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 c              do k=j+1,iend(i,iint)
2048               do k=j+1,nct
2049 C search over all next residues
2050                 if (dyn_ss_mask(k)) then
2051 C check if they are cysteins
2052 C              write(iout,*) 'k=',k
2053
2054 c              write(iout,*) "PRZED TRI", evdwij
2055                   evdwij_przed_tri=evdwij
2056                   call triple_ssbond_ene(i,j,k,evdwij)
2057 c               if(evdwij_przed_tri.ne.evdwij) then
2058 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2059 c               endif
2060
2061 c              write(iout,*) "PO TRI", evdwij
2062 C call the energy function that removes the artifical triple disulfide
2063 C bond the soubroutine is located in ssMD.F
2064                   evdw=evdw+evdwij
2065                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2066      &                        'evdw',i,j,evdwij,'tss'
2067                 endif!dyn_ss_mask(k)
2068               enddo! k
2069             ELSE
2070               ind=ind+1
2071               itypj=iabs(itype(j))
2072               if (itypj.eq.ntyp1) cycle
2073 c            dscj_inv=dsc_inv(itypj)
2074               dscj_inv=vbld_inv(j+nres)
2075 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2076 c     &       1.0d0/vbld(j+nres)
2077 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2078               sig0ij=sigma(itypi,itypj)
2079               chi1=chi(itypi,itypj)
2080               chi2=chi(itypj,itypi)
2081               chi12=chi1*chi2
2082               chip1=chip(itypi)
2083               chip2=chip(itypj)
2084               chip12=chip1*chip2
2085               alf1=alp(itypi)
2086               alf2=alp(itypj)
2087               alf12=0.5D0*(alf1+alf2)
2088 C For diagnostics only!!!
2089 c           chi1=0.0D0
2090 c           chi2=0.0D0
2091 c           chi12=0.0D0
2092 c           chip1=0.0D0
2093 c           chip2=0.0D0
2094 c           chip12=0.0D0
2095 c           alf1=0.0D0
2096 c           alf2=0.0D0
2097 c           alf12=0.0D0
2098               xj=c(1,nres+j)
2099               yj=c(2,nres+j)
2100               zj=c(3,nres+j)
2101               call to_box(xj,yj,zj)
2102               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2103               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2104      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2105               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2106      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2107 c            write (iout,*) "aa bb",aa_lip(itypi,itypj),
2108 c     &       bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2109 c     &       bb_aq(itypi,itypj),aa,bb
2110 c            write (iout,*) (sslipi+sslipj)/2.0d0,
2111 c     &        (2.0d0-sslipi-sslipj)/2.0d0
2112
2113 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2114 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2115 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2116 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2117 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2118               xj=boxshift(xj-xi,boxxsize)
2119               yj=boxshift(yj-yi,boxysize)
2120               zj=boxshift(zj-zi,boxzsize)
2121               dxj=dc_norm(1,nres+j)
2122               dyj=dc_norm(2,nres+j)
2123               dzj=dc_norm(3,nres+j)
2124 C            xj=xj-xi
2125 C            yj=yj-yi
2126 C            zj=zj-zi
2127 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2128 c            write (iout,*) "j",j," dc_norm",
2129 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2130               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2131               rij=dsqrt(rrij)
2132               sss=sscale(1.0d0/rij,r_cut_int)
2133 c            write (iout,'(a7,4f8.3)')
2134 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2135               if (sss.eq.0.0d0) cycle
2136               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2137 C Calculate angle-dependent terms of energy and contributions to their
2138 C derivatives.
2139               call sc_angular
2140               sigsq=1.0D0/sigsq
2141               sig=sig0ij*dsqrt(sigsq)
2142               rij_shift=1.0D0/rij-sig+sig0ij
2143 c              if (energy_dec)
2144 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2145 c     &       " sig",sig," sig0ij",sig0ij
2146 c for diagnostics; uncomment
2147 c            rij_shift=1.2*sig0ij
2148 C I hate to put IF's in the loops, but here don't have another choice!!!!
2149               if (rij_shift.le.0.0D0) then
2150                 evdw=1.0D20
2151 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2152 cd     &        restyp(itypi),i,restyp(itypj),j,
2153 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2154 c                return
2155               endif
2156               sigder=-sig*sigsq
2157 c---------------------------------------------------------------
2158               rij_shift=1.0D0/rij_shift
2159               fac=rij_shift**expon
2160 C here to start with
2161 C            if (c(i,3).gt.
2162               faclip=fac
2163               e1=fac*fac*aa
2164               e2=fac*bb
2165               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2166               eps2der=evdwij*eps3rt
2167               eps3der=evdwij*eps2rt
2168 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2169 C     &((sslipi+sslipj)/2.0d0+
2170 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2171 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2172 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2173               evdwij=evdwij*eps2rt*eps3rt
2174               evdw=evdw+evdwij*sss
2175               if (lprn) then
2176                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2177                 epsi=bb**2/aa
2178                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2179      &           restyp(itypi),i,restyp(itypj),j,
2180      &           epsi,sigm,chi1,chi2,chip1,chip2,
2181      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2182      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2183      &           evdwij
2184               endif
2185
2186               if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2187      &          'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2188
2189 C Calculate gradient components.
2190               e1=e1*eps1*eps2rt**2*eps3rt**2
2191               fac=-expon*(e1+evdwij)*rij_shift
2192               sigder=fac*sigder
2193               fac=rij*fac
2194 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2195 c     &      evdwij,fac,sigma(itypi,itypj),expon
2196               fac=fac+evdwij*sssgrad/sss*rij
2197 c            fac=0.0d0
2198 C Calculate the radial part of the gradient
2199               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2200      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2201      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2202      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2203               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2204               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2205 C            gg_lipi(3)=0.0d0
2206 C            gg_lipj(3)=0.0d0
2207               gg(1)=xj*fac
2208               gg(2)=yj*fac
2209               gg(3)=zj*fac
2210 C Calculate angular part of the gradient.
2211 c            call sc_grad_scale(sss)
2212               call sc_grad
2213             ENDIF    ! dyn_ss
2214 c          enddo      ! j
2215 c        enddo        ! iint
2216       enddo          ! i
2217 C      enddo          ! zshift
2218 C      enddo          ! yshift
2219 C      enddo          ! xshift
2220 c      write (iout,*) "Number of loop steps in EGB:",ind
2221 cccc      energy_dec=.false.
2222       return
2223       end
2224 C-----------------------------------------------------------------------------
2225       subroutine egbv(evdw)
2226 C
2227 C This subroutine calculates the interaction energy of nonbonded side chains
2228 C assuming the Gay-Berne-Vorobjev potential of interaction.
2229 C
2230       implicit none
2231       include 'DIMENSIONS'
2232       include 'COMMON.GEO'
2233       include 'COMMON.VAR'
2234       include 'COMMON.LOCAL'
2235       include 'COMMON.CHAIN'
2236       include 'COMMON.DERIV'
2237       include 'COMMON.NAMES'
2238       include 'COMMON.INTERACT'
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.CALC'
2241       include 'COMMON.SPLITELE'
2242       double precision boxshift
2243       integer icall
2244       common /srutu/ icall
2245       logical lprn
2246       double precision evdw
2247       integer itypi,itypj,itypi1,iint,ind,ikont
2248       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2249      & xi,yi,zi,fac_augm,e_augm
2250       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2251      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2252       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2253       evdw=0.0D0
2254 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2255       gg_lipi=0.0d0
2256       gg_lipj=0.0d0
2257       lprn=.false.
2258 c     if (icall.eq.0) lprn=.true.
2259       ind=0
2260 c      do i=iatsc_s,iatsc_e
2261       do ikont=g_listscsc_start,g_listscsc_end
2262         i=newcontlisti(ikont)
2263         j=newcontlistj(ikont)
2264         itypi=iabs(itype(i))
2265         if (itypi.eq.ntyp1) cycle
2266         itypi1=iabs(itype(i+1))
2267         xi=c(1,nres+i)
2268         yi=c(2,nres+i)
2269         zi=c(3,nres+i)
2270         call to_box(xi,yi,zi)
2271 C define scaling factor for lipids
2272
2273 C        if (positi.le.0) positi=positi+boxzsize
2274 C        print *,i
2275 C first for peptide groups
2276 c for each residue check if it is in lipid or lipid water border area
2277         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2278         dxi=dc_norm(1,nres+i)
2279         dyi=dc_norm(2,nres+i)
2280         dzi=dc_norm(3,nres+i)
2281 c        dsci_inv=dsc_inv(itypi)
2282         dsci_inv=vbld_inv(i+nres)
2283 C
2284 C Calculate SC interaction energy.
2285 C
2286 c        do iint=1,nint_gr(i)
2287 c          do j=istart(i,iint),iend(i,iint)
2288             ind=ind+1
2289             itypj=iabs(itype(j))
2290             if (itypj.eq.ntyp1) cycle
2291 c            dscj_inv=dsc_inv(itypj)
2292             dscj_inv=vbld_inv(j+nres)
2293             sig0ij=sigma(itypi,itypj)
2294             r0ij=r0(itypi,itypj)
2295             chi1=chi(itypi,itypj)
2296             chi2=chi(itypj,itypi)
2297             chi12=chi1*chi2
2298             chip1=chip(itypi)
2299             chip2=chip(itypj)
2300             chip12=chip1*chip2
2301             alf1=alp(itypi)
2302             alf2=alp(itypj)
2303             alf12=0.5D0*(alf1+alf2)
2304 C For diagnostics only!!!
2305 c           chi1=0.0D0
2306 c           chi2=0.0D0
2307 c           chi12=0.0D0
2308 c           chip1=0.0D0
2309 c           chip2=0.0D0
2310 c           chip12=0.0D0
2311 c           alf1=0.0D0
2312 c           alf2=0.0D0
2313 c           alf12=0.0D0
2314            xj=c(1,nres+j)
2315            yj=c(2,nres+j)
2316            zj=c(3,nres+j)
2317            call to_box(xj,yj,zj)
2318            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2319            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2320      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2321            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2322      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2323 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2324 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2325 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2326            xj=boxshift(xj-xi,boxxsize)
2327            yj=boxshift(yj-yi,boxysize)
2328            zj=boxshift(zj-zi,boxzsize)
2329            dxj=dc_norm(1,nres+j)
2330            dyj=dc_norm(2,nres+j)
2331            dzj=dc_norm(3,nres+j)
2332            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2333            rij=dsqrt(rrij)
2334            sss=sscale(1.0d0/rij,r_cut_int)
2335            if (sss.eq.0.0d0) cycle
2336            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2337 C Calculate angle-dependent terms of energy and contributions to their
2338 C derivatives.
2339            call sc_angular
2340            sigsq=1.0D0/sigsq
2341            sig=sig0ij*dsqrt(sigsq)
2342            rij_shift=1.0D0/rij-sig+r0ij
2343 C I hate to put IF's in the loops, but here don't have another choice!!!!
2344            if (rij_shift.le.0.0D0) then
2345              evdw=1.0D20
2346              return
2347            endif
2348            sigder=-sig*sigsq
2349 c---------------------------------------------------------------
2350            rij_shift=1.0D0/rij_shift
2351            fac=rij_shift**expon
2352            faclip=fac
2353            e1=fac*fac*aa
2354            e2=fac*bb
2355            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2356            eps2der=evdwij*eps3rt
2357            eps3der=evdwij*eps2rt
2358            fac_augm=rrij**expon
2359            e_augm=augm(itypi,itypj)*fac_augm
2360            evdwij=evdwij*eps2rt*eps3rt
2361            evdw=evdw+evdwij+e_augm
2362            if (lprn) then
2363              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2364              epsi=bb**2/aa
2365              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2366      &        restyp(itypi),i,restyp(itypj),j,
2367      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2368      &        chi1,chi2,chip1,chip2,
2369      &        eps1,eps2rt**2,eps3rt**2,
2370      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2371      &        evdwij+e_augm
2372            endif
2373 C Calculate gradient components.
2374            e1=e1*eps1*eps2rt**2*eps3rt**2
2375            fac=-expon*(e1+evdwij)*rij_shift
2376            sigder=fac*sigder
2377            fac=rij*fac-2*expon*rrij*e_augm
2378            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2379 C Calculate the radial part of the gradient
2380            gg_lipi(3)=eps1*(eps2rt*eps2rt)
2381      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2382      &       (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2383      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2384            gg_lipj(3)=ssgradlipj*gg_lipi(3)
2385            gg_lipi(3)=gg_lipi(3)*ssgradlipi
2386            gg(1)=xj*fac
2387            gg(2)=yj*fac
2388            gg(3)=zj*fac
2389 C Calculate angular part of the gradient.
2390 c            call sc_grad_scale(sss)
2391            call sc_grad
2392 c          enddo      ! j
2393 c        enddo        ! iint
2394       enddo          ! i
2395       end
2396 C-----------------------------------------------------------------------------
2397       subroutine sc_angular
2398 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2399 C om12. Called by ebp, egb, and egbv.
2400       implicit none
2401       include 'COMMON.CALC'
2402       include 'COMMON.IOUNITS'
2403       erij(1)=xj*rij
2404       erij(2)=yj*rij
2405       erij(3)=zj*rij
2406       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2407       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2408       om12=dxi*dxj+dyi*dyj+dzi*dzj
2409       chiom12=chi12*om12
2410 C Calculate eps1(om12) and its derivative in om12
2411       faceps1=1.0D0-om12*chiom12
2412       faceps1_inv=1.0D0/faceps1
2413       eps1=dsqrt(faceps1_inv)
2414 C Following variable is eps1*deps1/dom12
2415       eps1_om12=faceps1_inv*chiom12
2416 c diagnostics only
2417 c      faceps1_inv=om12
2418 c      eps1=om12
2419 c      eps1_om12=1.0d0
2420 c      write (iout,*) "om12",om12," eps1",eps1
2421 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2422 C and om12.
2423       om1om2=om1*om2
2424       chiom1=chi1*om1
2425       chiom2=chi2*om2
2426       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2427       sigsq=1.0D0-facsig*faceps1_inv
2428       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2429       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2430       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2431 c diagnostics only
2432 c      sigsq=1.0d0
2433 c      sigsq_om1=0.0d0
2434 c      sigsq_om2=0.0d0
2435 c      sigsq_om12=0.0d0
2436 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2437 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2438 c     &    " eps1",eps1
2439 C Calculate eps2 and its derivatives in om1, om2, and om12.
2440       chipom1=chip1*om1
2441       chipom2=chip2*om2
2442       chipom12=chip12*om12
2443       facp=1.0D0-om12*chipom12
2444       facp_inv=1.0D0/facp
2445       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2446 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2447 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2448 C Following variable is the square root of eps2
2449       eps2rt=1.0D0-facp1*facp_inv
2450 C Following three variables are the derivatives of the square root of eps
2451 C in om1, om2, and om12.
2452       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2453       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2454       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2455 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2456       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2457 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2458 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2459 c     &  " eps2rt_om12",eps2rt_om12
2460 C Calculate whole angle-dependent part of epsilon and contributions
2461 C to its derivatives
2462       return
2463       end
2464 C----------------------------------------------------------------------------
2465       subroutine sc_grad
2466       implicit real*8 (a-h,o-z)
2467       include 'DIMENSIONS'
2468       include 'COMMON.CHAIN'
2469       include 'COMMON.DERIV'
2470       include 'COMMON.CALC'
2471       include 'COMMON.IOUNITS'
2472       double precision dcosom1(3),dcosom2(3)
2473 cc      print *,'sss=',sss
2474       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2475       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2476       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2477      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2478 c diagnostics only
2479 c      eom1=0.0d0
2480 c      eom2=0.0d0
2481 c      eom12=evdwij*eps1_om12
2482 c end diagnostics
2483 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2484 c     &  " sigder",sigder
2485 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2486 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2487       do k=1,3
2488         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2489         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2490       enddo
2491       do k=1,3
2492         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2493       enddo
2494 c      write (iout,*) "gg",(gg(k),k=1,3)
2495       do k=1,3
2496         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2497      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2498      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2499         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2500      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2501      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2502 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2503 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2504 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2505 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2506       enddo
2507 C
2508 C Calculate the components of the gradient in DC and X
2509 C
2510 cgrad      do k=i,j-1
2511 cgrad        do l=1,3
2512 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2513 cgrad        enddo
2514 cgrad      enddo
2515       do l=1,3
2516         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2517         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2518       enddo
2519       return
2520       end
2521 C-----------------------------------------------------------------------
2522       subroutine e_softsphere(evdw)
2523 C
2524 C This subroutine calculates the interaction energy of nonbonded side chains
2525 C assuming the LJ potential of interaction.
2526 C
2527       implicit real*8 (a-h,o-z)
2528       include 'DIMENSIONS'
2529       parameter (accur=1.0d-10)
2530       include 'COMMON.GEO'
2531       include 'COMMON.VAR'
2532       include 'COMMON.LOCAL'
2533       include 'COMMON.CHAIN'
2534       include 'COMMON.DERIV'
2535       include 'COMMON.INTERACT'
2536       include 'COMMON.TORSION'
2537       include 'COMMON.SBRIDGE'
2538       include 'COMMON.NAMES'
2539       include 'COMMON.IOUNITS'
2540 c      include 'COMMON.CONTACTS'
2541       dimension gg(3)
2542       double precision boxshift
2543 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2544       evdw=0.0D0
2545 c      do i=iatsc_s,iatsc_e
2546       do ikont=g_listscsc_start,g_listscsc_end
2547         i=newcontlisti(ikont)
2548         j=newcontlistj(ikont)
2549         itypi=iabs(itype(i))
2550         if (itypi.eq.ntyp1) cycle
2551         itypi1=iabs(itype(i+1))
2552         xi=c(1,nres+i)
2553         yi=c(2,nres+i)
2554         zi=c(3,nres+i)
2555         call to_box(xi,yi,zi)
2556 C
2557 C Calculate SC interaction energy.
2558 C
2559 c        do iint=1,nint_gr(i)
2560 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2561 cd   &                  'iend=',iend(i,iint)
2562 c          do j=istart(i,iint),iend(i,iint)
2563             itypj=iabs(itype(j))
2564             if (itypj.eq.ntyp1) cycle
2565             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2566             yj=boxshift(c(2,nres+j)-yi,boxysize)
2567             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2568             rij=xj*xj+yj*yj+zj*zj
2569 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2570             r0ij=r0(itypi,itypj)
2571             r0ijsq=r0ij*r0ij
2572 c            print *,i,j,r0ij,dsqrt(rij)
2573             if (rij.lt.r0ijsq) then
2574               evdwij=0.25d0*(rij-r0ijsq)**2
2575               fac=rij-r0ijsq
2576             else
2577               evdwij=0.0d0
2578               fac=0.0d0
2579             endif
2580             evdw=evdw+evdwij
2581 C
2582 C Calculate the components of the gradient in DC and X
2583 C
2584             gg(1)=xj*fac
2585             gg(2)=yj*fac
2586             gg(3)=zj*fac
2587             do k=1,3
2588               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2589               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2590               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2591               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2592             enddo
2593 cgrad            do k=i,j-1
2594 cgrad              do l=1,3
2595 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2596 cgrad              enddo
2597 cgrad            enddo
2598 c          enddo ! j
2599 c        enddo ! iint
2600       enddo ! i
2601       return
2602       end
2603 C--------------------------------------------------------------------------
2604       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2605      &              eello_turn4)
2606 C
2607 C Soft-sphere potential of p-p interaction
2608 C
2609       implicit real*8 (a-h,o-z)
2610       include 'DIMENSIONS'
2611       include 'COMMON.CONTROL'
2612       include 'COMMON.IOUNITS'
2613       include 'COMMON.GEO'
2614       include 'COMMON.VAR'
2615       include 'COMMON.LOCAL'
2616       include 'COMMON.CHAIN'
2617       include 'COMMON.DERIV'
2618       include 'COMMON.INTERACT'
2619 c      include 'COMMON.CONTACTS'
2620       include 'COMMON.TORSION'
2621       include 'COMMON.VECTORS'
2622       include 'COMMON.FFIELD'
2623       dimension ggg(3)
2624       double precision boxshift
2625 C      write(iout,*) 'In EELEC_soft_sphere'
2626       ees=0.0D0
2627       evdw1=0.0D0
2628       eel_loc=0.0d0
2629       eello_turn3=0.0d0
2630       eello_turn4=0.0d0
2631       ind=0
2632       do i=iatel_s,iatel_e
2633         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2634         dxi=dc(1,i)
2635         dyi=dc(2,i)
2636         dzi=dc(3,i)
2637         xmedi=c(1,i)+0.5d0*dxi
2638         ymedi=c(2,i)+0.5d0*dyi
2639         zmedi=c(3,i)+0.5d0*dzi
2640         call to_box(xmedi,ymedi,zmedi)
2641         num_conti=0
2642 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2643         do j=ielstart(i),ielend(i)
2644           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2645           ind=ind+1
2646           iteli=itel(i)
2647           itelj=itel(j)
2648           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2649           r0ij=rpp(iteli,itelj)
2650           r0ijsq=r0ij*r0ij
2651           dxj=dc(1,j)
2652           dyj=dc(2,j)
2653           dzj=dc(3,j)
2654           xj=c(1,j)+0.5D0*dxj
2655           yj=c(2,j)+0.5D0*dyj
2656           zj=c(3,j)+0.5D0*dzj
2657           call to_box(xj,yj,zj)
2658           xj=boxshift(xj-xmedi,boxxsize)
2659           yj=boxshift(yj-ymedi,boxysize)
2660           zj=boxshift(zj-zmedi,boxzsize)
2661           rij=xj*xj+yj*yj+zj*zj
2662             sss=sscale(sqrt(rij),r_cut_int)
2663             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2664           if (rij.lt.r0ijsq) then
2665             evdw1ij=0.25d0*(rij-r0ijsq)**2
2666             fac=rij-r0ijsq
2667           else
2668             evdw1ij=0.0d0
2669             fac=0.0d0
2670           endif
2671           evdw1=evdw1+evdw1ij*sss
2672 C
2673 C Calculate contributions to the Cartesian gradient.
2674 C
2675           ggg(1)=fac*xj*sssgrad
2676           ggg(2)=fac*yj*sssgrad
2677           ggg(3)=fac*zj*sssgrad
2678           do k=1,3
2679             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2680             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2681           enddo
2682 *
2683 * Loop over residues i+1 thru j-1.
2684 *
2685 cgrad          do k=i+1,j-1
2686 cgrad            do l=1,3
2687 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2688 cgrad            enddo
2689 cgrad          enddo
2690         enddo ! j
2691       enddo   ! i
2692 cgrad      do i=nnt,nct-1
2693 cgrad        do k=1,3
2694 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2695 cgrad        enddo
2696 cgrad        do j=i+1,nct-1
2697 cgrad          do k=1,3
2698 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2699 cgrad          enddo
2700 cgrad        enddo
2701 cgrad      enddo
2702       return
2703       end
2704 c------------------------------------------------------------------------------
2705       subroutine vec_and_deriv
2706       implicit real*8 (a-h,o-z)
2707       include 'DIMENSIONS'
2708 #ifdef MPI
2709       include 'mpif.h'
2710 #endif
2711       include 'COMMON.IOUNITS'
2712       include 'COMMON.GEO'
2713       include 'COMMON.VAR'
2714       include 'COMMON.LOCAL'
2715       include 'COMMON.CHAIN'
2716       include 'COMMON.VECTORS'
2717       include 'COMMON.SETUP'
2718       include 'COMMON.TIME1'
2719       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2720 C Compute the local reference systems. For reference system (i), the
2721 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2722 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2723 #ifdef PARVEC
2724       do i=ivec_start,ivec_end
2725 #else
2726       do i=1,nres-1
2727 #endif
2728           if (i.eq.nres-1) then
2729 C Case of the last full residue
2730 C Compute the Z-axis
2731             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2732             costh=dcos(pi-theta(nres))
2733             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2734             do k=1,3
2735               uz(k,i)=fac*uz(k,i)
2736             enddo
2737 C Compute the derivatives of uz
2738             uzder(1,1,1)= 0.0d0
2739             uzder(2,1,1)=-dc_norm(3,i-1)
2740             uzder(3,1,1)= dc_norm(2,i-1)
2741             uzder(1,2,1)= dc_norm(3,i-1)
2742             uzder(2,2,1)= 0.0d0
2743             uzder(3,2,1)=-dc_norm(1,i-1)
2744             uzder(1,3,1)=-dc_norm(2,i-1)
2745             uzder(2,3,1)= dc_norm(1,i-1)
2746             uzder(3,3,1)= 0.0d0
2747             uzder(1,1,2)= 0.0d0
2748             uzder(2,1,2)= dc_norm(3,i)
2749             uzder(3,1,2)=-dc_norm(2,i)
2750             uzder(1,2,2)=-dc_norm(3,i)
2751             uzder(2,2,2)= 0.0d0
2752             uzder(3,2,2)= dc_norm(1,i)
2753             uzder(1,3,2)= dc_norm(2,i)
2754             uzder(2,3,2)=-dc_norm(1,i)
2755             uzder(3,3,2)= 0.0d0
2756 C Compute the Y-axis
2757             facy=fac
2758             do k=1,3
2759               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2760             enddo
2761 C Compute the derivatives of uy
2762             do j=1,3
2763               do k=1,3
2764                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2765      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2766                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2767               enddo
2768               uyder(j,j,1)=uyder(j,j,1)-costh
2769               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2770             enddo
2771             do j=1,2
2772               do k=1,3
2773                 do l=1,3
2774                   uygrad(l,k,j,i)=uyder(l,k,j)
2775                   uzgrad(l,k,j,i)=uzder(l,k,j)
2776                 enddo
2777               enddo
2778             enddo
2779             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2780             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2781             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2782             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2783           else
2784 C Other residues
2785 C Compute the Z-axis
2786             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2787             costh=dcos(pi-theta(i+2))
2788             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2789             do k=1,3
2790               uz(k,i)=fac*uz(k,i)
2791             enddo
2792 C Compute the derivatives of uz
2793             uzder(1,1,1)= 0.0d0
2794             uzder(2,1,1)=-dc_norm(3,i+1)
2795             uzder(3,1,1)= dc_norm(2,i+1)
2796             uzder(1,2,1)= dc_norm(3,i+1)
2797             uzder(2,2,1)= 0.0d0
2798             uzder(3,2,1)=-dc_norm(1,i+1)
2799             uzder(1,3,1)=-dc_norm(2,i+1)
2800             uzder(2,3,1)= dc_norm(1,i+1)
2801             uzder(3,3,1)= 0.0d0
2802             uzder(1,1,2)= 0.0d0
2803             uzder(2,1,2)= dc_norm(3,i)
2804             uzder(3,1,2)=-dc_norm(2,i)
2805             uzder(1,2,2)=-dc_norm(3,i)
2806             uzder(2,2,2)= 0.0d0
2807             uzder(3,2,2)= dc_norm(1,i)
2808             uzder(1,3,2)= dc_norm(2,i)
2809             uzder(2,3,2)=-dc_norm(1,i)
2810             uzder(3,3,2)= 0.0d0
2811 C Compute the Y-axis
2812             facy=fac
2813             do k=1,3
2814               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2815             enddo
2816 C Compute the derivatives of uy
2817             do j=1,3
2818               do k=1,3
2819                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2820      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2821                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2822               enddo
2823               uyder(j,j,1)=uyder(j,j,1)-costh
2824               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2825             enddo
2826             do j=1,2
2827               do k=1,3
2828                 do l=1,3
2829                   uygrad(l,k,j,i)=uyder(l,k,j)
2830                   uzgrad(l,k,j,i)=uzder(l,k,j)
2831                 enddo
2832               enddo
2833             enddo
2834             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2835             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2836             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2837             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2838           endif
2839       enddo
2840       do i=1,nres-1
2841         vbld_inv_temp(1)=vbld_inv(i+1)
2842         if (i.lt.nres-1) then
2843           vbld_inv_temp(2)=vbld_inv(i+2)
2844           else
2845           vbld_inv_temp(2)=vbld_inv(i)
2846           endif
2847         do j=1,2
2848           do k=1,3
2849             do l=1,3
2850               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2851               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2852             enddo
2853           enddo
2854         enddo
2855       enddo
2856 #if defined(PARVEC) && defined(MPI)
2857       if (nfgtasks1.gt.1) then
2858         time00=MPI_Wtime()
2859 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2860 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2861 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2862         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2863      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2864      &   FG_COMM1,IERR)
2865         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2866      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2867      &   FG_COMM1,IERR)
2868         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2869      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2870      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2871         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2872      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2873      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2874         time_gather=time_gather+MPI_Wtime()-time00
2875       endif
2876 #endif
2877 #ifdef DEBUG
2878       if (fg_rank.eq.0) then
2879         write (iout,*) "Arrays UY and UZ"
2880         do i=1,nres-1
2881           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2882      &     (uz(k,i),k=1,3)
2883         enddo
2884       endif
2885 #endif
2886       return
2887       end
2888 C--------------------------------------------------------------------------
2889       subroutine set_matrices
2890       implicit real*8 (a-h,o-z)
2891       include 'DIMENSIONS'
2892 #ifdef MPI
2893       include "mpif.h"
2894       include "COMMON.SETUP"
2895       integer IERR
2896       integer status(MPI_STATUS_SIZE)
2897 #endif
2898       include 'COMMON.IOUNITS'
2899       include 'COMMON.GEO'
2900       include 'COMMON.VAR'
2901       include 'COMMON.LOCAL'
2902       include 'COMMON.CHAIN'
2903       include 'COMMON.DERIV'
2904       include 'COMMON.INTERACT'
2905       include 'COMMON.CORRMAT'
2906       include 'COMMON.TORSION'
2907       include 'COMMON.VECTORS'
2908       include 'COMMON.FFIELD'
2909       double precision auxvec(2),auxmat(2,2)
2910 C
2911 C Compute the virtual-bond-torsional-angle dependent quantities needed
2912 C to calculate the el-loc multibody terms of various order.
2913 C
2914 c      write(iout,*) 'nphi=',nphi,nres
2915 c      write(iout,*) "itype2loc",itype2loc
2916 #ifdef PARMAT
2917       do i=ivec_start+2,ivec_end+2
2918 #else
2919       do i=3,nres+1
2920 #endif
2921         ii=ireschain(i-2)
2922 c        write (iout,*) "i",i,i-2," ii",ii
2923         if (ii.eq.0) cycle
2924         innt=chain_border(1,ii)
2925         inct=chain_border(2,ii)
2926 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2927 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2928         if (i.gt. innt+2 .and. i.lt.inct+2) then
2929           iti = itype2loc(itype(i-2))
2930         else
2931           iti=nloctyp
2932         endif
2933 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2934         if (i.gt. innt+1 .and. i.lt.inct+1) then
2935           iti1 = itype2loc(itype(i-1))
2936         else
2937           iti1=nloctyp
2938         endif
2939 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2940 c     &  " iti1",itype(i-1),iti1
2941 #ifdef NEWCORR
2942         cost1=dcos(theta(i-1))
2943         sint1=dsin(theta(i-1))
2944         sint1sq=sint1*sint1
2945         sint1cub=sint1sq*sint1
2946         sint1cost1=2*sint1*cost1
2947 c        write (iout,*) "bnew1",i,iti
2948 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2949 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2950 c        write (iout,*) "bnew2",i,iti
2951 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2952 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2953         do k=1,2
2954           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2955           b1(k,i-2)=sint1*b1k
2956           gtb1(k,i-2)=cost1*b1k-sint1sq*
2957      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2958           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2959           b2(k,i-2)=sint1*b2k
2960           gtb2(k,i-2)=cost1*b2k-sint1sq*
2961      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2962         enddo
2963         do k=1,2
2964           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2965           cc(1,k,i-2)=sint1sq*aux
2966           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2967      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2968           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2969           dd(1,k,i-2)=sint1sq*aux
2970           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2971      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2972         enddo
2973         cc(2,1,i-2)=cc(1,2,i-2)
2974         cc(2,2,i-2)=-cc(1,1,i-2)
2975         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2976         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2977         dd(2,1,i-2)=dd(1,2,i-2)
2978         dd(2,2,i-2)=-dd(1,1,i-2)
2979         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2980         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2981         do k=1,2
2982           do l=1,2
2983             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2984             EE(l,k,i-2)=sint1sq*aux
2985             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2986           enddo
2987         enddo
2988         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2989         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2990         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2991         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2992         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2993         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2994         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2995 c        b1tilde(1,i-2)=b1(1,i-2)
2996 c        b1tilde(2,i-2)=-b1(2,i-2)
2997 c        b2tilde(1,i-2)=b2(1,i-2)
2998 c        b2tilde(2,i-2)=-b2(2,i-2)
2999 #ifdef DEBUG
3000         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3002         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3003         write (iout,*) 'theta=', theta(i-1)
3004 #endif
3005 #else
3006         if (i.gt. innt+2 .and. i.lt.inct+2) then
3007 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3008           iti = itype2loc(itype(i-2))
3009         else
3010           iti=nloctyp
3011         endif
3012 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3013 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3014         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3015           iti1 = itype2loc(itype(i-1))
3016         else
3017           iti1=nloctyp
3018         endif
3019         b1(1,i-2)=b(3,iti)
3020         b1(2,i-2)=b(5,iti)
3021         b2(1,i-2)=b(2,iti)
3022         b2(2,i-2)=b(4,iti)
3023         do k=1,2
3024           do l=1,2
3025            CC(k,l,i-2)=ccold(k,l,iti)
3026            DD(k,l,i-2)=ddold(k,l,iti)
3027            EE(k,l,i-2)=eeold(k,l,iti)
3028            gtEE(k,l,i-2)=0.0d0
3029           enddo
3030         enddo
3031 #endif
3032         b1tilde(1,i-2)= b1(1,i-2)
3033         b1tilde(2,i-2)=-b1(2,i-2)
3034         b2tilde(1,i-2)= b2(1,i-2)
3035         b2tilde(2,i-2)=-b2(2,i-2)
3036 c
3037         Ctilde(1,1,i-2)= CC(1,1,i-2)
3038         Ctilde(1,2,i-2)= CC(1,2,i-2)
3039         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3040         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3041 c
3042         Dtilde(1,1,i-2)= DD(1,1,i-2)
3043         Dtilde(1,2,i-2)= DD(1,2,i-2)
3044         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3045         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3046 #ifdef DEBUG
3047         write(iout,*) "i",i," iti",iti
3048         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3049         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3050 #endif
3051       enddo
3052       mu=0.0d0
3053 #ifdef PARMAT
3054       do i=ivec_start+2,ivec_end+2
3055 #else
3056       do i=3,nres+1
3057 #endif
3058 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3059         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3060           sin1=dsin(phi(i))
3061           cos1=dcos(phi(i))
3062           sintab(i-2)=sin1
3063           costab(i-2)=cos1
3064           obrot(1,i-2)=cos1
3065           obrot(2,i-2)=sin1
3066           sin2=dsin(2*phi(i))
3067           cos2=dcos(2*phi(i))
3068           sintab2(i-2)=sin2
3069           costab2(i-2)=cos2
3070           obrot2(1,i-2)=cos2
3071           obrot2(2,i-2)=sin2
3072           Ug(1,1,i-2)=-cos1
3073           Ug(1,2,i-2)=-sin1
3074           Ug(2,1,i-2)=-sin1
3075           Ug(2,2,i-2)= cos1
3076           Ug2(1,1,i-2)=-cos2
3077           Ug2(1,2,i-2)=-sin2
3078           Ug2(2,1,i-2)=-sin2
3079           Ug2(2,2,i-2)= cos2
3080         else
3081           costab(i-2)=1.0d0
3082           sintab(i-2)=0.0d0
3083           obrot(1,i-2)=1.0d0
3084           obrot(2,i-2)=0.0d0
3085           obrot2(1,i-2)=0.0d0
3086           obrot2(2,i-2)=0.0d0
3087           Ug(1,1,i-2)=1.0d0
3088           Ug(1,2,i-2)=0.0d0
3089           Ug(2,1,i-2)=0.0d0
3090           Ug(2,2,i-2)=1.0d0
3091           Ug2(1,1,i-2)=0.0d0
3092           Ug2(1,2,i-2)=0.0d0
3093           Ug2(2,1,i-2)=0.0d0
3094           Ug2(2,2,i-2)=0.0d0
3095         endif
3096         if (i .gt. 3) then
3097           obrot_der(1,i-2)=-sin1
3098           obrot_der(2,i-2)= cos1
3099           Ugder(1,1,i-2)= sin1
3100           Ugder(1,2,i-2)=-cos1
3101           Ugder(2,1,i-2)=-cos1
3102           Ugder(2,2,i-2)=-sin1
3103           dwacos2=cos2+cos2
3104           dwasin2=sin2+sin2
3105           obrot2_der(1,i-2)=-dwasin2
3106           obrot2_der(2,i-2)= dwacos2
3107           Ug2der(1,1,i-2)= dwasin2
3108           Ug2der(1,2,i-2)=-dwacos2
3109           Ug2der(2,1,i-2)=-dwacos2
3110           Ug2der(2,2,i-2)=-dwasin2
3111         else
3112           obrot_der(1,i-2)=0.0d0
3113           obrot_der(2,i-2)=0.0d0
3114           Ugder(1,1,i-2)=0.0d0
3115           Ugder(1,2,i-2)=0.0d0
3116           Ugder(2,1,i-2)=0.0d0
3117           Ugder(2,2,i-2)=0.0d0
3118           obrot2_der(1,i-2)=0.0d0
3119           obrot2_der(2,i-2)=0.0d0
3120           Ug2der(1,1,i-2)=0.0d0
3121           Ug2der(1,2,i-2)=0.0d0
3122           Ug2der(2,1,i-2)=0.0d0
3123           Ug2der(2,2,i-2)=0.0d0
3124         endif
3125 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3126 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3127         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3128           iti = itype2loc(itype(i-2))
3129         else
3130           iti=nloctyp
3131         endif
3132 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3133         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3134           iti1 = itype2loc(itype(i-1))
3135         else
3136           iti1=nloctyp
3137         endif
3138 cd        write (iout,*) '*******i',i,' iti1',iti
3139 cd        write (iout,*) 'b1',b1(:,iti)
3140 cd        write (iout,*) 'b2',b2(:,iti)
3141 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3142 c        if (i .gt. iatel_s+2) then
3143         if (i .gt. nnt+2) then
3144           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3145 #ifdef NEWCORR
3146           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3147 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3148 #endif
3149 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3150 c     &    EE(1,2,iti),EE(2,2,i)
3151           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3152           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3153 c          write(iout,*) "Macierz EUG",
3154 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3155 c     &    eug(2,2,i-2)
3156 #ifdef FOURBODY
3157           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3158      &    then
3159           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3160           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3161           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3162           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3163           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3164           endif
3165 #endif
3166         else
3167           do k=1,2
3168             Ub2(k,i-2)=0.0d0
3169             Ctobr(k,i-2)=0.0d0
3170             Dtobr2(k,i-2)=0.0d0
3171             do l=1,2
3172               EUg(l,k,i-2)=0.0d0
3173               CUg(l,k,i-2)=0.0d0
3174               DUg(l,k,i-2)=0.0d0
3175               DtUg2(l,k,i-2)=0.0d0
3176             enddo
3177           enddo
3178         endif
3179         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3180         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3181         do k=1,2
3182           muder(k,i-2)=Ub2der(k,i-2)
3183         enddo
3184 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3185         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3186           if (itype(i-1).le.ntyp) then
3187             iti1 = itype2loc(itype(i-1))
3188           else
3189             iti1=nloctyp
3190           endif
3191         else
3192           iti1=nloctyp
3193         endif
3194         do k=1,2
3195           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3196 c          mu(k,i-2)=b1(k,i-1)
3197 c          mu(k,i-2)=Ub2(k,i-2)
3198         enddo
3199 #ifdef MUOUT
3200         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3201      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3202      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3203      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3204      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3205      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3206 #endif
3207 cd        write (iout,*) 'mu1',mu1(:,i-2)
3208 cd        write (iout,*) 'mu2',mu2(:,i-2)
3209 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3210 #ifdef FOURBODY
3211         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3212      &  then
3213         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3214         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3215         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3216         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3217         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3218 C Vectors and matrices dependent on a single virtual-bond dihedral.
3219         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3220         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3221         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3222         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3223         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3224         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3225         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3226         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3227         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3228         endif
3229 #endif
3230       enddo
3231 #ifdef FOURBODY
3232 C Matrices dependent on two consecutive virtual-bond dihedrals.
3233 C The order of matrices is from left to right.
3234       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3235      &then
3236 c      do i=max0(ivec_start,2),ivec_end
3237       do i=2,nres-1
3238         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3239         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3240         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3241         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3242         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3243         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3244         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3245         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3246       enddo
3247       endif
3248 #endif
3249 #if defined(MPI) && defined(PARMAT)
3250 #ifdef DEBUG
3251 c      if (fg_rank.eq.0) then
3252         write (iout,*) "Arrays UG and UGDER before GATHER"
3253         do i=1,nres-1
3254           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3255      &     ((ug(l,k,i),l=1,2),k=1,2),
3256      &     ((ugder(l,k,i),l=1,2),k=1,2)
3257         enddo
3258         write (iout,*) "Arrays UG2 and UG2DER"
3259         do i=1,nres-1
3260           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3261      &     ((ug2(l,k,i),l=1,2),k=1,2),
3262      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3263         enddo
3264         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3265         do i=1,nres-1
3266           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3267      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3268      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3269         enddo
3270         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3271         do i=1,nres-1
3272           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3273      &     costab(i),sintab(i),costab2(i),sintab2(i)
3274         enddo
3275         write (iout,*) "Array MUDER"
3276         do i=1,nres-1
3277           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3278         enddo
3279 c      endif
3280 #endif
3281       if (nfgtasks.gt.1) then
3282         time00=MPI_Wtime()
3283 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3284 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3285 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3286 #ifdef MATGATHER
3287         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3288      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3289      &   FG_COMM1,IERR)
3290         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3291      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3292      &   FG_COMM1,IERR)
3293         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3294      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3295      &   FG_COMM1,IERR)
3296         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3297      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3298      &   FG_COMM1,IERR)
3299         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3300      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3301      &   FG_COMM1,IERR)
3302         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3303      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3304      &   FG_COMM1,IERR)
3305         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3306      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3307      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3308         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3309      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3310      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3311         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3312      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3313      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3314         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3315      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3316      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3317 #ifdef FOURBODY
3318         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3319      &  then
3320         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3321      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3322      &   FG_COMM1,IERR)
3323         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3324      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3325      &   FG_COMM1,IERR)
3326         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3327      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3328      &   FG_COMM1,IERR)
3329        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3331      &   FG_COMM1,IERR)
3332         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3336      &   ivec_count(fg_rank1),
3337      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3338      &   FG_COMM1,IERR)
3339         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3340      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3341      &   FG_COMM1,IERR)
3342         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3343      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3344      &   FG_COMM1,IERR)
3345         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3346      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3347      &   FG_COMM1,IERR)
3348         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3349      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3350      &   FG_COMM1,IERR)
3351         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3352      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3353      &   FG_COMM1,IERR)
3354         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3355      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3356      &   FG_COMM1,IERR)
3357         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3358      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3359      &   FG_COMM1,IERR)
3360         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3361      &   ivec_count(fg_rank1),
3362      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3363      &   FG_COMM1,IERR)
3364         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3365      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3366      &   FG_COMM1,IERR)
3367        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3368      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3369      &   FG_COMM1,IERR)
3370         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3371      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3372      &   FG_COMM1,IERR)
3373        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3374      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3375      &   FG_COMM1,IERR)
3376         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3377      &   ivec_count(fg_rank1),
3378      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3379      &   FG_COMM1,IERR)
3380         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3381      &   ivec_count(fg_rank1),
3382      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3383      &   FG_COMM1,IERR)
3384         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3385      &   ivec_count(fg_rank1),
3386      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3387      &   MPI_MAT2,FG_COMM1,IERR)
3388         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3389      &   ivec_count(fg_rank1),
3390      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3391      &   MPI_MAT2,FG_COMM1,IERR)
3392         endif
3393 #endif
3394 #else
3395 c Passes matrix info through the ring
3396       isend=fg_rank1
3397       irecv=fg_rank1-1
3398       if (irecv.lt.0) irecv=nfgtasks1-1
3399       iprev=irecv
3400       inext=fg_rank1+1
3401       if (inext.ge.nfgtasks1) inext=0
3402       do i=1,nfgtasks1-1
3403 c        write (iout,*) "isend",isend," irecv",irecv
3404 c        call flush(iout)
3405         lensend=lentyp(isend)
3406         lenrecv=lentyp(irecv)
3407 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3408 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3409 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3410 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3411 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3412 c        write (iout,*) "Gather ROTAT1"
3413 c        call flush(iout)
3414 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3415 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3416 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3417 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3418 c        write (iout,*) "Gather ROTAT2"
3419 c        call flush(iout)
3420         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3421      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3422      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3423      &   iprev,4400+irecv,FG_COMM,status,IERR)
3424 c        write (iout,*) "Gather ROTAT_OLD"
3425 c        call flush(iout)
3426         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3427      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3428      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3429      &   iprev,5500+irecv,FG_COMM,status,IERR)
3430 c        write (iout,*) "Gather PRECOMP11"
3431 c        call flush(iout)
3432         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3433      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3434      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3435      &   iprev,6600+irecv,FG_COMM,status,IERR)
3436 c        write (iout,*) "Gather PRECOMP12"
3437 c        call flush(iout)
3438 #ifdef FOURBODY
3439         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3440      &  then
3441         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3442      &   MPI_ROTAT2(lensend),inext,7700+isend,
3443      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3444      &   iprev,7700+irecv,FG_COMM,status,IERR)
3445 c        write (iout,*) "Gather PRECOMP21"
3446 c        call flush(iout)
3447         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3448      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3449      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3450      &   iprev,8800+irecv,FG_COMM,status,IERR)
3451 c        write (iout,*) "Gather PRECOMP22"
3452 c        call flush(iout)
3453         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3454      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3455      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3456      &   MPI_PRECOMP23(lenrecv),
3457      &   iprev,9900+irecv,FG_COMM,status,IERR)
3458 #endif
3459 c        write (iout,*) "Gather PRECOMP23"
3460 c        call flush(iout)
3461         endif
3462         isend=irecv
3463         irecv=irecv-1
3464         if (irecv.lt.0) irecv=nfgtasks1-1
3465       enddo
3466 #endif
3467         time_gather=time_gather+MPI_Wtime()-time00
3468       endif
3469 #ifdef DEBUG
3470 c      if (fg_rank.eq.0) then
3471         write (iout,*) "Arrays UG and UGDER"
3472         do i=1,nres-1
3473           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3474      &     ((ug(l,k,i),l=1,2),k=1,2),
3475      &     ((ugder(l,k,i),l=1,2),k=1,2)
3476         enddo
3477         write (iout,*) "Arrays UG2 and UG2DER"
3478         do i=1,nres-1
3479           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3480      &     ((ug2(l,k,i),l=1,2),k=1,2),
3481      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3482         enddo
3483         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3484         do i=1,nres-1
3485           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3486      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3487      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3488         enddo
3489         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3490         do i=1,nres-1
3491           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3492      &     costab(i),sintab(i),costab2(i),sintab2(i)
3493         enddo
3494         write (iout,*) "Array MUDER"
3495         do i=1,nres-1
3496           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3497         enddo
3498 c      endif
3499 #endif
3500 #endif
3501 cd      do i=1,nres
3502 cd        iti = itype2loc(itype(i))
3503 cd        write (iout,*) i
3504 cd        do j=1,2
3505 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3506 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3507 cd        enddo
3508 cd      enddo
3509       return
3510       end
3511 C-----------------------------------------------------------------------------
3512       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3513 C
3514 C This subroutine calculates the average interaction energy and its gradient
3515 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3516 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3517 C The potential depends both on the distance of peptide-group centers and on
3518 C the orientation of the CA-CA virtual bonds.
3519 C
3520       implicit real*8 (a-h,o-z)
3521 #ifdef MPI
3522       include 'mpif.h'
3523 #endif
3524       include 'DIMENSIONS'
3525       include 'COMMON.CONTROL'
3526       include 'COMMON.SETUP'
3527       include 'COMMON.IOUNITS'
3528       include 'COMMON.GEO'
3529       include 'COMMON.VAR'
3530       include 'COMMON.LOCAL'
3531       include 'COMMON.CHAIN'
3532       include 'COMMON.DERIV'
3533       include 'COMMON.INTERACT'
3534 #ifdef FOURBODY
3535       include 'COMMON.CONTACTS'
3536       include 'COMMON.CONTMAT'
3537 #endif
3538       include 'COMMON.CORRMAT'
3539       include 'COMMON.TORSION'
3540       include 'COMMON.VECTORS'
3541       include 'COMMON.FFIELD'
3542       include 'COMMON.TIME1'
3543       include 'COMMON.SPLITELE'
3544       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3545      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3546       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3547      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3548       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3549      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3550      &    num_conti,j1,j2
3551       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3552       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3553 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3554 #ifdef MOMENT
3555       double precision scal_el /1.0d0/
3556 #else
3557       double precision scal_el /0.5d0/
3558 #endif
3559 C 12/13/98
3560 C 13-go grudnia roku pamietnego...
3561       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3562      &                   0.0d0,1.0d0,0.0d0,
3563      &                   0.0d0,0.0d0,1.0d0/
3564 cd      write(iout,*) 'In EELEC'
3565 cd      do i=1,nloctyp
3566 cd        write(iout,*) 'Type',i
3567 cd        write(iout,*) 'B1',B1(:,i)
3568 cd        write(iout,*) 'B2',B2(:,i)
3569 cd        write(iout,*) 'CC',CC(:,:,i)
3570 cd        write(iout,*) 'DD',DD(:,:,i)
3571 cd        write(iout,*) 'EE',EE(:,:,i)
3572 cd      enddo
3573 cd      call check_vecgrad
3574 cd      stop
3575       if (icheckgrad.eq.1) then
3576         do i=1,nres-1
3577           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3578           do k=1,3
3579             dc_norm(k,i)=dc(k,i)*fac
3580           enddo
3581 c          write (iout,*) 'i',i,' fac',fac
3582         enddo
3583       endif
3584       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3585      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3586      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3587 c        call vec_and_deriv
3588 #ifdef TIMING
3589         time01=MPI_Wtime()
3590 #endif
3591         call set_matrices
3592 #ifdef TIMING
3593         time_mat=time_mat+MPI_Wtime()-time01
3594 #endif
3595       endif
3596 cd      do i=1,nres-1
3597 cd        write (iout,*) 'i=',i
3598 cd        do k=1,3
3599 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3600 cd        enddo
3601 cd        do k=1,3
3602 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3603 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3604 cd        enddo
3605 cd      enddo
3606       t_eelecij=0.0d0
3607       ees=0.0D0
3608       evdw1=0.0D0
3609       eel_loc=0.0d0
3610       eello_turn3=0.0d0
3611       eello_turn4=0.0d0
3612       ind=0
3613 #ifdef FOURBODY
3614       do i=1,nres
3615         num_cont_hb(i)=0
3616       enddo
3617 #endif
3618 cd      print '(a)','Enter EELEC'
3619 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3620       do i=1,nres
3621         gel_loc_loc(i)=0.0d0
3622         gcorr_loc(i)=0.0d0
3623       enddo
3624 c
3625 c
3626 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3627 C
3628 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3629 C
3630 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3631       do i=iturn3_start,iturn3_end
3632 c        if (i.le.1) cycle
3633 C        write(iout,*) "tu jest i",i
3634         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3635 C changes suggested by Ana to avoid out of bounds
3636 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3637 c     & .or.((i+4).gt.nres)
3638 c     & .or.((i-1).le.0)
3639 C end of changes by Ana
3640      &  .or. itype(i+2).eq.ntyp1
3641      &  .or. itype(i+3).eq.ntyp1) cycle
3642 C Adam: Instructions below will switch off existing interactions
3643 c        if(i.gt.1)then
3644 c          if(itype(i-1).eq.ntyp1)cycle
3645 c        end if
3646 c        if(i.LT.nres-3)then
3647 c          if (itype(i+4).eq.ntyp1) cycle
3648 c        end if
3649         dxi=dc(1,i)
3650         dyi=dc(2,i)
3651         dzi=dc(3,i)
3652         dx_normi=dc_norm(1,i)
3653         dy_normi=dc_norm(2,i)
3654         dz_normi=dc_norm(3,i)
3655         xmedi=c(1,i)+0.5d0*dxi
3656         ymedi=c(2,i)+0.5d0*dyi
3657         zmedi=c(3,i)+0.5d0*dzi
3658         call to_box(xmedi,ymedi,zmedi)
3659         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3660         num_conti=0
3661         call eelecij(i,i+2,ees,evdw1,eel_loc)
3662         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3663 #ifdef FOURBODY
3664         num_cont_hb(i)=num_conti
3665 #endif
3666       enddo
3667       do i=iturn4_start,iturn4_end
3668         if (i.lt.1) cycle
3669         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3670 C changes suggested by Ana to avoid out of bounds
3671 c     & .or.((i+5).gt.nres)
3672 c     & .or.((i-1).le.0)
3673 C end of changes suggested by Ana
3674      &    .or. itype(i+3).eq.ntyp1
3675      &    .or. itype(i+4).eq.ntyp1
3676 c     &    .or. itype(i+5).eq.ntyp1
3677 c     &    .or. itype(i).eq.ntyp1
3678 c     &    .or. itype(i-1).eq.ntyp1
3679      &                             ) cycle
3680         dxi=dc(1,i)
3681         dyi=dc(2,i)
3682         dzi=dc(3,i)
3683         dx_normi=dc_norm(1,i)
3684         dy_normi=dc_norm(2,i)
3685         dz_normi=dc_norm(3,i)
3686         xmedi=c(1,i)+0.5d0*dxi
3687         ymedi=c(2,i)+0.5d0*dyi
3688         zmedi=c(3,i)+0.5d0*dzi
3689 C Return atom into box, boxxsize is size of box in x dimension
3690 c  194   continue
3691 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3692 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3693 C Condition for being inside the proper box
3694 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3695 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3696 c        go to 194
3697 c        endif
3698 c  195   continue
3699 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3700 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3701 C Condition for being inside the proper box
3702 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3703 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3704 c        go to 195
3705 c        endif
3706 c  196   continue
3707 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3708 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3709 C Condition for being inside the proper box
3710 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3711 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3712 c        go to 196
3713 c        endif
3714         call to_box(xmedi,ymedi,zmedi)
3715         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3716 #ifdef FOURBODY
3717         num_conti=num_cont_hb(i)
3718 #endif
3719 c        write(iout,*) "JESTEM W PETLI"
3720         call eelecij(i,i+3,ees,evdw1,eel_loc)
3721         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3722      &   call eturn4(i,eello_turn4)
3723 #ifdef FOURBODY
3724         num_cont_hb(i)=num_conti
3725 #endif
3726       enddo   ! i
3727 C Loop over all neighbouring boxes
3728 C      do xshift=-1,1
3729 C      do yshift=-1,1
3730 C      do zshift=-1,1
3731 c
3732 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3733 c
3734 CTU KURWA
3735 c      do i=iatel_s,iatel_e
3736       do ikont=g_listpp_start,g_listpp_end
3737         i=newcontlistppi(ikont)
3738         j=newcontlistppj(ikont)
3739 C        do i=75,75
3740 c        if (i.le.1) cycle
3741         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3742 C changes suggested by Ana to avoid out of bounds
3743 c     & .or.((i+2).gt.nres)
3744 c     & .or.((i-1).le.0)
3745 C end of changes by Ana
3746 c     &  .or. itype(i+2).eq.ntyp1
3747 c     &  .or. itype(i-1).eq.ntyp1
3748      &                ) cycle
3749         dxi=dc(1,i)
3750         dyi=dc(2,i)
3751         dzi=dc(3,i)
3752         dx_normi=dc_norm(1,i)
3753         dy_normi=dc_norm(2,i)
3754         dz_normi=dc_norm(3,i)
3755         xmedi=c(1,i)+0.5d0*dxi
3756         ymedi=c(2,i)+0.5d0*dyi
3757         zmedi=c(3,i)+0.5d0*dzi
3758         call to_box(xmedi,ymedi,zmedi)
3759         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3760 C          xmedi=xmedi+xshift*boxxsize
3761 C          ymedi=ymedi+yshift*boxysize
3762 C          zmedi=zmedi+zshift*boxzsize
3763
3764 C Return tom into box, boxxsize is size of box in x dimension
3765 c  164   continue
3766 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3767 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3768 C Condition for being inside the proper box
3769 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3770 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3771 c        go to 164
3772 c        endif
3773 c  165   continue
3774 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3775 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3776 C Condition for being inside the proper box
3777 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3778 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3779 c        go to 165
3780 c        endif
3781 c  166   continue
3782 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3783 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3784 cC Condition for being inside the proper box
3785 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3786 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3787 c        go to 166
3788 c        endif
3789
3790 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3791 #ifdef FOURBODY
3792         num_conti=num_cont_hb(i)
3793 #endif
3794 C I TU KURWA
3795 c        do j=ielstart(i),ielend(i)
3796 C          do j=16,17
3797 C          write (iout,*) i,j
3798 C         if (j.le.1) cycle
3799         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3800 C changes suggested by Ana to avoid out of bounds
3801 c     & .or.((j+2).gt.nres)
3802 c     & .or.((j-1).le.0)
3803 C end of changes by Ana
3804 c     & .or.itype(j+2).eq.ntyp1
3805 c     & .or.itype(j-1).eq.ntyp1
3806      &) cycle
3807         call eelecij(i,j,ees,evdw1,eel_loc)
3808 c        enddo ! j
3809 #ifdef FOURBODY
3810         num_cont_hb(i)=num_conti
3811 #endif
3812       enddo   ! i
3813 C     enddo   ! zshift
3814 C      enddo   ! yshift
3815 C      enddo   ! xshift
3816
3817 c      write (iout,*) "Number of loop steps in EELEC:",ind
3818 cd      do i=1,nres
3819 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3820 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3821 cd      enddo
3822 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3823 ccc      eel_loc=eel_loc+eello_turn3
3824 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3825       return
3826       end
3827 C-------------------------------------------------------------------------------
3828       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3829       implicit none
3830       include 'DIMENSIONS'
3831 #ifdef MPI
3832       include "mpif.h"
3833 #endif
3834       include 'COMMON.CONTROL'
3835       include 'COMMON.IOUNITS'
3836       include 'COMMON.GEO'
3837       include 'COMMON.VAR'
3838       include 'COMMON.LOCAL'
3839       include 'COMMON.CHAIN'
3840       include 'COMMON.DERIV'
3841       include 'COMMON.INTERACT'
3842 #ifdef FOURBODY
3843       include 'COMMON.CONTACTS'
3844       include 'COMMON.CONTMAT'
3845 #endif
3846       include 'COMMON.CORRMAT'
3847       include 'COMMON.TORSION'
3848       include 'COMMON.VECTORS'
3849       include 'COMMON.FFIELD'
3850       include 'COMMON.TIME1'
3851       include 'COMMON.SPLITELE'
3852       include 'COMMON.SHIELD'
3853       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3854      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3855       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3856      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3857      &    gmuij2(4),gmuji2(4)
3858       double precision dxi,dyi,dzi
3859       double precision dx_normi,dy_normi,dz_normi,aux
3860       integer j1,j2,lll,num_conti
3861       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3862      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3863      &    num_conti,j1,j2
3864       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3865       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3866       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3867       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3868      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3869      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3870      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3871      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3872      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3873      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3874      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3875       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3876       double precision xmedi,ymedi,zmedi
3877       double precision sscale,sscagrad,scalar
3878       double precision boxshift
3879       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3880      & faclipij2
3881       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3882 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3883 #ifdef MOMENT
3884       double precision scal_el /1.0d0/
3885 #else
3886       double precision scal_el /0.5d0/
3887 #endif
3888 C 12/13/98
3889 C 13-go grudnia roku pamietnego...
3890       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3891      &                   0.0d0,1.0d0,0.0d0,
3892      &                   0.0d0,0.0d0,1.0d0/
3893 c          time00=MPI_Wtime()
3894 cd      write (iout,*) "eelecij",i,j
3895 c          ind=ind+1
3896 c          write (iout,*) "lipscale",lipscale
3897           iteli=itel(i)
3898           itelj=itel(j)
3899           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3900           aaa=app(iteli,itelj)
3901           bbb=bpp(iteli,itelj)
3902           ael6i=ael6(iteli,itelj)
3903           ael3i=ael3(iteli,itelj)
3904           dxj=dc(1,j)
3905           dyj=dc(2,j)
3906           dzj=dc(3,j)
3907           dx_normj=dc_norm(1,j)
3908           dy_normj=dc_norm(2,j)
3909           dz_normj=dc_norm(3,j)
3910 C          xj=c(1,j)+0.5D0*dxj-xmedi
3911 C          yj=c(2,j)+0.5D0*dyj-ymedi
3912 C          zj=c(3,j)+0.5D0*dzj-zmedi
3913           xj=c(1,j)+0.5D0*dxj
3914           yj=c(2,j)+0.5D0*dyj
3915           zj=c(3,j)+0.5D0*dzj
3916           call to_box(xj,yj,zj)
3917           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3918           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3919           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3920           xj=boxshift(xj-xmedi,boxxsize)
3921           yj=boxshift(yj-ymedi,boxysize)
3922           zj=boxshift(zj-zmedi,boxzsize)
3923 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3924 c  174   continue
3925           rij=xj*xj+yj*yj+zj*zj
3926
3927           sss=sscale(dsqrt(rij),r_cut_int)
3928           if (sss.eq.0.0d0) return
3929           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3930 c            if (sss.gt.0.0d0) then
3931           rrmij=1.0D0/rij
3932           rij=dsqrt(rij)
3933           rmij=1.0D0/rij
3934           r3ij=rrmij*rmij
3935           r6ij=r3ij*r3ij
3936           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3937           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3938           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3939           fac=cosa-3.0D0*cosb*cosg
3940           ev1=aaa*r6ij*r6ij
3941 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3942           if (j.eq.i+2) ev1=scal_el*ev1
3943           ev2=bbb*r6ij
3944           fac3=ael6i*r6ij
3945           fac4=ael3i*r3ij
3946           evdwij=(ev1+ev2)
3947           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3948           el2=fac4*fac
3949 C MARYSIA
3950 C          eesij=(el1+el2)
3951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3953           if (shield_mode.gt.0) then
3954 C          fac_shield(i)=0.4
3955 C          fac_shield(j)=0.6
3956           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3957           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3958           eesij=(el1+el2)
3959           ees=ees+eesij*sss*faclipij2
3960           else
3961           fac_shield(i)=1.0
3962           fac_shield(j)=1.0
3963           eesij=(el1+el2)
3964           ees=ees+eesij*sss*faclipij2
3965           endif
3966           ees=ees
3967           evdw1=evdw1+evdwij*sss*faclipij2
3968 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3969 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3970 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3971 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3972
3973           if (energy_dec) then
3974             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3975      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3976             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
3977      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
3978      &        faclipij2
3979           endif
3980
3981 C
3982 C Calculate contributions to the Cartesian gradient.
3983 C
3984 #ifdef SPLITELE
3985           facvdw=-6*rrmij*(ev1+evdwij)*sss
3986           facel=-3*rrmij*(el1+eesij)
3987           fac1=fac
3988           erij(1)=xj*rmij
3989           erij(2)=yj*rmij
3990           erij(3)=zj*rmij
3991
3992 *
3993 * Radial derivatives. First process both termini of the fragment (i,j)
3994 *
3995           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
3996           ggg(1)=aux*xj
3997           ggg(2)=aux*yj
3998           ggg(3)=aux*zj
3999           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4000      &  (shield_mode.gt.0)) then
4001 C          print *,i,j
4002           do ilist=1,ishield_list(i)
4003            iresshield=shield_list(ilist,i)
4004            do k=1,3
4005            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4006      &      *2.0
4007            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4008      &              rlocshield
4009      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4010             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4011 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4012 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4013 C             if (iresshield.gt.i) then
4014 C               do ishi=i+1,iresshield-1
4015 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4016 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4017 C
4018 C              enddo
4019 C             else
4020 C               do ishi=iresshield,i
4021 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4022 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4023 C
4024 C               enddo
4025 C              endif
4026            enddo
4027           enddo
4028           do ilist=1,ishield_list(j)
4029            iresshield=shield_list(ilist,j)
4030            do k=1,3
4031            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4032      &     *2.0*sss
4033            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4034      &              rlocshield
4035      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4036            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4037
4038 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4039 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4040 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4041 C             if (iresshield.gt.j) then
4042 C               do ishi=j+1,iresshield-1
4043 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4044 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4045 C
4046 C               enddo
4047 C            else
4048 C               do ishi=iresshield,j
4049 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4050 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4051 C               enddo
4052 C              endif
4053            enddo
4054           enddo
4055
4056           do k=1,3
4057             gshieldc(k,i)=gshieldc(k,i)+
4058      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4059             gshieldc(k,j)=gshieldc(k,j)+
4060      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4061             gshieldc(k,i-1)=gshieldc(k,i-1)+
4062      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4063             gshieldc(k,j-1)=gshieldc(k,j-1)+
4064      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4065
4066            enddo
4067            endif
4068 c          do k=1,3
4069 c            ghalf=0.5D0*ggg(k)
4070 c            gelc(k,i)=gelc(k,i)+ghalf
4071 c            gelc(k,j)=gelc(k,j)+ghalf
4072 c          enddo
4073 c 9/28/08 AL Gradient compotents will be summed only at the end
4074 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4075           do k=1,3
4076             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4077             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4078           enddo
4079           gelc_long(3,j)=gelc_long(3,j)+
4080      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
4081
4082           gelc_long(3,i)=gelc_long(3,i)+
4083      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
4084
4085
4086 *
4087 * Loop over residues i+1 thru j-1.
4088 *
4089 cgrad          do k=i+1,j-1
4090 cgrad            do l=1,3
4091 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4092 cgrad            enddo
4093 cgrad          enddo
4094           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4095           ggg(1)=facvdw*xj
4096           ggg(2)=facvdw*yj
4097           ggg(3)=facvdw*zj
4098 c          do k=1,3
4099 c            ghalf=0.5D0*ggg(k)
4100 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4101 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4102 c          enddo
4103 c 9/28/08 AL Gradient compotents will be summed only at the end
4104           do k=1,3
4105             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4106             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4107           enddo
4108 !C Lipidic part for scaling weight
4109           gvdwpp(3,j)=gvdwpp(3,j)+
4110      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4111           gvdwpp(3,i)=gvdwpp(3,i)+
4112      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4113 *
4114 * Loop over residues i+1 thru j-1.
4115 *
4116 cgrad          do k=i+1,j-1
4117 cgrad            do l=1,3
4118 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121 #else
4122 C MARYSIA
4123           facvdw=(ev1+evdwij)*faclipij2
4124           facel=(el1+eesij)
4125           fac1=fac
4126           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4127      &       +(evdwij+eesij)*sssgrad*rrmij
4128           erij(1)=xj*rmij
4129           erij(2)=yj*rmij
4130           erij(3)=zj*rmij
4131 *
4132 * Radial derivatives. First process both termini of the fragment (i,j)
4133 *
4134           ggg(1)=fac*xj
4135 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4136           ggg(2)=fac*yj
4137 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4138           ggg(3)=fac*zj
4139 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4140 c          do k=1,3
4141 c            ghalf=0.5D0*ggg(k)
4142 c            gelc(k,i)=gelc(k,i)+ghalf
4143 c            gelc(k,j)=gelc(k,j)+ghalf
4144 c          enddo
4145 c 9/28/08 AL Gradient compotents will be summed only at the end
4146           do k=1,3
4147             gelc_long(k,j)=gelc(k,j)+ggg(k)
4148             gelc_long(k,i)=gelc(k,i)-ggg(k)
4149           enddo
4150 *
4151 * Loop over residues i+1 thru j-1.
4152 *
4153 cgrad          do k=i+1,j-1
4154 cgrad            do l=1,3
4155 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4156 cgrad            enddo
4157 cgrad          enddo
4158 c 9/28/08 AL Gradient compotents will be summed only at the end
4159           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4160           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4161           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4162           do k=1,3
4163             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4164             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4165           enddo
4166           gvdwpp(3,j)=gvdwpp(3,j)+
4167      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4168           gvdwpp(3,i)=gvdwpp(3,i)+
4169      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4170 #endif
4171 *
4172 * Angular part
4173 *
4174           ecosa=2.0D0*fac3*fac1+fac4
4175           fac4=-3.0D0*fac4
4176           fac3=-6.0D0*fac3
4177           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4178           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4179           do k=1,3
4180             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4181             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4182           enddo
4183 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4184 cd   &          (dcosg(k),k=1,3)
4185           do k=1,3
4186             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4187      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4188           enddo
4189 c          do k=1,3
4190 c            ghalf=0.5D0*ggg(k)
4191 c            gelc(k,i)=gelc(k,i)+ghalf
4192 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4193 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4194 c            gelc(k,j)=gelc(k,j)+ghalf
4195 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4196 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4197 c          enddo
4198 cgrad          do k=i+1,j-1
4199 cgrad            do l=1,3
4200 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4201 cgrad            enddo
4202 cgrad          enddo
4203 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4204           do k=1,3
4205             gelc(k,i)=gelc(k,i)
4206      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4207      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4208      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4209             gelc(k,j)=gelc(k,j)
4210      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4211      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4212      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4213             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4214             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4215           enddo
4216 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4217
4218 C MARYSIA
4219 c          endif !sscale
4220           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4221      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4222      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4223 C
4224 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4225 C   energy of a peptide unit is assumed in the form of a second-order
4226 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4227 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4228 C   are computed for EVERY pair of non-contiguous peptide groups.
4229 C
4230
4231           if (j.lt.nres-1) then
4232             j1=j+1
4233             j2=j-1
4234           else
4235             j1=j-1
4236             j2=j-2
4237           endif
4238           kkk=0
4239           lll=0
4240           do k=1,2
4241             do l=1,2
4242               kkk=kkk+1
4243               muij(kkk)=mu(k,i)*mu(l,j)
4244 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4245 #ifdef NEWCORR
4246              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4247 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4248              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4249              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4250 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4251              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4252 #endif
4253             enddo
4254           enddo
4255 #ifdef DEBUG
4256           write (iout,*) 'EELEC: i',i,' j',j
4257           write (iout,*) 'j',j,' j1',j1,' j2',j2
4258           write(iout,*) 'muij',muij
4259 #endif
4260           ury=scalar(uy(1,i),erij)
4261           urz=scalar(uz(1,i),erij)
4262           vry=scalar(uy(1,j),erij)
4263           vrz=scalar(uz(1,j),erij)
4264           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4265           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4266           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4267           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4268           fac=dsqrt(-ael6i)*r3ij
4269 #ifdef DEBUG
4270           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4271           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4272      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4273      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4274      &      "uzvz",scalar(uz(1,i),uz(1,j))
4275           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4276           write (iout,*) "fac",fac
4277 #endif
4278           a22=a22*fac
4279           a23=a23*fac
4280           a32=a32*fac
4281           a33=a33*fac
4282 #ifdef DEBUG
4283           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4284 #endif
4285 #undef DEBUG
4286 cd          write (iout,'(4i5,4f10.5)')
4287 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4288 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4289 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4290 cd     &      uy(:,j),uz(:,j)
4291 cd          write (iout,'(4f10.5)')
4292 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4293 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4294 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4295 cd           write (iout,'(9f10.5/)')
4296 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4297 C Derivatives of the elements of A in virtual-bond vectors
4298           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4299           do k=1,3
4300             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4301             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4302             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4303             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4304             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4305             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4306             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4307             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4308             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4309             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4310             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4311             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4312           enddo
4313 C Compute radial contributions to the gradient
4314           facr=-3.0d0*rrmij
4315           a22der=a22*facr
4316           a23der=a23*facr
4317           a32der=a32*facr
4318           a33der=a33*facr
4319           agg(1,1)=a22der*xj
4320           agg(2,1)=a22der*yj
4321           agg(3,1)=a22der*zj
4322           agg(1,2)=a23der*xj
4323           agg(2,2)=a23der*yj
4324           agg(3,2)=a23der*zj
4325           agg(1,3)=a32der*xj
4326           agg(2,3)=a32der*yj
4327           agg(3,3)=a32der*zj
4328           agg(1,4)=a33der*xj
4329           agg(2,4)=a33der*yj
4330           agg(3,4)=a33der*zj
4331 C Add the contributions coming from er
4332           fac3=-3.0d0*fac
4333           do k=1,3
4334             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4335             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4336             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4337             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4338           enddo
4339           do k=1,3
4340 C Derivatives in DC(i)
4341 cgrad            ghalf1=0.5d0*agg(k,1)
4342 cgrad            ghalf2=0.5d0*agg(k,2)
4343 cgrad            ghalf3=0.5d0*agg(k,3)
4344 cgrad            ghalf4=0.5d0*agg(k,4)
4345             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4346      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4347             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4348      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4349             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4350      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4351             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4352      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4353 C Derivatives in DC(i+1)
4354             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4355      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4356             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4357      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4358             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4359      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4360             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4361      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4362 C Derivatives in DC(j)
4363             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4364      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4365             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4366      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4367             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4368      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4369             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4370      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4371 C Derivatives in DC(j+1) or DC(nres-1)
4372             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4373      &      -3.0d0*vryg(k,3)*ury)
4374             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4375      &      -3.0d0*vrzg(k,3)*ury)
4376             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4377      &      -3.0d0*vryg(k,3)*urz)
4378             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4379      &      -3.0d0*vrzg(k,3)*urz)
4380 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4381 cgrad              do l=1,4
4382 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4383 cgrad              enddo
4384 cgrad            endif
4385           enddo
4386           acipa(1,1)=a22
4387           acipa(1,2)=a23
4388           acipa(2,1)=a32
4389           acipa(2,2)=a33
4390           a22=-a22
4391           a23=-a23
4392           do l=1,2
4393             do k=1,3
4394               agg(k,l)=-agg(k,l)
4395               aggi(k,l)=-aggi(k,l)
4396               aggi1(k,l)=-aggi1(k,l)
4397               aggj(k,l)=-aggj(k,l)
4398               aggj1(k,l)=-aggj1(k,l)
4399             enddo
4400           enddo
4401           if (j.lt.nres-1) then
4402             a22=-a22
4403             a32=-a32
4404             do l=1,3,2
4405               do k=1,3
4406                 agg(k,l)=-agg(k,l)
4407                 aggi(k,l)=-aggi(k,l)
4408                 aggi1(k,l)=-aggi1(k,l)
4409                 aggj(k,l)=-aggj(k,l)
4410                 aggj1(k,l)=-aggj1(k,l)
4411               enddo
4412             enddo
4413           else
4414             a22=-a22
4415             a23=-a23
4416             a32=-a32
4417             a33=-a33
4418             do l=1,4
4419               do k=1,3
4420                 agg(k,l)=-agg(k,l)
4421                 aggi(k,l)=-aggi(k,l)
4422                 aggi1(k,l)=-aggi1(k,l)
4423                 aggj(k,l)=-aggj(k,l)
4424                 aggj1(k,l)=-aggj1(k,l)
4425               enddo
4426             enddo
4427           endif
4428           ENDIF ! WCORR
4429           IF (wel_loc.gt.0.0d0) THEN
4430 C Contribution to the local-electrostatic energy coming from the i-j pair
4431           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4432      &     +a33*muij(4)
4433 #ifdef DEBUG
4434           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4435      &     " a33",a33
4436           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4437      &     " wel_loc",wel_loc
4438 #endif
4439           if (shield_mode.eq.0) then
4440            fac_shield(i)=1.0
4441            fac_shield(j)=1.0
4442 C          else
4443 C           fac_shield(i)=0.4
4444 C           fac_shield(j)=0.6
4445           endif
4446           eel_loc_ij=eel_loc_ij
4447      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4448 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4449 c     &            'eelloc',i,j,eel_loc_ij
4450 C Now derivative over eel_loc
4451           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4452      &  (shield_mode.gt.0)) then
4453 C          print *,i,j
4454
4455           do ilist=1,ishield_list(i)
4456            iresshield=shield_list(ilist,i)
4457            do k=1,3
4458            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4459      &                                          /fac_shield(i)
4460 C     &      *2.0
4461            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4462      &              rlocshield
4463      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4464             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4465      &      +rlocshield
4466            enddo
4467           enddo
4468           do ilist=1,ishield_list(j)
4469            iresshield=shield_list(ilist,j)
4470            do k=1,3
4471            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4472      &                                       /fac_shield(j)
4473 C     &     *2.0
4474            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4475      &              rlocshield
4476      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4477            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4478      &             +rlocshield
4479
4480            enddo
4481           enddo
4482
4483           do k=1,3
4484             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4485      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4486             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4487      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4488             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4489      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4490             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4491      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4492            enddo
4493            endif
4494
4495
4496 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4497 c     &                     ' eel_loc_ij',eel_loc_ij
4498 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4499 C Calculate patrial derivative for theta angle
4500 #ifdef NEWCORR
4501          geel_loc_ij=(a22*gmuij1(1)
4502      &     +a23*gmuij1(2)
4503      &     +a32*gmuij1(3)
4504      &     +a33*gmuij1(4))
4505      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4506 c         write(iout,*) "derivative over thatai"
4507 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4508 c     &   a33*gmuij1(4)
4509          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4510      &      geel_loc_ij*wel_loc
4511 c         write(iout,*) "derivative over thatai-1"
4512 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4513 c     &   a33*gmuij2(4)
4514          geel_loc_ij=
4515      &     a22*gmuij2(1)
4516      &     +a23*gmuij2(2)
4517      &     +a32*gmuij2(3)
4518      &     +a33*gmuij2(4)
4519          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4520      &      geel_loc_ij*wel_loc
4521      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4522
4523 c  Derivative over j residue
4524          geel_loc_ji=a22*gmuji1(1)
4525      &     +a23*gmuji1(2)
4526      &     +a32*gmuji1(3)
4527      &     +a33*gmuji1(4)
4528 c         write(iout,*) "derivative over thataj"
4529 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4530 c     &   a33*gmuji1(4)
4531
4532         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4533      &      geel_loc_ji*wel_loc
4534      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4535
4536          geel_loc_ji=
4537      &     +a22*gmuji2(1)
4538      &     +a23*gmuji2(2)
4539      &     +a32*gmuji2(3)
4540      &     +a33*gmuji2(4)
4541 c         write(iout,*) "derivative over thataj-1"
4542 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4543 c     &   a33*gmuji2(4)
4544          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4545      &      geel_loc_ji*wel_loc
4546      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4547 #endif
4548 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4549
4550           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4551      &            'eelloc',i,j,eel_loc_ij
4552 c           if (eel_loc_ij.ne.0)
4553 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4554 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4555
4556           eel_loc=eel_loc+eel_loc_ij
4557 C Partial derivatives in virtual-bond dihedral angles gamma
4558           if (i.gt.1)
4559      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4560      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4561      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4562      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4563
4564           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4565      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4566      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4567      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4568 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4569           aux=eel_loc_ij/sss*sssgrad*rmij
4570           ggg(1)=aux*xj
4571           ggg(2)=aux*yj
4572           ggg(3)=aux*zj
4573           do l=1,3
4574             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4575      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4576      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4577             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4578             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4579 cgrad            ghalf=0.5d0*ggg(l)
4580 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4581 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4582           enddo
4583           gel_loc_long(3,j)=gel_loc_long(3,j)+
4584      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4585
4586           gel_loc_long(3,i)=gel_loc_long(3,i)+
4587      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4588
4589 cgrad          do k=i+1,j2
4590 cgrad            do l=1,3
4591 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4592 cgrad            enddo
4593 cgrad          enddo
4594 C Remaining derivatives of eello
4595           do l=1,3
4596             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4597      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4598      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4599
4600             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4601      &        aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4602      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4603
4604             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4605      &        aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4606      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4607
4608             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4609      &        aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4610      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4611
4612           enddo
4613           ENDIF
4614 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4615 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4616 #ifdef FOURBODY
4617           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4618      &       .and. num_conti.le.maxconts) then
4619 c            write (iout,*) i,j," entered corr"
4620 C
4621 C Calculate the contact function. The ith column of the array JCONT will
4622 C contain the numbers of atoms that make contacts with the atom I (of numbers
4623 C greater than I). The arrays FACONT and GACONT will contain the values of
4624 C the contact function and its derivative.
4625 c           r0ij=1.02D0*rpp(iteli,itelj)
4626 c           r0ij=1.11D0*rpp(iteli,itelj)
4627             r0ij=2.20D0*rpp(iteli,itelj)
4628 c           r0ij=1.55D0*rpp(iteli,itelj)
4629             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4630             if (fcont.gt.0.0D0) then
4631               num_conti=num_conti+1
4632               if (num_conti.gt.maxconts) then
4633                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4634      &                         ' will skip next contacts for this conf.'
4635               else
4636                 jcont_hb(num_conti,i)=j
4637 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4638 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4639                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4640      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4641 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4642 C  terms.
4643                 d_cont(num_conti,i)=rij
4644 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4645 C     --- Electrostatic-interaction matrix ---
4646                 a_chuj(1,1,num_conti,i)=a22
4647                 a_chuj(1,2,num_conti,i)=a23
4648                 a_chuj(2,1,num_conti,i)=a32
4649                 a_chuj(2,2,num_conti,i)=a33
4650 C     --- Gradient of rij
4651                 do kkk=1,3
4652                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4653                 enddo
4654                 kkll=0
4655                 do k=1,2
4656                   do l=1,2
4657                     kkll=kkll+1
4658                     do m=1,3
4659                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4660                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4661                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4662                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4663                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4664                     enddo
4665                   enddo
4666                 enddo
4667                 ENDIF
4668                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4669 C Calculate contact energies
4670                 cosa4=4.0D0*cosa
4671                 wij=cosa-3.0D0*cosb*cosg
4672                 cosbg1=cosb+cosg
4673                 cosbg2=cosb-cosg
4674 c               fac3=dsqrt(-ael6i)/r0ij**3
4675                 fac3=dsqrt(-ael6i)*r3ij
4676 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4677                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4678                 if (ees0tmp.gt.0) then
4679                   ees0pij=dsqrt(ees0tmp)
4680                 else
4681                   ees0pij=0
4682                 endif
4683 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4684                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4685                 if (ees0tmp.gt.0) then
4686                   ees0mij=dsqrt(ees0tmp)
4687                 else
4688                   ees0mij=0
4689                 endif
4690 c               ees0mij=0.0D0
4691                 if (shield_mode.eq.0) then
4692                 fac_shield(i)=1.0d0
4693                 fac_shield(j)=1.0d0
4694                 else
4695                 ees0plist(num_conti,i)=j
4696 C                fac_shield(i)=0.4d0
4697 C                fac_shield(j)=0.6d0
4698                 endif
4699                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4700      &          *fac_shield(i)*fac_shield(j)*sss
4701                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4702      &          *fac_shield(i)*fac_shield(j)*sss
4703 C Diagnostics. Comment out or remove after debugging!
4704 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4705 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4706 c               ees0m(num_conti,i)=0.0D0
4707 C End diagnostics.
4708 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4709 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4710 C Angular derivatives of the contact function
4711                 ees0pij1=fac3/ees0pij
4712                 ees0mij1=fac3/ees0mij
4713                 fac3p=-3.0D0*fac3*rrmij
4714                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4715                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4716 c               ees0mij1=0.0D0
4717                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4718                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4719                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4720                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4721                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4722                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4723                 ecosap=ecosa1+ecosa2
4724                 ecosbp=ecosb1+ecosb2
4725                 ecosgp=ecosg1+ecosg2
4726                 ecosam=ecosa1-ecosa2
4727                 ecosbm=ecosb1-ecosb2
4728                 ecosgm=ecosg1-ecosg2
4729 C Diagnostics
4730 c               ecosap=ecosa1
4731 c               ecosbp=ecosb1
4732 c               ecosgp=ecosg1
4733 c               ecosam=0.0D0
4734 c               ecosbm=0.0D0
4735 c               ecosgm=0.0D0
4736 C End diagnostics
4737                 facont_hb(num_conti,i)=fcont
4738                 fprimcont=fprimcont/rij
4739 cd              facont_hb(num_conti,i)=1.0D0
4740 C Following line is for diagnostics.
4741 cd              fprimcont=0.0D0
4742                 do k=1,3
4743                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4744                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4745                 enddo
4746                 do k=1,3
4747                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4748                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4749                 enddo
4750                 gggp(1)=gggp(1)+ees0pijp*xj
4751      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4752                 gggp(2)=gggp(2)+ees0pijp*yj
4753      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4754                 gggp(3)=gggp(3)+ees0pijp*zj
4755      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4756                 gggm(1)=gggm(1)+ees0mijp*xj
4757      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4758                 gggm(2)=gggm(2)+ees0mijp*yj
4759      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4760                 gggm(3)=gggm(3)+ees0mijp*zj
4761      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4762 C Derivatives due to the contact function
4763                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4764                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4765                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4766                 do k=1,3
4767 c
4768 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4769 c          following the change of gradient-summation algorithm.
4770 c
4771 cgrad                  ghalfp=0.5D0*gggp(k)
4772 cgrad                  ghalfm=0.5D0*gggm(k)
4773                   gacontp_hb1(k,num_conti,i)=!ghalfp
4774      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4775      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4776      &          *fac_shield(i)*fac_shield(j)*sss
4777
4778                   gacontp_hb2(k,num_conti,i)=!ghalfp
4779      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4780      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4781      &          *fac_shield(i)*fac_shield(j)*sss
4782
4783                   gacontp_hb3(k,num_conti,i)=gggp(k)
4784      &          *fac_shield(i)*fac_shield(j)*sss
4785
4786                   gacontm_hb1(k,num_conti,i)=!ghalfm
4787      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4788      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4789      &          *fac_shield(i)*fac_shield(j)*sss
4790
4791                   gacontm_hb2(k,num_conti,i)=!ghalfm
4792      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4793      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4794      &          *fac_shield(i)*fac_shield(j)*sss
4795
4796                   gacontm_hb3(k,num_conti,i)=gggm(k)
4797      &          *fac_shield(i)*fac_shield(j)*sss
4798
4799                 enddo
4800 C Diagnostics. Comment out or remove after debugging!
4801 cdiag           do k=1,3
4802 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4803 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4804 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4805 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4806 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4807 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4808 cdiag           enddo
4809               ENDIF ! wcorr
4810               endif  ! num_conti.le.maxconts
4811             endif  ! fcont.gt.0
4812           endif    ! j.gt.i+1
4813 #endif
4814           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4815             do k=1,4
4816               do l=1,3
4817                 ghalf=0.5d0*agg(l,k)
4818                 aggi(l,k)=aggi(l,k)+ghalf
4819                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4820                 aggj(l,k)=aggj(l,k)+ghalf
4821               enddo
4822             enddo
4823             if (j.eq.nres-1 .and. i.lt.j-2) then
4824               do k=1,4
4825                 do l=1,3
4826                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4827                 enddo
4828               enddo
4829             endif
4830           endif
4831 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4832       return
4833       end
4834 C-----------------------------------------------------------------------------
4835       subroutine eturn3(i,eello_turn3)
4836 C Third- and fourth-order contributions from turns
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.IOUNITS'
4840       include 'COMMON.GEO'
4841       include 'COMMON.VAR'
4842       include 'COMMON.LOCAL'
4843       include 'COMMON.CHAIN'
4844       include 'COMMON.DERIV'
4845       include 'COMMON.INTERACT'
4846       include 'COMMON.CORRMAT'
4847       include 'COMMON.TORSION'
4848       include 'COMMON.VECTORS'
4849       include 'COMMON.FFIELD'
4850       include 'COMMON.CONTROL'
4851       include 'COMMON.SHIELD'
4852       dimension ggg(3)
4853       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4854      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4855      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4856      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4857      &  auxgmat2(2,2),auxgmatt2(2,2)
4858       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4859      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4860       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4861      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4862      &    num_conti,j1,j2
4863       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4864       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4865       j=i+2
4866 c      write (iout,*) "eturn3",i,j,j1,j2
4867       a_temp(1,1)=a22
4868       a_temp(1,2)=a23
4869       a_temp(2,1)=a32
4870       a_temp(2,2)=a33
4871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4872 C
4873 C               Third-order contributions
4874 C
4875 C                 (i+2)o----(i+3)
4876 C                      | |
4877 C                      | |
4878 C                 (i+1)o----i
4879 C
4880 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4881 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4882         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4883 c auxalary matices for theta gradient
4884 c auxalary matrix for i+1 and constant i+2
4885         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4886 c auxalary matrix for i+2 and constant i+1
4887         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4888         call transpose2(auxmat(1,1),auxmat1(1,1))
4889         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4890         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4891         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4892         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4893         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4894         if (shield_mode.eq.0) then
4895         fac_shield(i)=1.0
4896         fac_shield(j)=1.0
4897 C        else
4898 C        fac_shield(i)=0.4
4899 C        fac_shield(j)=0.6
4900         endif
4901         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4902      &  *fac_shield(i)*fac_shield(j)*faclipij
4903         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4904      &  *fac_shield(i)*fac_shield(j)
4905         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4906      &    eello_t3
4907 C#ifdef NEWCORR
4908 C Derivatives in theta
4909         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4910      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4911      &   *fac_shield(i)*fac_shield(j)*faclipij
4912         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4913      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4914      &   *fac_shield(i)*fac_shield(j)*faclipij
4915 C#endif
4916
4917 C Derivatives in shield mode
4918           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4919      &  (shield_mode.gt.0)) then
4920 C          print *,i,j
4921
4922           do ilist=1,ishield_list(i)
4923            iresshield=shield_list(ilist,i)
4924            do k=1,3
4925            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4926 C     &      *2.0
4927            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4928      &              rlocshield
4929      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4930             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4931      &      +rlocshield
4932            enddo
4933           enddo
4934           do ilist=1,ishield_list(j)
4935            iresshield=shield_list(ilist,j)
4936            do k=1,3
4937            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4938 C     &     *2.0
4939            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4940      &              rlocshield
4941      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4942            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4943      &             +rlocshield
4944
4945            enddo
4946           enddo
4947
4948           do k=1,3
4949             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4950      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4951             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4952      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4953             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4954      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4955             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4956      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4957            enddo
4958            endif
4959
4960 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4961 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4962 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4963 cd     &    ' eello_turn3_num',4*eello_turn3_num
4964 C Derivatives in gamma(i)
4965         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4966         call transpose2(auxmat2(1,1),auxmat3(1,1))
4967         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4968         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4969      &   *fac_shield(i)*fac_shield(j)*faclipij
4970 C Derivatives in gamma(i+1)
4971         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4972         call transpose2(auxmat2(1,1),auxmat3(1,1))
4973         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4974         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4975      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4976      &   *fac_shield(i)*fac_shield(j)*faclipij
4977 C Cartesian derivatives
4978         do l=1,3
4979 c            ghalf1=0.5d0*agg(l,1)
4980 c            ghalf2=0.5d0*agg(l,2)
4981 c            ghalf3=0.5d0*agg(l,3)
4982 c            ghalf4=0.5d0*agg(l,4)
4983           a_temp(1,1)=aggi(l,1)!+ghalf1
4984           a_temp(1,2)=aggi(l,2)!+ghalf2
4985           a_temp(2,1)=aggi(l,3)!+ghalf3
4986           a_temp(2,2)=aggi(l,4)!+ghalf4
4987           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4988           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4989      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4990      &      *fac_shield(i)*fac_shield(j)*faclipij
4991
4992           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4993           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4994           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4995           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4996           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4997           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4998      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4999      &      *fac_shield(i)*fac_shield(j)*faclipij
5000           a_temp(1,1)=aggj(l,1)!+ghalf1
5001           a_temp(1,2)=aggj(l,2)!+ghalf2
5002           a_temp(2,1)=aggj(l,3)!+ghalf3
5003           a_temp(2,2)=aggj(l,4)!+ghalf4
5004           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5005           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5006      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5007      &      *fac_shield(i)*fac_shield(j)*faclipij
5008           a_temp(1,1)=aggj1(l,1)
5009           a_temp(1,2)=aggj1(l,2)
5010           a_temp(2,1)=aggj1(l,3)
5011           a_temp(2,2)=aggj1(l,4)
5012           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5013           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5014      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5015      &      *fac_shield(i)*fac_shield(j)*faclipij
5016         enddo
5017         gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5018      &    ssgradlipi*eello_t3/4.0d0*lipscale
5019         gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5020      &    ssgradlipj*eello_t3/4.0d0*lipscale
5021         gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5022      &    ssgradlipi*eello_t3/4.0d0*lipscale
5023         gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5024      &    ssgradlipj*eello_t3/4.0d0*lipscale
5025
5026       return
5027       end
5028 C-------------------------------------------------------------------------------
5029       subroutine eturn4(i,eello_turn4)
5030 C Third- and fourth-order contributions from turns
5031       implicit real*8 (a-h,o-z)
5032       include 'DIMENSIONS'
5033       include 'COMMON.IOUNITS'
5034       include 'COMMON.GEO'
5035       include 'COMMON.VAR'
5036       include 'COMMON.LOCAL'
5037       include 'COMMON.CHAIN'
5038       include 'COMMON.DERIV'
5039       include 'COMMON.INTERACT'
5040       include 'COMMON.CORRMAT'
5041       include 'COMMON.TORSION'
5042       include 'COMMON.VECTORS'
5043       include 'COMMON.FFIELD'
5044       include 'COMMON.CONTROL'
5045       include 'COMMON.SHIELD'
5046       dimension ggg(3)
5047       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5048      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5049      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5050      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5051      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5052      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5053      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5054       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5055      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5056       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5057      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5058      &    num_conti,j1,j2
5059       j=i+3
5060 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5061 C
5062 C               Fourth-order contributions
5063 C
5064 C                 (i+3)o----(i+4)
5065 C                     /  |
5066 C               (i+2)o   |
5067 C                     \  |
5068 C                 (i+1)o----i
5069 C
5070 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5071 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5072 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5073 c        write(iout,*)"WCHODZE W PROGRAM"
5074         a_temp(1,1)=a22
5075         a_temp(1,2)=a23
5076         a_temp(2,1)=a32
5077         a_temp(2,2)=a33
5078         iti1=itype2loc(itype(i+1))
5079         iti2=itype2loc(itype(i+2))
5080         iti3=itype2loc(itype(i+3))
5081 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5082         call transpose2(EUg(1,1,i+1),e1t(1,1))
5083         call transpose2(Eug(1,1,i+2),e2t(1,1))
5084         call transpose2(Eug(1,1,i+3),e3t(1,1))
5085 C Ematrix derivative in theta
5086         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5087         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5088         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5089         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5090 c       eta1 in derivative theta
5091         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5092         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5093 c       auxgvec is derivative of Ub2 so i+3 theta
5094         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5095 c       auxalary matrix of E i+1
5096         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5097 c        s1=0.0
5098 c        gs1=0.0
5099         s1=scalar2(b1(1,i+2),auxvec(1))
5100 c derivative of theta i+2 with constant i+3
5101         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5102 c derivative of theta i+2 with constant i+2
5103         gs32=scalar2(b1(1,i+2),auxgvec(1))
5104 c derivative of E matix in theta of i+1
5105         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5106
5107         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5108 c       ea31 in derivative theta
5109         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5110         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5111 c auxilary matrix auxgvec of Ub2 with constant E matirx
5112         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5113 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5114         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5115
5116 c        s2=0.0
5117 c        gs2=0.0
5118         s2=scalar2(b1(1,i+1),auxvec(1))
5119 c derivative of theta i+1 with constant i+3
5120         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5121 c derivative of theta i+2 with constant i+1
5122         gs21=scalar2(b1(1,i+1),auxgvec(1))
5123 c derivative of theta i+3 with constant i+1
5124         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5125 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5126 c     &  gtb1(1,i+1)
5127         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5128 c two derivatives over diffetent matrices
5129 c gtae3e2 is derivative over i+3
5130         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5131 c ae3gte2 is derivative over i+2
5132         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5133         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5134 c three possible derivative over theta E matices
5135 c i+1
5136         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5137 c i+2
5138         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5139 c i+3
5140         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5141         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5142
5143         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5144         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5145         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5146         if (shield_mode.eq.0) then
5147         fac_shield(i)=1.0
5148         fac_shield(j)=1.0
5149 C        else
5150 C        fac_shield(i)=0.6
5151 C        fac_shield(j)=0.4
5152         endif
5153         eello_turn4=eello_turn4-(s1+s2+s3)
5154      &  *fac_shield(i)*fac_shield(j)*faclipij
5155         eello_t4=-(s1+s2+s3)
5156      &  *fac_shield(i)*fac_shield(j)
5157 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5158         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5159      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5160 C Now derivative over shield:
5161           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5162      &  (shield_mode.gt.0)) then
5163 C          print *,i,j
5164
5165           do ilist=1,ishield_list(i)
5166            iresshield=shield_list(ilist,i)
5167            do k=1,3
5168            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5169 C     &      *2.0
5170            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5171      &              rlocshield
5172      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5173             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5174      &      +rlocshield
5175            enddo
5176           enddo
5177           do ilist=1,ishield_list(j)
5178            iresshield=shield_list(ilist,j)
5179            do k=1,3
5180            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5181 C     &     *2.0
5182            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5183      &              rlocshield
5184      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5185            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5186      &             +rlocshield
5187
5188            enddo
5189           enddo
5190
5191           do k=1,3
5192             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5193      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5194             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5195      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5196             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5197      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5198             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5199      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5200            enddo
5201            endif
5202 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5203 cd     &    ' eello_turn4_num',8*eello_turn4_num
5204 #ifdef NEWCORR
5205         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5206      &                  -(gs13+gsE13+gsEE1)*wturn4
5207      &  *fac_shield(i)*fac_shield(j)
5208         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5209      &                    -(gs23+gs21+gsEE2)*wturn4
5210      &  *fac_shield(i)*fac_shield(j)
5211
5212         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5213      &                    -(gs32+gsE31+gsEE3)*wturn4
5214      &  *fac_shield(i)*fac_shield(j)
5215
5216 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5217 c     &   gs2
5218 #endif
5219         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5220      &      'eturn4',i,j,-(s1+s2+s3)
5221 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5222 c     &    ' eello_turn4_num',8*eello_turn4_num
5223 C Derivatives in gamma(i)
5224         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5225         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5226         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5227         s1=scalar2(b1(1,i+2),auxvec(1))
5228         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5229         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5230         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5231      &  *fac_shield(i)*fac_shield(j)*faclipij
5232 C Derivatives in gamma(i+1)
5233         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5234         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5235         s2=scalar2(b1(1,i+1),auxvec(1))
5236         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5237         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5238         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5239         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5240      &  *fac_shield(i)*fac_shield(j)*faclipij
5241 C Derivatives in gamma(i+2)
5242         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5243         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5244         s1=scalar2(b1(1,i+2),auxvec(1))
5245         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5246         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5247         s2=scalar2(b1(1,i+1),auxvec(1))
5248         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5249         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5250         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5251         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5252      &  *fac_shield(i)*fac_shield(j)*faclipij
5253 C Cartesian derivatives
5254 C Derivatives of this turn contributions in DC(i+2)
5255         if (j.lt.nres-1) then
5256           do l=1,3
5257             a_temp(1,1)=agg(l,1)
5258             a_temp(1,2)=agg(l,2)
5259             a_temp(2,1)=agg(l,3)
5260             a_temp(2,2)=agg(l,4)
5261             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5262             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5263             s1=scalar2(b1(1,i+2),auxvec(1))
5264             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5265             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5266             s2=scalar2(b1(1,i+1),auxvec(1))
5267             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5268             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5269             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5270             ggg(l)=-(s1+s2+s3)
5271             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5272      &       *fac_shield(i)*fac_shield(j)*faclipij
5273           enddo
5274         endif
5275 C Remaining derivatives of this turn contribution
5276         do l=1,3
5277           a_temp(1,1)=aggi(l,1)
5278           a_temp(1,2)=aggi(l,2)
5279           a_temp(2,1)=aggi(l,3)
5280           a_temp(2,2)=aggi(l,4)
5281           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5282           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5283           s1=scalar2(b1(1,i+2),auxvec(1))
5284           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5285           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5286           s2=scalar2(b1(1,i+1),auxvec(1))
5287           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5288           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5289           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5290           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5291      &     *fac_shield(i)*fac_shield(j)*faclipij
5292           a_temp(1,1)=aggi1(l,1)
5293           a_temp(1,2)=aggi1(l,2)
5294           a_temp(2,1)=aggi1(l,3)
5295           a_temp(2,2)=aggi1(l,4)
5296           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5297           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5298           s1=scalar2(b1(1,i+2),auxvec(1))
5299           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5300           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5301           s2=scalar2(b1(1,i+1),auxvec(1))
5302           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5303           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5304           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5305           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5306      &      *fac_shield(i)*fac_shield(j)*faclipij
5307           a_temp(1,1)=aggj(l,1)
5308           a_temp(1,2)=aggj(l,2)
5309           a_temp(2,1)=aggj(l,3)
5310           a_temp(2,2)=aggj(l,4)
5311           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5312           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5313           s1=scalar2(b1(1,i+2),auxvec(1))
5314           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5315           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5316           s2=scalar2(b1(1,i+1),auxvec(1))
5317           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5318           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5319           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5320           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5321      &      *fac_shield(i)*fac_shield(j)*faclipij
5322           a_temp(1,1)=aggj1(l,1)
5323           a_temp(1,2)=aggj1(l,2)
5324           a_temp(2,1)=aggj1(l,3)
5325           a_temp(2,2)=aggj1(l,4)
5326           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5327           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5328           s1=scalar2(b1(1,i+2),auxvec(1))
5329           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5330           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5331           s2=scalar2(b1(1,i+1),auxvec(1))
5332           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5333           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5334           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5335 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5336           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5337      &      *fac_shield(i)*fac_shield(j)*faclipij
5338         enddo
5339         gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5340      &    ssgradlipi*eello_t4/4.0d0*lipscale
5341         gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5342      &    ssgradlipj*eello_t4/4.0d0*lipscale
5343         gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5344      &    ssgradlipi*eello_t4/4.0d0*lipscale
5345         gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5346      &    ssgradlipj*eello_t4/4.0d0*lipscale
5347       return
5348       end
5349 C-----------------------------------------------------------------------------
5350       subroutine vecpr(u,v,w)
5351       implicit real*8(a-h,o-z)
5352       dimension u(3),v(3),w(3)
5353       w(1)=u(2)*v(3)-u(3)*v(2)
5354       w(2)=-u(1)*v(3)+u(3)*v(1)
5355       w(3)=u(1)*v(2)-u(2)*v(1)
5356       return
5357       end
5358 C-----------------------------------------------------------------------------
5359       subroutine unormderiv(u,ugrad,unorm,ungrad)
5360 C This subroutine computes the derivatives of a normalized vector u, given
5361 C the derivatives computed without normalization conditions, ugrad. Returns
5362 C ungrad.
5363       implicit none
5364       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5365       double precision vec(3)
5366       double precision scalar
5367       integer i,j
5368 c      write (2,*) 'ugrad',ugrad
5369 c      write (2,*) 'u',u
5370       do i=1,3
5371         vec(i)=scalar(ugrad(1,i),u(1))
5372       enddo
5373 c      write (2,*) 'vec',vec
5374       do i=1,3
5375         do j=1,3
5376           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5377         enddo
5378       enddo
5379 c      write (2,*) 'ungrad',ungrad
5380       return
5381       end
5382 C-----------------------------------------------------------------------------
5383       subroutine escp_soft_sphere(evdw2,evdw2_14)
5384 C
5385 C This subroutine calculates the excluded-volume interaction energy between
5386 C peptide-group centers and side chains and its gradient in virtual-bond and
5387 C side-chain vectors.
5388 C
5389       implicit real*8 (a-h,o-z)
5390       include 'DIMENSIONS'
5391       include 'COMMON.GEO'
5392       include 'COMMON.VAR'
5393       include 'COMMON.LOCAL'
5394       include 'COMMON.CHAIN'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.FFIELD'
5398       include 'COMMON.IOUNITS'
5399       include 'COMMON.CONTROL'
5400       dimension ggg(3)
5401       double precision boxshift
5402       evdw2=0.0D0
5403       evdw2_14=0.0d0
5404       r0_scp=4.5d0
5405 cd    print '(a)','Enter ESCP'
5406 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5407 C      do xshift=-1,1
5408 C      do yshift=-1,1
5409 C      do zshift=-1,1
5410 c      do i=iatscp_s,iatscp_e
5411       do ikont=g_listscp_start,g_listscp_end
5412         i=newcontlistscpi(ikont)
5413         j=newcontlistscpj(ikont)
5414         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5415         iteli=itel(i)
5416         xi=0.5D0*(c(1,i)+c(1,i+1))
5417         yi=0.5D0*(c(2,i)+c(2,i+1))
5418         zi=0.5D0*(c(3,i)+c(3,i+1))
5419 C Return atom into box, boxxsize is size of box in x dimension
5420 c  134   continue
5421 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5422 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5423 C Condition for being inside the proper box
5424 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5425 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5426 c        go to 134
5427 c        endif
5428 c  135   continue
5429 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5430 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5431 C Condition for being inside the proper box
5432 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5433 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5434 c        go to 135
5435 c c       endif
5436 c  136   continue
5437 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5438 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5439 cC Condition for being inside the proper box
5440 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5441 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5442 c        go to 136
5443 c        endif
5444           call to_box(xi,yi,zi)
5445 C          xi=xi+xshift*boxxsize
5446 C          yi=yi+yshift*boxysize
5447 C          zi=zi+zshift*boxzsize
5448 c        do iint=1,nscp_gr(i)
5449
5450 c        do j=iscpstart(i,iint),iscpend(i,iint)
5451           if (itype(j).eq.ntyp1) cycle
5452           itypj=iabs(itype(j))
5453 C Uncomment following three lines for SC-p interactions
5454 c         xj=c(1,nres+j)-xi
5455 c         yj=c(2,nres+j)-yi
5456 c         zj=c(3,nres+j)-zi
5457 C Uncomment following three lines for Ca-p interactions
5458           xj=c(1,j)
5459           yj=c(2,j)
5460           zj=c(3,j)
5461           call to_box(xj,yj,zj)
5462           xj=boxshift(xj-xi,boxxsize)
5463           yj=boxshift(yj-yi,boxysize)
5464           zj=boxshift(zj-zi,boxzsize)
5465 C          xj=xj-xi
5466 C          yj=yj-yi
5467 C          zj=zj-zi
5468           rij=xj*xj+yj*yj+zj*zj
5469
5470           r0ij=r0_scp
5471           r0ijsq=r0ij*r0ij
5472           if (rij.lt.r0ijsq) then
5473             evdwij=0.25d0*(rij-r0ijsq)**2
5474             fac=rij-r0ijsq
5475           else
5476             evdwij=0.0d0
5477             fac=0.0d0
5478           endif
5479           evdw2=evdw2+evdwij
5480 C
5481 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5482 C
5483           ggg(1)=xj*fac
5484           ggg(2)=yj*fac
5485           ggg(3)=zj*fac
5486           do k=1,3
5487             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5488             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5489           enddo
5490 c        enddo
5491
5492 c        enddo ! iint
5493       enddo ! i
5494 C      enddo !zshift
5495 C      enddo !yshift
5496 C      enddo !xshift
5497       return
5498       end
5499 C-----------------------------------------------------------------------------
5500       subroutine escp(evdw2,evdw2_14)
5501 C
5502 C This subroutine calculates the excluded-volume interaction energy between
5503 C peptide-group centers and side chains and its gradient in virtual-bond and
5504 C side-chain vectors.
5505 C
5506       implicit none
5507       include 'DIMENSIONS'
5508       include 'COMMON.GEO'
5509       include 'COMMON.VAR'
5510       include 'COMMON.LOCAL'
5511       include 'COMMON.CHAIN'
5512       include 'COMMON.DERIV'
5513       include 'COMMON.INTERACT'
5514       include 'COMMON.FFIELD'
5515       include 'COMMON.IOUNITS'
5516       include 'COMMON.CONTROL'
5517       include 'COMMON.SPLITELE'
5518       double precision ggg(3)
5519       integer i,iint,j,k,iteli,itypj,subchap,ikont
5520       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5521      & fac,e1,e2,rij
5522       double precision evdw2,evdw2_14,evdwij
5523       double precision sscale,sscagrad
5524       double precision boxshift
5525       evdw2=0.0D0
5526       evdw2_14=0.0d0
5527 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5528 cd    print '(a)','Enter ESCP'
5529 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5530 C      do xshift=-1,1
5531 C      do yshift=-1,1
5532 C      do zshift=-1,1
5533       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5534 c      do i=iatscp_s,iatscp_e
5535       do ikont=g_listscp_start,g_listscp_end
5536         i=newcontlistscpi(ikont)
5537         j=newcontlistscpj(ikont)
5538         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5539         iteli=itel(i)
5540         xi=0.5D0*(c(1,i)+c(1,i+1))
5541         yi=0.5D0*(c(2,i)+c(2,i+1))
5542         zi=0.5D0*(c(3,i)+c(3,i+1))
5543         call to_box(xi,yi,zi)
5544 c        do iint=1,nscp_gr(i)
5545
5546 c        do j=iscpstart(i,iint),iscpend(i,iint)
5547           itypj=iabs(itype(j))
5548           if (itypj.eq.ntyp1) cycle
5549 C Uncomment following three lines for SC-p interactions
5550 c         xj=c(1,nres+j)-xi
5551 c         yj=c(2,nres+j)-yi
5552 c         zj=c(3,nres+j)-zi
5553 C Uncomment following three lines for Ca-p interactions
5554           xj=c(1,j)
5555           yj=c(2,j)
5556           zj=c(3,j)
5557           call to_box(xj,yj,zj)
5558           xj=boxshift(xj-xi,boxxsize)
5559           yj=boxshift(yj-yi,boxysize)
5560           zj=boxshift(zj-zi,boxzsize)
5561 c          print *,xj,yj,zj,'polozenie j'
5562           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5563 c          print *,rrij
5564           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5565 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5566 c          if (sss.eq.0) print *,'czasem jest OK'
5567           if (sss.le.0.0d0) cycle
5568           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5569           fac=rrij**expon2
5570           e1=fac*fac*aad(itypj,iteli)
5571           e2=fac*bad(itypj,iteli)
5572           if (iabs(j-i) .le. 2) then
5573             e1=scal14*e1
5574             e2=scal14*e2
5575             evdw2_14=evdw2_14+(e1+e2)*sss
5576           endif
5577           evdwij=e1+e2
5578           evdw2=evdw2+evdwij*sss
5579           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5580      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5581      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5582      &       bad(itypj,iteli)
5583 C
5584 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5585 C
5586           fac=-(evdwij+e1)*rrij*sss
5587           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5588           ggg(1)=xj*fac
5589           ggg(2)=yj*fac
5590           ggg(3)=zj*fac
5591 cgrad          if (j.lt.i) then
5592 cd          write (iout,*) 'j<i'
5593 C Uncomment following three lines for SC-p interactions
5594 c           do k=1,3
5595 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5596 c           enddo
5597 cgrad          else
5598 cd          write (iout,*) 'j>i'
5599 cgrad            do k=1,3
5600 cgrad              ggg(k)=-ggg(k)
5601 C Uncomment following line for SC-p interactions
5602 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5603 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5604 cgrad            enddo
5605 cgrad          endif
5606 cgrad          do k=1,3
5607 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5608 cgrad          enddo
5609 cgrad          kstart=min0(i+1,j)
5610 cgrad          kend=max0(i-1,j-1)
5611 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5612 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5613 cgrad          do k=kstart,kend
5614 cgrad            do l=1,3
5615 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5616 cgrad            enddo
5617 cgrad          enddo
5618           do k=1,3
5619             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5620             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5621           enddo
5622 c        endif !endif for sscale cutoff
5623 c        enddo ! j
5624
5625 c        enddo ! iint
5626       enddo ! i
5627 c      enddo !zshift
5628 c      enddo !yshift
5629 c      enddo !xshift
5630       do i=1,nct
5631         do j=1,3
5632           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5633           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5634           gradx_scp(j,i)=expon*gradx_scp(j,i)
5635         enddo
5636       enddo
5637 C******************************************************************************
5638 C
5639 C                              N O T E !!!
5640 C
5641 C To save time the factor EXPON has been extracted from ALL components
5642 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5643 C use!
5644 C
5645 C******************************************************************************
5646       return
5647       end
5648 C--------------------------------------------------------------------------
5649       subroutine edis(ehpb)
5650 C
5651 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5652 C
5653       implicit real*8 (a-h,o-z)
5654       include 'DIMENSIONS'
5655       include 'COMMON.SBRIDGE'
5656       include 'COMMON.CHAIN'
5657       include 'COMMON.DERIV'
5658       include 'COMMON.VAR'
5659       include 'COMMON.INTERACT'
5660       include 'COMMON.IOUNITS'
5661       include 'COMMON.CONTROL'
5662       dimension ggg(3),ggg_peak(3,1000)
5663       ehpb=0.0D0
5664       do i=1,3
5665        ggg(i)=0.0d0
5666       enddo
5667 c 8/21/18 AL: added explicit restraints on reference coords
5668 c      write (iout,*) "restr_on_coord",restr_on_coord
5669       if (restr_on_coord) then
5670
5671       do i=nnt,nct
5672         ecoor=0.0d0
5673         if (itype(i).eq.ntyp1) cycle
5674         do j=1,3
5675           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5676           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5677         enddo
5678         if (itype(i).ne.10) then
5679           do j=1,3
5680             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5681             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5682           enddo
5683         endif
5684         if (energy_dec) write (iout,*)
5685      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5686         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5687       enddo
5688
5689       endif
5690 C      write (iout,*) ,"link_end",link_end,constr_dist
5691 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5692 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5693 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5694 c     &  " link_end_peak",link_end_peak
5695       if (link_end.eq.0.and.link_end_peak.eq.0) return
5696       do i=link_start_peak,link_end_peak
5697         ehpb_peak=0.0d0
5698 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5699 c     &   ipeak(1,i),ipeak(2,i)
5700         do ip=ipeak(1,i),ipeak(2,i)
5701           ii=ihpb_peak(ip)
5702           jj=jhpb_peak(ip)
5703           dd=dist(ii,jj)
5704           iip=ip-ipeak(1,i)+1
5705 C iii and jjj point to the residues for which the distance is assigned.
5706 c          if (ii.gt.nres) then
5707 c            iii=ii-nres
5708 c            jjj=jj-nres
5709 c          else
5710 c            iii=ii
5711 c            jjj=jj
5712 c          endif
5713           if (ii.gt.nres) then
5714             iii=ii-nres
5715           else
5716             iii=ii
5717           endif
5718           if (jj.gt.nres) then
5719             jjj=jj-nres
5720           else
5721             jjj=jj
5722           endif
5723           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5724           aux=dexp(-scal_peak*aux)
5725           ehpb_peak=ehpb_peak+aux
5726           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5727      &      forcon_peak(ip))*aux/dd
5728           do j=1,3
5729             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5730           enddo
5731           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5732      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5733      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5734         enddo
5735 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5736         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5737         do ip=ipeak(1,i),ipeak(2,i)
5738           iip=ip-ipeak(1,i)+1
5739           do j=1,3
5740             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5741           enddo
5742           ii=ihpb_peak(ip)
5743           jj=jhpb_peak(ip)
5744 C iii and jjj point to the residues for which the distance is assigned.
5745 c          if (ii.gt.nres) then
5746 c            iii=ii-nres
5747 c            jjj=jj-nres
5748 c          else
5749 c            iii=ii
5750 c            jjj=jj
5751 c          endif
5752           if (ii.gt.nres) then
5753             iii=ii-nres
5754           else
5755             iii=ii
5756           endif
5757           if (jj.gt.nres) then
5758             jjj=jj-nres
5759           else
5760             jjj=jj
5761           endif
5762           if (iii.lt.ii) then
5763             do j=1,3
5764               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5765             enddo
5766           endif
5767           if (jjj.lt.jj) then
5768             do j=1,3
5769               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5770             enddo
5771           endif
5772           do k=1,3
5773             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5774             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5775           enddo
5776         enddo
5777       enddo
5778       do i=link_start,link_end
5779 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5780 C CA-CA distance used in regularization of structure.
5781         ii=ihpb(i)
5782         jj=jhpb(i)
5783 C iii and jjj point to the residues for which the distance is assigned.
5784         if (ii.gt.nres) then
5785           iii=ii-nres
5786         else
5787           iii=ii
5788         endif
5789         if (jj.gt.nres) then
5790           jjj=jj-nres
5791         else
5792           jjj=jj
5793         endif
5794 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5795 c     &    dhpb(i),dhpb1(i),forcon(i)
5796 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5797 C    distance and angle dependent SS bond potential.
5798 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5799 C     & iabs(itype(jjj)).eq.1) then
5800 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5801 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5802         if (.not.dyn_ss .and. i.le.nss) then
5803 C 15/02/13 CC dynamic SSbond - additional check
5804           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5805      &        iabs(itype(jjj)).eq.1) then
5806            call ssbond_ene(iii,jjj,eij)
5807            ehpb=ehpb+2*eij
5808          endif
5809 cd          write (iout,*) "eij",eij
5810 cd   &   ' waga=',waga,' fac=',fac
5811 !        else if (ii.gt.nres .and. jj.gt.nres) then
5812         else
5813 C Calculate the distance between the two points and its difference from the
5814 C target distance.
5815           dd=dist(ii,jj)
5816           if (irestr_type(i).eq.11) then
5817             ehpb=ehpb+fordepth(i)!**4.0d0
5818      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5819             fac=fordepth(i)!**4.0d0
5820      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5821             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5822      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5823      &        ehpb,irestr_type(i)
5824           else if (irestr_type(i).eq.10) then
5825 c AL 6//19/2018 cross-link restraints
5826             xdis = 0.5d0*(dd/forcon(i))**2
5827             expdis = dexp(-xdis)
5828 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5829             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5830 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5831 c     &          " wboltzd",wboltzd
5832             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5833 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5834             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5835      &           *expdis/(aux*forcon(i)**2)
5836             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5837      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5838      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5839           else if (irestr_type(i).eq.2) then
5840 c Quartic restraints
5841             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5842             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5843      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5844      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5845             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5846           else
5847 c Quadratic restraints
5848             rdis=dd-dhpb(i)
5849 C Get the force constant corresponding to this distance.
5850             waga=forcon(i)
5851 C Calculate the contribution to energy.
5852             ehpb=ehpb+0.5d0*waga*rdis*rdis
5853             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5854      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5855      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5856 C
5857 C Evaluate gradient.
5858 C
5859             fac=waga*rdis/dd
5860           endif
5861 c Calculate Cartesian gradient
5862           do j=1,3
5863             ggg(j)=fac*(c(j,jj)-c(j,ii))
5864           enddo
5865 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5866 C If this is a SC-SC distance, we need to calculate the contributions to the
5867 C Cartesian gradient in the SC vectors (ghpbx).
5868           if (iii.lt.ii) then
5869             do j=1,3
5870               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5871             enddo
5872           endif
5873           if (jjj.lt.jj) then
5874             do j=1,3
5875               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5876             enddo
5877           endif
5878           do k=1,3
5879             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5880             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5881           enddo
5882         endif
5883       enddo
5884       return
5885       end
5886 C--------------------------------------------------------------------------
5887       subroutine ssbond_ene(i,j,eij)
5888 C
5889 C Calculate the distance and angle dependent SS-bond potential energy
5890 C using a free-energy function derived based on RHF/6-31G** ab initio
5891 C calculations of diethyl disulfide.
5892 C
5893 C A. Liwo and U. Kozlowska, 11/24/03
5894 C
5895       implicit real*8 (a-h,o-z)
5896       include 'DIMENSIONS'
5897       include 'COMMON.SBRIDGE'
5898       include 'COMMON.CHAIN'
5899       include 'COMMON.DERIV'
5900       include 'COMMON.LOCAL'
5901       include 'COMMON.INTERACT'
5902       include 'COMMON.VAR'
5903       include 'COMMON.IOUNITS'
5904       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5905       itypi=iabs(itype(i))
5906       xi=c(1,nres+i)
5907       yi=c(2,nres+i)
5908       zi=c(3,nres+i)
5909       dxi=dc_norm(1,nres+i)
5910       dyi=dc_norm(2,nres+i)
5911       dzi=dc_norm(3,nres+i)
5912 c      dsci_inv=dsc_inv(itypi)
5913       dsci_inv=vbld_inv(nres+i)
5914       itypj=iabs(itype(j))
5915 c      dscj_inv=dsc_inv(itypj)
5916       dscj_inv=vbld_inv(nres+j)
5917       xj=c(1,nres+j)-xi
5918       yj=c(2,nres+j)-yi
5919       zj=c(3,nres+j)-zi
5920       dxj=dc_norm(1,nres+j)
5921       dyj=dc_norm(2,nres+j)
5922       dzj=dc_norm(3,nres+j)
5923       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5924       rij=dsqrt(rrij)
5925       erij(1)=xj*rij
5926       erij(2)=yj*rij
5927       erij(3)=zj*rij
5928       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5929       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5930       om12=dxi*dxj+dyi*dyj+dzi*dzj
5931       do k=1,3
5932         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5933         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5934       enddo
5935       rij=1.0d0/rij
5936       deltad=rij-d0cm
5937       deltat1=1.0d0-om1
5938       deltat2=1.0d0+om2
5939       deltat12=om2-om1+2.0d0
5940       cosphi=om12-om1*om2
5941       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5942      &  +akct*deltad*deltat12
5943      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5944 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5945 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5946 c     &  " deltat12",deltat12," eij",eij
5947       ed=2*akcm*deltad+akct*deltat12
5948       pom1=akct*deltad
5949       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5950       eom1=-2*akth*deltat1-pom1-om2*pom2
5951       eom2= 2*akth*deltat2+pom1-om1*pom2
5952       eom12=pom2
5953       do k=1,3
5954         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5955         ghpbx(k,i)=ghpbx(k,i)-ggk
5956      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5957      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5958         ghpbx(k,j)=ghpbx(k,j)+ggk
5959      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5960      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5961         ghpbc(k,i)=ghpbc(k,i)-ggk
5962         ghpbc(k,j)=ghpbc(k,j)+ggk
5963       enddo
5964 C
5965 C Calculate the components of the gradient in DC and X
5966 C
5967 cgrad      do k=i,j-1
5968 cgrad        do l=1,3
5969 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5970 cgrad        enddo
5971 cgrad      enddo
5972       return
5973       end
5974 C--------------------------------------------------------------------------
5975       subroutine ebond(estr)
5976 c
5977 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5978 c
5979       implicit real*8 (a-h,o-z)
5980       include 'DIMENSIONS'
5981       include 'COMMON.LOCAL'
5982       include 'COMMON.GEO'
5983       include 'COMMON.INTERACT'
5984       include 'COMMON.DERIV'
5985       include 'COMMON.VAR'
5986       include 'COMMON.CHAIN'
5987       include 'COMMON.IOUNITS'
5988       include 'COMMON.NAMES'
5989       include 'COMMON.FFIELD'
5990       include 'COMMON.CONTROL'
5991       include 'COMMON.SETUP'
5992       double precision u(3),ud(3)
5993       estr=0.0d0
5994       estr1=0.0d0
5995       do i=ibondp_start,ibondp_end
5996 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5997 c      used
5998 #ifdef FIVEDIAG
5999         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6000         diff = vbld(i)-vbldp0
6001 #else
6002         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6003 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6004 c          do j=1,3
6005 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6006 c     &      *dc(j,i-1)/vbld(i)
6007 c          enddo
6008 c          if (energy_dec) write(iout,*)
6009 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6010 c        else
6011 C       Checking if it involves dummy (NH3+ or COO-) group
6012         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6013 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6014           diff = vbld(i)-vbldpDUM
6015           if (energy_dec) write(iout,*) "dum_bond",i,diff
6016         else
6017 C NO    vbldp0 is the equlibrium length of spring for peptide group
6018           diff = vbld(i)-vbldp0
6019         endif
6020 #endif
6021         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6022      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6023         estr=estr+diff*diff
6024         do j=1,3
6025           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6026         enddo
6027 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6028 c        endif
6029       enddo
6030
6031       estr=0.5d0*AKP*estr+estr1
6032 c
6033 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6034 c
6035       do i=ibond_start,ibond_end
6036         iti=iabs(itype(i))
6037         if (iti.ne.10 .and. iti.ne.ntyp1) then
6038           nbi=nbondterm(iti)
6039           if (nbi.eq.1) then
6040             diff=vbld(i+nres)-vbldsc0(1,iti)
6041             if (energy_dec)  write (iout,*)
6042      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6043      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6044             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6045             do j=1,3
6046               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6047             enddo
6048           else
6049             do j=1,nbi
6050               diff=vbld(i+nres)-vbldsc0(j,iti)
6051               ud(j)=aksc(j,iti)*diff
6052               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6053             enddo
6054             uprod=u(1)
6055             do j=2,nbi
6056               uprod=uprod*u(j)
6057             enddo
6058             usum=0.0d0
6059             usumsqder=0.0d0
6060             do j=1,nbi
6061               uprod1=1.0d0
6062               uprod2=1.0d0
6063               do k=1,nbi
6064                 if (k.ne.j) then
6065                   uprod1=uprod1*u(k)
6066                   uprod2=uprod2*u(k)*u(k)
6067                 endif
6068               enddo
6069               usum=usum+uprod1
6070               usumsqder=usumsqder+ud(j)*uprod2
6071             enddo
6072             estr=estr+uprod/usum
6073             do j=1,3
6074              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6075             enddo
6076           endif
6077         endif
6078       enddo
6079       return
6080       end
6081 #ifdef CRYST_THETA
6082 C--------------------------------------------------------------------------
6083       subroutine ebend(etheta)
6084 C
6085 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6086 C angles gamma and its derivatives in consecutive thetas and gammas.
6087 C
6088       implicit real*8 (a-h,o-z)
6089       include 'DIMENSIONS'
6090       include 'COMMON.LOCAL'
6091       include 'COMMON.GEO'
6092       include 'COMMON.INTERACT'
6093       include 'COMMON.DERIV'
6094       include 'COMMON.VAR'
6095       include 'COMMON.CHAIN'
6096       include 'COMMON.IOUNITS'
6097       include 'COMMON.NAMES'
6098       include 'COMMON.FFIELD'
6099       include 'COMMON.CONTROL'
6100       include 'COMMON.TORCNSTR'
6101       common /calcthet/ term1,term2,termm,diffak,ratak,
6102      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6103      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6104       double precision y(2),z(2)
6105       delta=0.02d0*pi
6106 c      time11=dexp(-2*time)
6107 c      time12=1.0d0
6108       etheta=0.0D0
6109 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6110       do i=ithet_start,ithet_end
6111         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6112      &  .or.itype(i).eq.ntyp1) cycle
6113 C Zero the energy function and its derivative at 0 or pi.
6114         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6115         it=itype(i-1)
6116         ichir1=isign(1,itype(i-2))
6117         ichir2=isign(1,itype(i))
6118          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6119          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6120          if (itype(i-1).eq.10) then
6121           itype1=isign(10,itype(i-2))
6122           ichir11=isign(1,itype(i-2))
6123           ichir12=isign(1,itype(i-2))
6124           itype2=isign(10,itype(i))
6125           ichir21=isign(1,itype(i))
6126           ichir22=isign(1,itype(i))
6127          endif
6128
6129         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6130 #ifdef OSF
6131           phii=phi(i)
6132           if (phii.ne.phii) phii=150.0
6133 #else
6134           phii=phi(i)
6135 #endif
6136           y(1)=dcos(phii)
6137           y(2)=dsin(phii)
6138         else
6139           y(1)=0.0D0
6140           y(2)=0.0D0
6141         endif
6142         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6143 #ifdef OSF
6144           phii1=phi(i+1)
6145           if (phii1.ne.phii1) phii1=150.0
6146           phii1=pinorm(phii1)
6147           z(1)=cos(phii1)
6148 #else
6149           phii1=phi(i+1)
6150 #endif
6151           z(1)=dcos(phii1)
6152           z(2)=dsin(phii1)
6153         else
6154           z(1)=0.0D0
6155           z(2)=0.0D0
6156         endif
6157 C Calculate the "mean" value of theta from the part of the distribution
6158 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6159 C In following comments this theta will be referred to as t_c.
6160         thet_pred_mean=0.0d0
6161         do k=1,2
6162             athetk=athet(k,it,ichir1,ichir2)
6163             bthetk=bthet(k,it,ichir1,ichir2)
6164           if (it.eq.10) then
6165              athetk=athet(k,itype1,ichir11,ichir12)
6166              bthetk=bthet(k,itype2,ichir21,ichir22)
6167           endif
6168          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6169 c         write(iout,*) 'chuj tu', y(k),z(k)
6170         enddo
6171         dthett=thet_pred_mean*ssd
6172         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6173 C Derivatives of the "mean" values in gamma1 and gamma2.
6174         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6175      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6176          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6177      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6178          if (it.eq.10) then
6179       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6180      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6181         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6182      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6183          endif
6184         if (theta(i).gt.pi-delta) then
6185           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6186      &         E_tc0)
6187           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6188           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6189           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6190      &        E_theta)
6191           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6192      &        E_tc)
6193         else if (theta(i).lt.delta) then
6194           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6195           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6196           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6197      &        E_theta)
6198           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6199           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6200      &        E_tc)
6201         else
6202           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6203      &        E_theta,E_tc)
6204         endif
6205         etheta=etheta+ethetai
6206         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6207      &      'ebend',i,ethetai,theta(i),itype(i)
6208         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6209         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6210         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6211       enddo
6212
6213 C Ufff.... We've done all this!!!
6214       return
6215       end
6216 C---------------------------------------------------------------------------
6217       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6218      &     E_tc)
6219       implicit real*8 (a-h,o-z)
6220       include 'DIMENSIONS'
6221       include 'COMMON.LOCAL'
6222       include 'COMMON.IOUNITS'
6223       common /calcthet/ term1,term2,termm,diffak,ratak,
6224      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6225      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6226 C Calculate the contributions to both Gaussian lobes.
6227 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6228 C The "polynomial part" of the "standard deviation" of this part of
6229 C the distributioni.
6230 ccc        write (iout,*) thetai,thet_pred_mean
6231         sig=polthet(3,it)
6232         do j=2,0,-1
6233           sig=sig*thet_pred_mean+polthet(j,it)
6234         enddo
6235 C Derivative of the "interior part" of the "standard deviation of the"
6236 C gamma-dependent Gaussian lobe in t_c.
6237         sigtc=3*polthet(3,it)
6238         do j=2,1,-1
6239           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6240         enddo
6241         sigtc=sig*sigtc
6242 C Set the parameters of both Gaussian lobes of the distribution.
6243 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6244         fac=sig*sig+sigc0(it)
6245         sigcsq=fac+fac
6246         sigc=1.0D0/sigcsq
6247 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6248         sigsqtc=-4.0D0*sigcsq*sigtc
6249 c       print *,i,sig,sigtc,sigsqtc
6250 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6251         sigtc=-sigtc/(fac*fac)
6252 C Following variable is sigma(t_c)**(-2)
6253         sigcsq=sigcsq*sigcsq
6254         sig0i=sig0(it)
6255         sig0inv=1.0D0/sig0i**2
6256         delthec=thetai-thet_pred_mean
6257         delthe0=thetai-theta0i
6258         term1=-0.5D0*sigcsq*delthec*delthec
6259         term2=-0.5D0*sig0inv*delthe0*delthe0
6260 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6261 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6262 C NaNs in taking the logarithm. We extract the largest exponent which is added
6263 C to the energy (this being the log of the distribution) at the end of energy
6264 C term evaluation for this virtual-bond angle.
6265         if (term1.gt.term2) then
6266           termm=term1
6267           term2=dexp(term2-termm)
6268           term1=1.0d0
6269         else
6270           termm=term2
6271           term1=dexp(term1-termm)
6272           term2=1.0d0
6273         endif
6274 C The ratio between the gamma-independent and gamma-dependent lobes of
6275 C the distribution is a Gaussian function of thet_pred_mean too.
6276         diffak=gthet(2,it)-thet_pred_mean
6277         ratak=diffak/gthet(3,it)**2
6278         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6279 C Let's differentiate it in thet_pred_mean NOW.
6280         aktc=ak*ratak
6281 C Now put together the distribution terms to make complete distribution.
6282         termexp=term1+ak*term2
6283         termpre=sigc+ak*sig0i
6284 C Contribution of the bending energy from this theta is just the -log of
6285 C the sum of the contributions from the two lobes and the pre-exponential
6286 C factor. Simple enough, isn't it?
6287         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6288 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6289 C NOW the derivatives!!!
6290 C 6/6/97 Take into account the deformation.
6291         E_theta=(delthec*sigcsq*term1
6292      &       +ak*delthe0*sig0inv*term2)/termexp
6293         E_tc=((sigtc+aktc*sig0i)/termpre
6294      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6295      &       aktc*term2)/termexp)
6296       return
6297       end
6298 c-----------------------------------------------------------------------------
6299       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6300       implicit real*8 (a-h,o-z)
6301       include 'DIMENSIONS'
6302       include 'COMMON.LOCAL'
6303       include 'COMMON.IOUNITS'
6304       common /calcthet/ term1,term2,termm,diffak,ratak,
6305      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6306      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6307       delthec=thetai-thet_pred_mean
6308       delthe0=thetai-theta0i
6309 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6310       t3 = thetai-thet_pred_mean
6311       t6 = t3**2
6312       t9 = term1
6313       t12 = t3*sigcsq
6314       t14 = t12+t6*sigsqtc
6315       t16 = 1.0d0
6316       t21 = thetai-theta0i
6317       t23 = t21**2
6318       t26 = term2
6319       t27 = t21*t26
6320       t32 = termexp
6321       t40 = t32**2
6322       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6323      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6324      & *(-t12*t9-ak*sig0inv*t27)
6325       return
6326       end
6327 #else
6328 C--------------------------------------------------------------------------
6329       subroutine ebend(etheta)
6330 C
6331 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6332 C angles gamma and its derivatives in consecutive thetas and gammas.
6333 C ab initio-derived potentials from
6334 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6335 C
6336       implicit real*8 (a-h,o-z)
6337       include 'DIMENSIONS'
6338       include 'COMMON.LOCAL'
6339       include 'COMMON.GEO'
6340       include 'COMMON.INTERACT'
6341       include 'COMMON.DERIV'
6342       include 'COMMON.VAR'
6343       include 'COMMON.CHAIN'
6344       include 'COMMON.IOUNITS'
6345       include 'COMMON.NAMES'
6346       include 'COMMON.FFIELD'
6347       include 'COMMON.CONTROL'
6348       include 'COMMON.TORCNSTR'
6349       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6350      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6351      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6352      & sinph1ph2(maxdouble,maxdouble)
6353       logical lprn /.false./, lprn1 /.false./
6354       etheta=0.0D0
6355       do i=ithet_start,ithet_end
6356 c        print *,i,itype(i-1),itype(i),itype(i-2)
6357         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6358      &  .or.itype(i).eq.ntyp1) cycle
6359 C        print *,i,theta(i)
6360         if (iabs(itype(i+1)).eq.20) iblock=2
6361         if (iabs(itype(i+1)).ne.20) iblock=1
6362         dethetai=0.0d0
6363         dephii=0.0d0
6364         dephii1=0.0d0
6365         theti2=0.5d0*theta(i)
6366         ityp2=ithetyp((itype(i-1)))
6367         do k=1,nntheterm
6368           coskt(k)=dcos(k*theti2)
6369           sinkt(k)=dsin(k*theti2)
6370         enddo
6371 C        print *,ethetai
6372         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6373 #ifdef OSF
6374           phii=phi(i)
6375           if (phii.ne.phii) phii=150.0
6376 #else
6377           phii=phi(i)
6378 #endif
6379           ityp1=ithetyp((itype(i-2)))
6380 C propagation of chirality for glycine type
6381           do k=1,nsingle
6382             cosph1(k)=dcos(k*phii)
6383             sinph1(k)=dsin(k*phii)
6384           enddo
6385         else
6386           phii=0.0d0
6387           do k=1,nsingle
6388           ityp1=ithetyp((itype(i-2)))
6389             cosph1(k)=0.0d0
6390             sinph1(k)=0.0d0
6391           enddo
6392         endif
6393         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6394 #ifdef OSF
6395           phii1=phi(i+1)
6396           if (phii1.ne.phii1) phii1=150.0
6397           phii1=pinorm(phii1)
6398 #else
6399           phii1=phi(i+1)
6400 #endif
6401           ityp3=ithetyp((itype(i)))
6402           do k=1,nsingle
6403             cosph2(k)=dcos(k*phii1)
6404             sinph2(k)=dsin(k*phii1)
6405           enddo
6406         else
6407           phii1=0.0d0
6408           ityp3=ithetyp((itype(i)))
6409           do k=1,nsingle
6410             cosph2(k)=0.0d0
6411             sinph2(k)=0.0d0
6412           enddo
6413         endif
6414         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6415         do k=1,ndouble
6416           do l=1,k-1
6417             ccl=cosph1(l)*cosph2(k-l)
6418             ssl=sinph1(l)*sinph2(k-l)
6419             scl=sinph1(l)*cosph2(k-l)
6420             csl=cosph1(l)*sinph2(k-l)
6421             cosph1ph2(l,k)=ccl-ssl
6422             cosph1ph2(k,l)=ccl+ssl
6423             sinph1ph2(l,k)=scl+csl
6424             sinph1ph2(k,l)=scl-csl
6425           enddo
6426         enddo
6427         if (lprn) then
6428         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6429      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6430         write (iout,*) "coskt and sinkt"
6431         do k=1,nntheterm
6432           write (iout,*) k,coskt(k),sinkt(k)
6433         enddo
6434         endif
6435         do k=1,ntheterm
6436           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6437           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6438      &      *coskt(k)
6439           if (lprn)
6440      &    write (iout,*) "k",k,"
6441      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6442      &     " ethetai",ethetai
6443         enddo
6444         if (lprn) then
6445         write (iout,*) "cosph and sinph"
6446         do k=1,nsingle
6447           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6448         enddo
6449         write (iout,*) "cosph1ph2 and sinph2ph2"
6450         do k=2,ndouble
6451           do l=1,k-1
6452             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6453      &         sinph1ph2(l,k),sinph1ph2(k,l)
6454           enddo
6455         enddo
6456         write(iout,*) "ethetai",ethetai
6457         endif
6458 C       print *,ethetai
6459         do m=1,ntheterm2
6460           do k=1,nsingle
6461             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6462      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6463      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6464      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6465             ethetai=ethetai+sinkt(m)*aux
6466             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6467             dephii=dephii+k*sinkt(m)*(
6468      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6469      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6470             dephii1=dephii1+k*sinkt(m)*(
6471      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6472      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6473             if (lprn)
6474      &      write (iout,*) "m",m," k",k," bbthet",
6475      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6476      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6477      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6478      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6479 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6480           enddo
6481         enddo
6482 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6483 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6484 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6485 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6486         if (lprn)
6487      &  write(iout,*) "ethetai",ethetai
6488 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6489         do m=1,ntheterm3
6490           do k=2,ndouble
6491             do l=1,k-1
6492               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6493      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6494      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6495      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6496               ethetai=ethetai+sinkt(m)*aux
6497               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6498               dephii=dephii+l*sinkt(m)*(
6499      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6500      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6501      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6502      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6503               dephii1=dephii1+(k-l)*sinkt(m)*(
6504      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6505      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6506      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6507      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6508               if (lprn) then
6509               write (iout,*) "m",m," k",k," l",l," ffthet",
6510      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6511      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6512      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6513      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6514      &            " ethetai",ethetai
6515               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6516      &            cosph1ph2(k,l)*sinkt(m),
6517      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6518               endif
6519             enddo
6520           enddo
6521         enddo
6522 10      continue
6523 c        lprn1=.true.
6524 C        print *,ethetai
6525         if (lprn1)
6526      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6527      &   i,theta(i)*rad2deg,phii*rad2deg,
6528      &   phii1*rad2deg,ethetai
6529 c        lprn1=.false.
6530         etheta=etheta+ethetai
6531         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6532         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6533         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6534       enddo
6535
6536       return
6537       end
6538 #endif
6539 #ifdef CRYST_SC
6540 c-----------------------------------------------------------------------------
6541       subroutine esc(escloc)
6542 C Calculate the local energy of a side chain and its derivatives in the
6543 C corresponding virtual-bond valence angles THETA and the spherical angles
6544 C ALPHA and OMEGA.
6545       implicit real*8 (a-h,o-z)
6546       include 'DIMENSIONS'
6547       include 'COMMON.GEO'
6548       include 'COMMON.LOCAL'
6549       include 'COMMON.VAR'
6550       include 'COMMON.INTERACT'
6551       include 'COMMON.DERIV'
6552       include 'COMMON.CHAIN'
6553       include 'COMMON.IOUNITS'
6554       include 'COMMON.NAMES'
6555       include 'COMMON.FFIELD'
6556       include 'COMMON.CONTROL'
6557       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6558      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6559       common /sccalc/ time11,time12,time112,theti,it,nlobit
6560       delta=0.02d0*pi
6561       escloc=0.0D0
6562 c     write (iout,'(a)') 'ESC'
6563       do i=loc_start,loc_end
6564         it=itype(i)
6565         if (it.eq.ntyp1) cycle
6566         if (it.eq.10) goto 1
6567         nlobit=nlob(iabs(it))
6568 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6569 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6570         theti=theta(i+1)-pipol
6571         x(1)=dtan(theti)
6572         x(2)=alph(i)
6573         x(3)=omeg(i)
6574
6575         if (x(2).gt.pi-delta) then
6576           xtemp(1)=x(1)
6577           xtemp(2)=pi-delta
6578           xtemp(3)=x(3)
6579           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6580           xtemp(2)=pi
6581           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6582           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6583      &        escloci,dersc(2))
6584           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6585      &        ddersc0(1),dersc(1))
6586           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6587      &        ddersc0(3),dersc(3))
6588           xtemp(2)=pi-delta
6589           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6590           xtemp(2)=pi
6591           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6592           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6593      &            dersc0(2),esclocbi,dersc02)
6594           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6595      &            dersc12,dersc01)
6596           call splinthet(x(2),0.5d0*delta,ss,ssd)
6597           dersc0(1)=dersc01
6598           dersc0(2)=dersc02
6599           dersc0(3)=0.0d0
6600           do k=1,3
6601             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6602           enddo
6603           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6604 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6605 c    &             esclocbi,ss,ssd
6606           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6607 c         escloci=esclocbi
6608 c         write (iout,*) escloci
6609         else if (x(2).lt.delta) then
6610           xtemp(1)=x(1)
6611           xtemp(2)=delta
6612           xtemp(3)=x(3)
6613           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6614           xtemp(2)=0.0d0
6615           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6616           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6617      &        escloci,dersc(2))
6618           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6619      &        ddersc0(1),dersc(1))
6620           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6621      &        ddersc0(3),dersc(3))
6622           xtemp(2)=delta
6623           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6624           xtemp(2)=0.0d0
6625           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6626           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6627      &            dersc0(2),esclocbi,dersc02)
6628           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6629      &            dersc12,dersc01)
6630           dersc0(1)=dersc01
6631           dersc0(2)=dersc02
6632           dersc0(3)=0.0d0
6633           call splinthet(x(2),0.5d0*delta,ss,ssd)
6634           do k=1,3
6635             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6636           enddo
6637           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6638 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6639 c    &             esclocbi,ss,ssd
6640           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6641 c         write (iout,*) escloci
6642         else
6643           call enesc(x,escloci,dersc,ddummy,.false.)
6644         endif
6645
6646         escloc=escloc+escloci
6647         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6648      &     'escloc',i,escloci
6649 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6650
6651         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6652      &   wscloc*dersc(1)
6653         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6654         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6655     1   continue
6656       enddo
6657       return
6658       end
6659 C---------------------------------------------------------------------------
6660       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6661       implicit real*8 (a-h,o-z)
6662       include 'DIMENSIONS'
6663       include 'COMMON.GEO'
6664       include 'COMMON.LOCAL'
6665       include 'COMMON.IOUNITS'
6666       common /sccalc/ time11,time12,time112,theti,it,nlobit
6667       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6668       double precision contr(maxlob,-1:1)
6669       logical mixed
6670 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6671         escloc_i=0.0D0
6672         do j=1,3
6673           dersc(j)=0.0D0
6674           if (mixed) ddersc(j)=0.0d0
6675         enddo
6676         x3=x(3)
6677
6678 C Because of periodicity of the dependence of the SC energy in omega we have
6679 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6680 C To avoid underflows, first compute & store the exponents.
6681
6682         do iii=-1,1
6683
6684           x(3)=x3+iii*dwapi
6685
6686           do j=1,nlobit
6687             do k=1,3
6688               z(k)=x(k)-censc(k,j,it)
6689             enddo
6690             do k=1,3
6691               Axk=0.0D0
6692               do l=1,3
6693                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6694               enddo
6695               Ax(k,j,iii)=Axk
6696             enddo
6697             expfac=0.0D0
6698             do k=1,3
6699               expfac=expfac+Ax(k,j,iii)*z(k)
6700             enddo
6701             contr(j,iii)=expfac
6702           enddo ! j
6703
6704         enddo ! iii
6705
6706         x(3)=x3
6707 C As in the case of ebend, we want to avoid underflows in exponentiation and
6708 C subsequent NaNs and INFs in energy calculation.
6709 C Find the largest exponent
6710         emin=contr(1,-1)
6711         do iii=-1,1
6712           do j=1,nlobit
6713             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6714           enddo
6715         enddo
6716         emin=0.5D0*emin
6717 cd      print *,'it=',it,' emin=',emin
6718
6719 C Compute the contribution to SC energy and derivatives
6720         do iii=-1,1
6721
6722           do j=1,nlobit
6723 #ifdef OSF
6724             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6725             if(adexp.ne.adexp) adexp=1.0
6726             expfac=dexp(adexp)
6727 #else
6728             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6729 #endif
6730 cd          print *,'j=',j,' expfac=',expfac
6731             escloc_i=escloc_i+expfac
6732             do k=1,3
6733               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6734             enddo
6735             if (mixed) then
6736               do k=1,3,2
6737                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6738      &            +gaussc(k,2,j,it))*expfac
6739               enddo
6740             endif
6741           enddo
6742
6743         enddo ! iii
6744
6745         dersc(1)=dersc(1)/cos(theti)**2
6746         ddersc(1)=ddersc(1)/cos(theti)**2
6747         ddersc(3)=ddersc(3)
6748
6749         escloci=-(dlog(escloc_i)-emin)
6750         do j=1,3
6751           dersc(j)=dersc(j)/escloc_i
6752         enddo
6753         if (mixed) then
6754           do j=1,3,2
6755             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6756           enddo
6757         endif
6758       return
6759       end
6760 C------------------------------------------------------------------------------
6761       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6762       implicit real*8 (a-h,o-z)
6763       include 'DIMENSIONS'
6764       include 'COMMON.GEO'
6765       include 'COMMON.LOCAL'
6766       include 'COMMON.IOUNITS'
6767       common /sccalc/ time11,time12,time112,theti,it,nlobit
6768       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6769       double precision contr(maxlob)
6770       logical mixed
6771
6772       escloc_i=0.0D0
6773
6774       do j=1,3
6775         dersc(j)=0.0D0
6776       enddo
6777
6778       do j=1,nlobit
6779         do k=1,2
6780           z(k)=x(k)-censc(k,j,it)
6781         enddo
6782         z(3)=dwapi
6783         do k=1,3
6784           Axk=0.0D0
6785           do l=1,3
6786             Axk=Axk+gaussc(l,k,j,it)*z(l)
6787           enddo
6788           Ax(k,j)=Axk
6789         enddo
6790         expfac=0.0D0
6791         do k=1,3
6792           expfac=expfac+Ax(k,j)*z(k)
6793         enddo
6794         contr(j)=expfac
6795       enddo ! j
6796
6797 C As in the case of ebend, we want to avoid underflows in exponentiation and
6798 C subsequent NaNs and INFs in energy calculation.
6799 C Find the largest exponent
6800       emin=contr(1)
6801       do j=1,nlobit
6802         if (emin.gt.contr(j)) emin=contr(j)
6803       enddo
6804       emin=0.5D0*emin
6805
6806 C Compute the contribution to SC energy and derivatives
6807
6808       dersc12=0.0d0
6809       do j=1,nlobit
6810         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6811         escloc_i=escloc_i+expfac
6812         do k=1,2
6813           dersc(k)=dersc(k)+Ax(k,j)*expfac
6814         enddo
6815         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6816      &            +gaussc(1,2,j,it))*expfac
6817         dersc(3)=0.0d0
6818       enddo
6819
6820       dersc(1)=dersc(1)/cos(theti)**2
6821       dersc12=dersc12/cos(theti)**2
6822       escloci=-(dlog(escloc_i)-emin)
6823       do j=1,2
6824         dersc(j)=dersc(j)/escloc_i
6825       enddo
6826       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6827       return
6828       end
6829 #else
6830 c----------------------------------------------------------------------------------
6831       subroutine esc(escloc)
6832 C Calculate the local energy of a side chain and its derivatives in the
6833 C corresponding virtual-bond valence angles THETA and the spherical angles
6834 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6835 C added by Urszula Kozlowska. 07/11/2007
6836 C
6837       implicit real*8 (a-h,o-z)
6838       include 'DIMENSIONS'
6839       include 'COMMON.GEO'
6840       include 'COMMON.LOCAL'
6841       include 'COMMON.VAR'
6842       include 'COMMON.SCROT'
6843       include 'COMMON.INTERACT'
6844       include 'COMMON.DERIV'
6845       include 'COMMON.CHAIN'
6846       include 'COMMON.IOUNITS'
6847       include 'COMMON.NAMES'
6848       include 'COMMON.FFIELD'
6849       include 'COMMON.CONTROL'
6850       include 'COMMON.VECTORS'
6851       double precision x_prime(3),y_prime(3),z_prime(3)
6852      &    , sumene,dsc_i,dp2_i,x(65),
6853      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6854      &    de_dxx,de_dyy,de_dzz,de_dt
6855       double precision s1_t,s1_6_t,s2_t,s2_6_t
6856       double precision
6857      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6858      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6859      & dt_dCi(3),dt_dCi1(3)
6860       common /sccalc/ time11,time12,time112,theti,it,nlobit
6861       delta=0.02d0*pi
6862       escloc=0.0D0
6863       do i=loc_start,loc_end
6864         if (itype(i).eq.ntyp1) cycle
6865         costtab(i+1) =dcos(theta(i+1))
6866         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6867         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6868         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6869         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6870         cosfac=dsqrt(cosfac2)
6871         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6872         sinfac=dsqrt(sinfac2)
6873         it=iabs(itype(i))
6874         if (it.eq.10) goto 1
6875 c
6876 C  Compute the axes of tghe local cartesian coordinates system; store in
6877 c   x_prime, y_prime and z_prime
6878 c
6879         do j=1,3
6880           x_prime(j) = 0.00
6881           y_prime(j) = 0.00
6882           z_prime(j) = 0.00
6883         enddo
6884 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6885 C     &   dc_norm(3,i+nres)
6886         do j = 1,3
6887           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6888           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6889         enddo
6890         do j = 1,3
6891           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6892         enddo
6893 c       write (2,*) "i",i
6894 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6895 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6896 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6897 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6898 c      & " xy",scalar(x_prime(1),y_prime(1)),
6899 c      & " xz",scalar(x_prime(1),z_prime(1)),
6900 c      & " yy",scalar(y_prime(1),y_prime(1)),
6901 c      & " yz",scalar(y_prime(1),z_prime(1)),
6902 c      & " zz",scalar(z_prime(1),z_prime(1))
6903 c
6904 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6905 C to local coordinate system. Store in xx, yy, zz.
6906 c
6907         xx=0.0d0
6908         yy=0.0d0
6909         zz=0.0d0
6910         do j = 1,3
6911           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6912           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6913           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6914         enddo
6915
6916         xxtab(i)=xx
6917         yytab(i)=yy
6918         zztab(i)=zz
6919 C
6920 C Compute the energy of the ith side cbain
6921 C
6922 c        write (2,*) "xx",xx," yy",yy," zz",zz
6923         it=iabs(itype(i))
6924         do j = 1,65
6925           x(j) = sc_parmin(j,it)
6926         enddo
6927 #ifdef CHECK_COORD
6928 Cc diagnostics - remove later
6929         xx1 = dcos(alph(2))
6930         yy1 = dsin(alph(2))*dcos(omeg(2))
6931         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6932         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6933      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6934      &    xx1,yy1,zz1
6935 C,"  --- ", xx_w,yy_w,zz_w
6936 c end diagnostics
6937 #endif
6938         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6939      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6940      &   + x(10)*yy*zz
6941         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6942      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6943      & + x(20)*yy*zz
6944         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6945      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6946      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6947      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6948      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6949      &  +x(40)*xx*yy*zz
6950         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6951      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6952      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6953      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6954      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6955      &  +x(60)*xx*yy*zz
6956         dsc_i   = 0.743d0+x(61)
6957         dp2_i   = 1.9d0+x(62)
6958         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6959      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6960         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6961      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6962         s1=(1+x(63))/(0.1d0 + dscp1)
6963         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6964         s2=(1+x(65))/(0.1d0 + dscp2)
6965         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6966         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6967      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6968 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6969 c     &   sumene4,
6970 c     &   dscp1,dscp2,sumene
6971 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6972         escloc = escloc + sumene
6973         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6974      &   " escloc",sumene,escloc,it,itype(i)
6975 c     & ,zz,xx,yy
6976 c#define DEBUG
6977 #ifdef DEBUG
6978 C
6979 C This section to check the numerical derivatives of the energy of ith side
6980 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6981 C #define DEBUG in the code to turn it on.
6982 C
6983         write (2,*) "sumene               =",sumene
6984         aincr=1.0d-7
6985         xxsave=xx
6986         xx=xx+aincr
6987         write (2,*) xx,yy,zz
6988         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6989         de_dxx_num=(sumenep-sumene)/aincr
6990         xx=xxsave
6991         write (2,*) "xx+ sumene from enesc=",sumenep
6992         yysave=yy
6993         yy=yy+aincr
6994         write (2,*) xx,yy,zz
6995         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6996         de_dyy_num=(sumenep-sumene)/aincr
6997         yy=yysave
6998         write (2,*) "yy+ sumene from enesc=",sumenep
6999         zzsave=zz
7000         zz=zz+aincr
7001         write (2,*) xx,yy,zz
7002         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7003         de_dzz_num=(sumenep-sumene)/aincr
7004         zz=zzsave
7005         write (2,*) "zz+ sumene from enesc=",sumenep
7006         costsave=cost2tab(i+1)
7007         sintsave=sint2tab(i+1)
7008         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7009         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7010         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7011         de_dt_num=(sumenep-sumene)/aincr
7012         write (2,*) " t+ sumene from enesc=",sumenep
7013         cost2tab(i+1)=costsave
7014         sint2tab(i+1)=sintsave
7015 C End of diagnostics section.
7016 #endif
7017 C
7018 C Compute the gradient of esc
7019 C
7020 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7021         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7022         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7023         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7024         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7025         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7026         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7027         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7028         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7029         pom1=(sumene3*sint2tab(i+1)+sumene1)
7030      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7031         pom2=(sumene4*cost2tab(i+1)+sumene2)
7032      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7033         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7034         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7035      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7036      &  +x(40)*yy*zz
7037         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7038         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7039      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7040      &  +x(60)*yy*zz
7041         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7042      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7043      &        +(pom1+pom2)*pom_dx
7044 #ifdef DEBUG
7045         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7046 #endif
7047 C
7048         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7049         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7050      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7051      &  +x(40)*xx*zz
7052         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7053         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7054      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7055      &  +x(59)*zz**2 +x(60)*xx*zz
7056         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7057      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7058      &        +(pom1-pom2)*pom_dy
7059 #ifdef DEBUG
7060         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7061 #endif
7062 C
7063         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7064      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7065      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7066      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7067      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7068      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7069      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7070      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7071 #ifdef DEBUG
7072         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7073 #endif
7074 C
7075         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7076      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7077      &  +pom1*pom_dt1+pom2*pom_dt2
7078 #ifdef DEBUG
7079         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7080 #endif
7081 c#undef DEBUG
7082 c
7083 C
7084        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7085        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7086        cosfac2xx=cosfac2*xx
7087        sinfac2yy=sinfac2*yy
7088        do k = 1,3
7089          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7090      &      vbld_inv(i+1)
7091          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7092      &      vbld_inv(i)
7093          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7094          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7095 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7096 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7097 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7098 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7099          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7100          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7101          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7102          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7103          dZZ_Ci1(k)=0.0d0
7104          dZZ_Ci(k)=0.0d0
7105          do j=1,3
7106            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7107      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7108            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7109      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7110          enddo
7111
7112          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7113          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7114          dZZ_XYZ(k)=vbld_inv(i+nres)*
7115      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7116 c
7117          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7118          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7119        enddo
7120
7121        do k=1,3
7122          dXX_Ctab(k,i)=dXX_Ci(k)
7123          dXX_C1tab(k,i)=dXX_Ci1(k)
7124          dYY_Ctab(k,i)=dYY_Ci(k)
7125          dYY_C1tab(k,i)=dYY_Ci1(k)
7126          dZZ_Ctab(k,i)=dZZ_Ci(k)
7127          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7128          dXX_XYZtab(k,i)=dXX_XYZ(k)
7129          dYY_XYZtab(k,i)=dYY_XYZ(k)
7130          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7131        enddo
7132
7133        do k = 1,3
7134 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7135 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7136 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7137 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7138 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7139 c     &    dt_dci(k)
7140 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7141 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7142          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7143      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7144          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7145      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7146          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7147      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7148        enddo
7149 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7150 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7151
7152 C to check gradient call subroutine check_grad
7153
7154     1 continue
7155       enddo
7156       return
7157       end
7158 c------------------------------------------------------------------------------
7159       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7160       implicit none
7161       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7162      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7163       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7164      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7165      &   + x(10)*yy*zz
7166       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7167      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7168      & + x(20)*yy*zz
7169       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7170      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7171      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7172      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7173      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7174      &  +x(40)*xx*yy*zz
7175       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7176      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7177      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7178      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7179      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7180      &  +x(60)*xx*yy*zz
7181       dsc_i   = 0.743d0+x(61)
7182       dp2_i   = 1.9d0+x(62)
7183       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7184      &          *(xx*cost2+yy*sint2))
7185       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7186      &          *(xx*cost2-yy*sint2))
7187       s1=(1+x(63))/(0.1d0 + dscp1)
7188       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7189       s2=(1+x(65))/(0.1d0 + dscp2)
7190       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7191       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7192      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7193       enesc=sumene
7194       return
7195       end
7196 #endif
7197 c------------------------------------------------------------------------------
7198       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7199 C
7200 C This procedure calculates two-body contact function g(rij) and its derivative:
7201 C
7202 C           eps0ij                                     !       x < -1
7203 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7204 C            0                                         !       x > 1
7205 C
7206 C where x=(rij-r0ij)/delta
7207 C
7208 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7209 C
7210       implicit none
7211       double precision rij,r0ij,eps0ij,fcont,fprimcont
7212       double precision x,x2,x4,delta
7213 c     delta=0.02D0*r0ij
7214 c      delta=0.2D0*r0ij
7215       x=(rij-r0ij)/delta
7216       if (x.lt.-1.0D0) then
7217         fcont=eps0ij
7218         fprimcont=0.0D0
7219       else if (x.le.1.0D0) then
7220         x2=x*x
7221         x4=x2*x2
7222         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7223         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7224       else
7225         fcont=0.0D0
7226         fprimcont=0.0D0
7227       endif
7228       return
7229       end
7230 c------------------------------------------------------------------------------
7231       subroutine splinthet(theti,delta,ss,ssder)
7232       implicit real*8 (a-h,o-z)
7233       include 'DIMENSIONS'
7234       include 'COMMON.VAR'
7235       include 'COMMON.GEO'
7236       thetup=pi-delta
7237       thetlow=delta
7238       if (theti.gt.pipol) then
7239         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7240       else
7241         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7242         ssder=-ssder
7243       endif
7244       return
7245       end
7246 c------------------------------------------------------------------------------
7247       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7248       implicit none
7249       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7250       double precision ksi,ksi2,ksi3,a1,a2,a3
7251       a1=fprim0*delta/(f1-f0)
7252       a2=3.0d0-2.0d0*a1
7253       a3=a1-2.0d0
7254       ksi=(x-x0)/delta
7255       ksi2=ksi*ksi
7256       ksi3=ksi2*ksi
7257       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7258       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7259       return
7260       end
7261 c------------------------------------------------------------------------------
7262       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7263       implicit none
7264       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7265       double precision ksi,ksi2,ksi3,a1,a2,a3
7266       ksi=(x-x0)/delta
7267       ksi2=ksi*ksi
7268       ksi3=ksi2*ksi
7269       a1=fprim0x*delta
7270       a2=3*(f1x-f0x)-2*fprim0x*delta
7271       a3=fprim0x*delta-2*(f1x-f0x)
7272       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7273       return
7274       end
7275 C-----------------------------------------------------------------------------
7276 #ifdef CRYST_TOR
7277 C-----------------------------------------------------------------------------
7278       subroutine etor(etors)
7279       implicit real*8 (a-h,o-z)
7280       include 'DIMENSIONS'
7281       include 'COMMON.VAR'
7282       include 'COMMON.GEO'
7283       include 'COMMON.LOCAL'
7284       include 'COMMON.TORSION'
7285       include 'COMMON.INTERACT'
7286       include 'COMMON.DERIV'
7287       include 'COMMON.CHAIN'
7288       include 'COMMON.NAMES'
7289       include 'COMMON.IOUNITS'
7290       include 'COMMON.FFIELD'
7291       include 'COMMON.TORCNSTR'
7292       include 'COMMON.CONTROL'
7293       logical lprn
7294 C Set lprn=.true. for debugging
7295       lprn=.false.
7296 c      lprn=.true.
7297       etors=0.0D0
7298       do i=iphi_start,iphi_end
7299       etors_ii=0.0D0
7300         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7301      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7302         itori=itortyp(itype(i-2))
7303         itori1=itortyp(itype(i-1))
7304         phii=phi(i)
7305         gloci=0.0D0
7306 C Proline-Proline pair is a special case...
7307         if (itori.eq.3 .and. itori1.eq.3) then
7308           if (phii.gt.-dwapi3) then
7309             cosphi=dcos(3*phii)
7310             fac=1.0D0/(1.0D0-cosphi)
7311             etorsi=v1(1,3,3)*fac
7312             etorsi=etorsi+etorsi
7313             etors=etors+etorsi-v1(1,3,3)
7314             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7315             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7316           endif
7317           do j=1,3
7318             v1ij=v1(j+1,itori,itori1)
7319             v2ij=v2(j+1,itori,itori1)
7320             cosphi=dcos(j*phii)
7321             sinphi=dsin(j*phii)
7322             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7323             if (energy_dec) etors_ii=etors_ii+
7324      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7325             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7326           enddo
7327         else
7328           do j=1,nterm_old
7329             v1ij=v1(j,itori,itori1)
7330             v2ij=v2(j,itori,itori1)
7331             cosphi=dcos(j*phii)
7332             sinphi=dsin(j*phii)
7333             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7334             if (energy_dec) etors_ii=etors_ii+
7335      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7336             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7337           enddo
7338         endif
7339         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7340              'etor',i,etors_ii
7341         if (lprn)
7342      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7343      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7344      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7345         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7346 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7347       enddo
7348       return
7349       end
7350 c------------------------------------------------------------------------------
7351       subroutine etor_d(etors_d)
7352       etors_d=0.0d0
7353       return
7354       end
7355 c----------------------------------------------------------------------------
7356 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7357       subroutine e_modeller(ehomology_constr)
7358       ehomology_constr=0.0d0
7359       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7360       return
7361       end
7362 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7363
7364 c------------------------------------------------------------------------------
7365       subroutine etor_d(etors_d)
7366       etors_d=0.0d0
7367       return
7368       end
7369 c----------------------------------------------------------------------------
7370 #else
7371       subroutine etor(etors)
7372       implicit real*8 (a-h,o-z)
7373       include 'DIMENSIONS'
7374       include 'COMMON.VAR'
7375       include 'COMMON.GEO'
7376       include 'COMMON.LOCAL'
7377       include 'COMMON.TORSION'
7378       include 'COMMON.INTERACT'
7379       include 'COMMON.DERIV'
7380       include 'COMMON.CHAIN'
7381       include 'COMMON.NAMES'
7382       include 'COMMON.IOUNITS'
7383       include 'COMMON.FFIELD'
7384       include 'COMMON.TORCNSTR'
7385       include 'COMMON.CONTROL'
7386       logical lprn
7387 C Set lprn=.true. for debugging
7388       lprn=.false.
7389 c     lprn=.true.
7390       etors=0.0D0
7391       do i=iphi_start,iphi_end
7392 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7393 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7394 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7395 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7396         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7397      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7398 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7399 C For introducing the NH3+ and COO- group please check the etor_d for reference
7400 C and guidance
7401         etors_ii=0.0D0
7402          if (iabs(itype(i)).eq.20) then
7403          iblock=2
7404          else
7405          iblock=1
7406          endif
7407         itori=itortyp(itype(i-2))
7408         itori1=itortyp(itype(i-1))
7409         phii=phi(i)
7410         gloci=0.0D0
7411 C Regular cosine and sine terms
7412         do j=1,nterm(itori,itori1,iblock)
7413           v1ij=v1(j,itori,itori1,iblock)
7414           v2ij=v2(j,itori,itori1,iblock)
7415           cosphi=dcos(j*phii)
7416           sinphi=dsin(j*phii)
7417           etors=etors+v1ij*cosphi+v2ij*sinphi
7418           if (energy_dec) etors_ii=etors_ii+
7419      &                v1ij*cosphi+v2ij*sinphi
7420           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7421         enddo
7422 C Lorentz terms
7423 C                         v1
7424 C  E = SUM ----------------------------------- - v1
7425 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7426 C
7427         cosphi=dcos(0.5d0*phii)
7428         sinphi=dsin(0.5d0*phii)
7429         do j=1,nlor(itori,itori1,iblock)
7430           vl1ij=vlor1(j,itori,itori1)
7431           vl2ij=vlor2(j,itori,itori1)
7432           vl3ij=vlor3(j,itori,itori1)
7433           pom=vl2ij*cosphi+vl3ij*sinphi
7434           pom1=1.0d0/(pom*pom+1.0d0)
7435           etors=etors+vl1ij*pom1
7436           if (energy_dec) etors_ii=etors_ii+
7437      &                vl1ij*pom1
7438           pom=-pom*pom1*pom1
7439           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7440         enddo
7441 C Subtract the constant term
7442         etors=etors-v0(itori,itori1,iblock)
7443           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7444      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7445         if (lprn)
7446      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7447      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7448      &  (v1(j,itori,itori1,iblock),j=1,6),
7449      &  (v2(j,itori,itori1,iblock),j=1,6)
7450         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7451 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7452       enddo
7453       return
7454       end
7455 c----------------------------------------------------------------------------
7456       subroutine etor_d(etors_d)
7457 C 6/23/01 Compute double torsional energy
7458       implicit real*8 (a-h,o-z)
7459       include 'DIMENSIONS'
7460       include 'COMMON.VAR'
7461       include 'COMMON.GEO'
7462       include 'COMMON.LOCAL'
7463       include 'COMMON.TORSION'
7464       include 'COMMON.INTERACT'
7465       include 'COMMON.DERIV'
7466       include 'COMMON.CHAIN'
7467       include 'COMMON.NAMES'
7468       include 'COMMON.IOUNITS'
7469       include 'COMMON.FFIELD'
7470       include 'COMMON.TORCNSTR'
7471       logical lprn
7472 C Set lprn=.true. for debugging
7473       lprn=.false.
7474 c     lprn=.true.
7475       etors_d=0.0D0
7476 c      write(iout,*) "a tu??"
7477       do i=iphid_start,iphid_end
7478 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7479 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7480 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7481 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7482 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7483          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7484      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7485      &  (itype(i+1).eq.ntyp1)) cycle
7486 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7487         itori=itortyp(itype(i-2))
7488         itori1=itortyp(itype(i-1))
7489         itori2=itortyp(itype(i))
7490         phii=phi(i)
7491         phii1=phi(i+1)
7492         gloci1=0.0D0
7493         gloci2=0.0D0
7494         iblock=1
7495         if (iabs(itype(i+1)).eq.20) iblock=2
7496 C Iblock=2 Proline type
7497 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7498 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7499 C        if (itype(i+1).eq.ntyp1) iblock=3
7500 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7501 C IS or IS NOT need for this
7502 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7503 C        is (itype(i-3).eq.ntyp1) ntblock=2
7504 C        ntblock is N-terminal blocking group
7505
7506 C Regular cosine and sine terms
7507         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7508 C Example of changes for NH3+ blocking group
7509 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7510 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7511           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7512           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7513           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7514           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7515           cosphi1=dcos(j*phii)
7516           sinphi1=dsin(j*phii)
7517           cosphi2=dcos(j*phii1)
7518           sinphi2=dsin(j*phii1)
7519           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7520      &     v2cij*cosphi2+v2sij*sinphi2
7521           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7522           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7523         enddo
7524         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7525           do l=1,k-1
7526             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7527             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7528             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7529             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7530             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7531             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7532             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7533             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7534             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7535      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7536             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7537      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7538             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7539      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7540           enddo
7541         enddo
7542         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7543         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7544       enddo
7545       return
7546       end
7547 #endif
7548 C----------------------------------------------------------------------------------
7549 C The rigorous attempt to derive energy function
7550       subroutine etor_kcc(etors)
7551       implicit real*8 (a-h,o-z)
7552       include 'DIMENSIONS'
7553       include 'COMMON.VAR'
7554       include 'COMMON.GEO'
7555       include 'COMMON.LOCAL'
7556       include 'COMMON.TORSION'
7557       include 'COMMON.INTERACT'
7558       include 'COMMON.DERIV'
7559       include 'COMMON.CHAIN'
7560       include 'COMMON.NAMES'
7561       include 'COMMON.IOUNITS'
7562       include 'COMMON.FFIELD'
7563       include 'COMMON.TORCNSTR'
7564       include 'COMMON.CONTROL'
7565       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7566       logical lprn
7567 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7568 C Set lprn=.true. for debugging
7569       lprn=energy_dec
7570 c     lprn=.true.
7571 C      print *,"wchodze kcc"
7572       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7573       etors=0.0D0
7574       do i=iphi_start,iphi_end
7575 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7576 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7577 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7578 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7579         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7580      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7581         itori=itortyp(itype(i-2))
7582         itori1=itortyp(itype(i-1))
7583         phii=phi(i)
7584         glocig=0.0D0
7585         glocit1=0.0d0
7586         glocit2=0.0d0
7587 C to avoid multiple devision by 2
7588 c        theti22=0.5d0*theta(i)
7589 C theta 12 is the theta_1 /2
7590 C theta 22 is theta_2 /2
7591 c        theti12=0.5d0*theta(i-1)
7592 C and appropriate sinus function
7593         sinthet1=dsin(theta(i-1))
7594         sinthet2=dsin(theta(i))
7595         costhet1=dcos(theta(i-1))
7596         costhet2=dcos(theta(i))
7597 C to speed up lets store its mutliplication
7598         sint1t2=sinthet2*sinthet1
7599         sint1t2n=1.0d0
7600 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7601 C +d_n*sin(n*gamma)) *
7602 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7603 C we have two sum 1) Non-Chebyshev which is with n and gamma
7604         nval=nterm_kcc_Tb(itori,itori1)
7605         c1(0)=0.0d0
7606         c2(0)=0.0d0
7607         c1(1)=1.0d0
7608         c2(1)=1.0d0
7609         do j=2,nval
7610           c1(j)=c1(j-1)*costhet1
7611           c2(j)=c2(j-1)*costhet2
7612         enddo
7613         etori=0.0d0
7614         do j=1,nterm_kcc(itori,itori1)
7615           cosphi=dcos(j*phii)
7616           sinphi=dsin(j*phii)
7617           sint1t2n1=sint1t2n
7618           sint1t2n=sint1t2n*sint1t2
7619           sumvalc=0.0d0
7620           gradvalct1=0.0d0
7621           gradvalct2=0.0d0
7622           do k=1,nval
7623             do l=1,nval
7624               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7625               gradvalct1=gradvalct1+
7626      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7627               gradvalct2=gradvalct2+
7628      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7629             enddo
7630           enddo
7631           gradvalct1=-gradvalct1*sinthet1
7632           gradvalct2=-gradvalct2*sinthet2
7633           sumvals=0.0d0
7634           gradvalst1=0.0d0
7635           gradvalst2=0.0d0
7636           do k=1,nval
7637             do l=1,nval
7638               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7639               gradvalst1=gradvalst1+
7640      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7641               gradvalst2=gradvalst2+
7642      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7643             enddo
7644           enddo
7645           gradvalst1=-gradvalst1*sinthet1
7646           gradvalst2=-gradvalst2*sinthet2
7647           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7648           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7649 C glocig is the gradient local i site in gamma
7650           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7651 C now gradient over theta_1
7652           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7653      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7654           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7655      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7656         enddo ! j
7657         etors=etors+etori
7658 C derivative over gamma
7659         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7660 C derivative over theta1
7661         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7662 C now derivative over theta2
7663         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7664         if (lprn) then
7665           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7666      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7667           write (iout,*) "c1",(c1(k),k=0,nval),
7668      &    " c2",(c2(k),k=0,nval)
7669         endif
7670       enddo
7671       return
7672       end
7673 c---------------------------------------------------------------------------------------------
7674       subroutine etor_constr(edihcnstr)
7675       implicit real*8 (a-h,o-z)
7676       include 'DIMENSIONS'
7677       include 'COMMON.VAR'
7678       include 'COMMON.GEO'
7679       include 'COMMON.LOCAL'
7680       include 'COMMON.TORSION'
7681       include 'COMMON.INTERACT'
7682       include 'COMMON.DERIV'
7683       include 'COMMON.CHAIN'
7684       include 'COMMON.NAMES'
7685       include 'COMMON.IOUNITS'
7686       include 'COMMON.FFIELD'
7687       include 'COMMON.TORCNSTR'
7688       include 'COMMON.BOUNDS'
7689       include 'COMMON.CONTROL'
7690 ! 6/20/98 - dihedral angle constraints
7691       edihcnstr=0.0d0
7692 c      do i=1,ndih_constr
7693       if (raw_psipred) then
7694         do i=idihconstr_start,idihconstr_end
7695           itori=idih_constr(i)
7696           phii=phi(itori)
7697           gaudih_i=vpsipred(1,i)
7698           gauder_i=0.0d0
7699           do j=1,2
7700             s = sdihed(j,i)
7701             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7702             dexpcos_i=dexp(-cos_i*cos_i)
7703             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7704             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7705      &            *cos_i*dexpcos_i/s**2
7706           enddo
7707           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7708           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7709           if (energy_dec)
7710      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7711      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7712      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7713      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7714      &     -wdihc*dlog(gaudih_i)
7715         enddo
7716       else
7717
7718       do i=idihconstr_start,idihconstr_end
7719         itori=idih_constr(i)
7720         phii=phi(itori)
7721         difi=pinorm(phii-phi0(i))
7722         if (difi.gt.drange(i)) then
7723           difi=difi-drange(i)
7724           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7725           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7726         else if (difi.lt.-drange(i)) then
7727           difi=difi+drange(i)
7728           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7729           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7730         else
7731           difi=0.0
7732         endif
7733       enddo
7734
7735       endif
7736
7737       return
7738       end
7739 c----------------------------------------------------------------------------
7740 c MODELLER restraint function
7741       subroutine e_modeller(ehomology_constr)
7742       implicit none
7743       include 'DIMENSIONS'
7744
7745       double precision ehomology_constr
7746       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7747       integer katy, odleglosci, test7
7748       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7749       real*8 Eval,Erot
7750       real*8 distance(max_template),distancek(max_template),
7751      &    min_odl,godl(max_template),dih_diff(max_template)
7752
7753 c
7754 c     FP - 30/10/2014 Temporary specifications for homology restraints
7755 c
7756       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7757      &                 sgtheta
7758       double precision, dimension (maxres) :: guscdiff,usc_diff
7759       double precision, dimension (max_template) ::
7760      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7761      &           theta_diff
7762       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7763      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7764      & betai,sum_sgodl,dij
7765       double precision dist,pinorm
7766 c
7767       include 'COMMON.SBRIDGE'
7768       include 'COMMON.CHAIN'
7769       include 'COMMON.GEO'
7770       include 'COMMON.DERIV'
7771       include 'COMMON.LOCAL'
7772       include 'COMMON.INTERACT'
7773       include 'COMMON.VAR'
7774       include 'COMMON.IOUNITS'
7775 c      include 'COMMON.MD'
7776       include 'COMMON.CONTROL'
7777       include 'COMMON.HOMOLOGY'
7778       include 'COMMON.QRESTR'
7779 c
7780 c     From subroutine Econstr_back
7781 c
7782       include 'COMMON.NAMES'
7783       include 'COMMON.TIME1'
7784 c
7785
7786
7787       do i=1,max_template
7788         distancek(i)=9999999.9
7789       enddo
7790
7791
7792       odleg=0.0d0
7793
7794 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7795 c function)
7796 C AL 5/2/14 - Introduce list of restraints
7797 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7798 #ifdef DEBUG
7799       write(iout,*) "------- dist restrs start -------"
7800 #endif
7801       do ii = link_start_homo,link_end_homo
7802          i = ires_homo(ii)
7803          j = jres_homo(ii)
7804          dij=dist(i,j)
7805 c        write (iout,*) "dij(",i,j,") =",dij
7806          nexl=0
7807          do k=1,constr_homology
7808 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7809            if(.not.l_homo(k,ii)) then
7810              nexl=nexl+1
7811              cycle
7812            endif
7813            distance(k)=odl(k,ii)-dij
7814 c          write (iout,*) "distance(",k,") =",distance(k)
7815 c
7816 c          For Gaussian-type Urestr
7817 c
7818            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7819 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7820 c          write (iout,*) "distancek(",k,") =",distancek(k)
7821 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7822 c
7823 c          For Lorentzian-type Urestr
7824 c
7825            if (waga_dist.lt.0.0d0) then
7826               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7827               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7828      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7829            endif
7830          enddo
7831
7832 c         min_odl=minval(distancek)
7833          if (nexl.gt.0) then
7834            min_odl=0.0d0
7835          else
7836            do kk=1,constr_homology
7837             if(l_homo(kk,ii)) then
7838               min_odl=distancek(kk)
7839               exit
7840             endif
7841            enddo
7842            do kk=1,constr_homology
7843             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7844      &              min_odl=distancek(kk)
7845            enddo
7846          endif
7847
7848 c        write (iout,* )"min_odl",min_odl
7849 #ifdef DEBUG
7850          write (iout,*) "ij dij",i,j,dij
7851          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7852          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7853          write (iout,* )"min_odl",min_odl
7854 #endif
7855 #ifdef OLDRESTR
7856          odleg2=0.0d0
7857 #else
7858          if (waga_dist.ge.0.0d0) then
7859            odleg2=nexl
7860          else
7861            odleg2=0.0d0
7862          endif
7863 #endif
7864          do k=1,constr_homology
7865 c Nie wiem po co to liczycie jeszcze raz!
7866 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7867 c     &              (2*(sigma_odl(i,j,k))**2))
7868            if(.not.l_homo(k,ii)) cycle
7869            if (waga_dist.ge.0.0d0) then
7870 c
7871 c          For Gaussian-type Urestr
7872 c
7873             godl(k)=dexp(-distancek(k)+min_odl)
7874             odleg2=odleg2+godl(k)
7875 c
7876 c          For Lorentzian-type Urestr
7877 c
7878            else
7879             odleg2=odleg2+distancek(k)
7880            endif
7881
7882 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7883 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7884 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7885 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7886
7887          enddo
7888 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7889 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7890 #ifdef DEBUG
7891          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7892          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7893 #endif
7894            if (waga_dist.ge.0.0d0) then
7895 c
7896 c          For Gaussian-type Urestr
7897 c
7898               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7899 c
7900 c          For Lorentzian-type Urestr
7901 c
7902            else
7903               odleg=odleg+odleg2/constr_homology
7904            endif
7905 c
7906 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7907 c Gradient
7908 c
7909 c          For Gaussian-type Urestr
7910 c
7911          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7912          sum_sgodl=0.0d0
7913          do k=1,constr_homology
7914 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7915 c     &           *waga_dist)+min_odl
7916 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7917 c
7918          if(.not.l_homo(k,ii)) cycle
7919          if (waga_dist.ge.0.0d0) then
7920 c          For Gaussian-type Urestr
7921 c
7922            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7923 c
7924 c          For Lorentzian-type Urestr
7925 c
7926          else
7927            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7928      &           sigma_odlir(k,ii)**2)**2)
7929          endif
7930            sum_sgodl=sum_sgodl+sgodl
7931
7932 c            sgodl2=sgodl2+sgodl
7933 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7934 c      write(iout,*) "constr_homology=",constr_homology
7935 c      write(iout,*) i, j, k, "TEST K"
7936          enddo
7937          if (waga_dist.ge.0.0d0) then
7938 c
7939 c          For Gaussian-type Urestr
7940 c
7941             grad_odl3=waga_homology(iset)*waga_dist
7942      &                *sum_sgodl/(sum_godl*dij)
7943 c
7944 c          For Lorentzian-type Urestr
7945 c
7946          else
7947 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7948 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7949             grad_odl3=-waga_homology(iset)*waga_dist*
7950      &                sum_sgodl/(constr_homology*dij)
7951          endif
7952 c
7953 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7954
7955
7956 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7957 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7958 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7959
7960 ccc      write(iout,*) godl, sgodl, grad_odl3
7961
7962 c          grad_odl=grad_odl+grad_odl3
7963
7964          do jik=1,3
7965             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7966 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7967 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7968 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7969             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7970             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7971 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7972 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7973 c         if (i.eq.25.and.j.eq.27) then
7974 c         write(iout,*) "jik",jik,"i",i,"j",j
7975 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7976 c         write(iout,*) "grad_odl3",grad_odl3
7977 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7978 c         write(iout,*) "ggodl",ggodl
7979 c         write(iout,*) "ghpbc(",jik,i,")",
7980 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7981 c     &                 ghpbc(jik,j)
7982 c         endif
7983          enddo
7984 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7985 ccc     & dLOG(odleg2),"-odleg=", -odleg
7986
7987       enddo ! ii-loop for dist
7988 #ifdef DEBUG
7989       write(iout,*) "------- dist restrs end -------"
7990 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7991 c    &     waga_d.eq.1.0d0) call sum_gradient
7992 #endif
7993 c Pseudo-energy and gradient from dihedral-angle restraints from
7994 c homology templates
7995 c      write (iout,*) "End of distance loop"
7996 c      call flush(iout)
7997       kat=0.0d0
7998 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7999 #ifdef DEBUG
8000       write(iout,*) "------- dih restrs start -------"
8001       do i=idihconstr_start_homo,idihconstr_end_homo
8002         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8003       enddo
8004 #endif
8005       do i=idihconstr_start_homo,idihconstr_end_homo
8006         kat2=0.0d0
8007 c        betai=beta(i,i+1,i+2,i+3)
8008         betai = phi(i)
8009 c       write (iout,*) "betai =",betai
8010         do k=1,constr_homology
8011           dih_diff(k)=pinorm(dih(k,i)-betai)
8012 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8013 cd     &                  ,sigma_dih(k,i)
8014 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8015 c     &                                   -(6.28318-dih_diff(i,k))
8016 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8017 c     &                                   6.28318+dih_diff(i,k)
8018 #ifdef OLD_DIHED
8019           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8020 #else
8021           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8022 #endif
8023 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8024           gdih(k)=dexp(kat3)
8025           kat2=kat2+gdih(k)
8026 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8027 c          write(*,*)""
8028         enddo
8029 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8030 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8031 #ifdef DEBUG
8032         write (iout,*) "i",i," betai",betai," kat2",kat2
8033         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8034 #endif
8035         if (kat2.le.1.0d-14) cycle
8036         kat=kat-dLOG(kat2/constr_homology)
8037 c       write (iout,*) "kat",kat ! sum of -ln-s
8038
8039 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8040 ccc     & dLOG(kat2), "-kat=", -kat
8041
8042 c ----------------------------------------------------------------------
8043 c Gradient
8044 c ----------------------------------------------------------------------
8045
8046         sum_gdih=kat2
8047         sum_sgdih=0.0d0
8048         do k=1,constr_homology
8049 #ifdef OLD_DIHED
8050           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8051 #else
8052           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8053 #endif
8054 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8055           sum_sgdih=sum_sgdih+sgdih
8056         enddo
8057 c       grad_dih3=sum_sgdih/sum_gdih
8058         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8059
8060 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8061 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8062 ccc     & gloc(nphi+i-3,icg)
8063         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8064 c        if (i.eq.25) then
8065 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8066 c        endif
8067 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8068 ccc     & gloc(nphi+i-3,icg)
8069
8070       enddo ! i-loop for dih
8071 #ifdef DEBUG
8072       write(iout,*) "------- dih restrs end -------"
8073 #endif
8074
8075 c Pseudo-energy and gradient for theta angle restraints from
8076 c homology templates
8077 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8078 c adapted
8079
8080 c
8081 c     For constr_homology reference structures (FP)
8082 c
8083 c     Uconst_back_tot=0.0d0
8084       Eval=0.0d0
8085       Erot=0.0d0
8086 c     Econstr_back legacy
8087       do i=1,nres
8088 c     do i=ithet_start,ithet_end
8089        dutheta(i)=0.0d0
8090 c     enddo
8091 c     do i=loc_start,loc_end
8092         do j=1,3
8093           duscdiff(j,i)=0.0d0
8094           duscdiffx(j,i)=0.0d0
8095         enddo
8096       enddo
8097 c
8098 c     do iref=1,nref
8099 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8100 c     write (iout,*) "waga_theta",waga_theta
8101       if (waga_theta.gt.0.0d0) then
8102 #ifdef DEBUG
8103       write (iout,*) "usampl",usampl
8104       write(iout,*) "------- theta restrs start -------"
8105 c     do i=ithet_start,ithet_end
8106 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8107 c     enddo
8108 #endif
8109 c     write (iout,*) "maxres",maxres,"nres",nres
8110
8111       do i=ithet_start,ithet_end
8112 c
8113 c     do i=1,nfrag_back
8114 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8115 c
8116 c Deviation of theta angles wrt constr_homology ref structures
8117 c
8118         utheta_i=0.0d0 ! argument of Gaussian for single k
8119         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8120 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8121 c       over residues in a fragment
8122 c       write (iout,*) "theta(",i,")=",theta(i)
8123         do k=1,constr_homology
8124 c
8125 c         dtheta_i=theta(j)-thetaref(j,iref)
8126 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8127           theta_diff(k)=thetatpl(k,i)-theta(i)
8128 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8129 cd     &                  ,sigma_theta(k,i)
8130
8131 c
8132           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8133 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8134           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8135           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8136 c         Gradient for single Gaussian restraint in subr Econstr_back
8137 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8138 c
8139         enddo
8140 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8141 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8142
8143 c
8144 c         Gradient for multiple Gaussian restraint
8145         sum_gtheta=gutheta_i
8146         sum_sgtheta=0.0d0
8147         do k=1,constr_homology
8148 c        New generalized expr for multiple Gaussian from Econstr_back
8149          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8150 c
8151 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8152           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8153         enddo
8154 c       Final value of gradient using same var as in Econstr_back
8155         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8156      &      +sum_sgtheta/sum_gtheta*waga_theta
8157      &               *waga_homology(iset)
8158 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8159 c     &               *waga_homology(iset)
8160 c       dutheta(i)=sum_sgtheta/sum_gtheta
8161 c
8162 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8163         Eval=Eval-dLOG(gutheta_i/constr_homology)
8164 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8165 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8166 c       Uconst_back=Uconst_back+utheta(i)
8167       enddo ! (i-loop for theta)
8168 #ifdef DEBUG
8169       write(iout,*) "------- theta restrs end -------"
8170 #endif
8171       endif
8172 c
8173 c Deviation of local SC geometry
8174 c
8175 c Separation of two i-loops (instructed by AL - 11/3/2014)
8176 c
8177 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8178 c     write (iout,*) "waga_d",waga_d
8179
8180 #ifdef DEBUG
8181       write(iout,*) "------- SC restrs start -------"
8182       write (iout,*) "Initial duscdiff,duscdiffx"
8183       do i=loc_start,loc_end
8184         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8185      &                 (duscdiffx(jik,i),jik=1,3)
8186       enddo
8187 #endif
8188       do i=loc_start,loc_end
8189         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8190         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8191 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8192 c       write(iout,*) "xxtab, yytab, zztab"
8193 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8194         do k=1,constr_homology
8195 c
8196           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8197 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8198           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8199           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8200 c         write(iout,*) "dxx, dyy, dzz"
8201 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8202 c
8203           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8204 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8205 c         uscdiffk(k)=usc_diff(i)
8206           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8207 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8208 c     &       " guscdiff2",guscdiff2(k)
8209           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8210 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8211 c     &      xxref(j),yyref(j),zzref(j)
8212         enddo
8213 c
8214 c       Gradient
8215 c
8216 c       Generalized expression for multiple Gaussian acc to that for a single
8217 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8218 c
8219 c       Original implementation
8220 c       sum_guscdiff=guscdiff(i)
8221 c
8222 c       sum_sguscdiff=0.0d0
8223 c       do k=1,constr_homology
8224 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8225 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8226 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8227 c       enddo
8228 c
8229 c       Implementation of new expressions for gradient (Jan. 2015)
8230 c
8231 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8232         do k=1,constr_homology
8233 c
8234 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8235 c       before. Now the drivatives should be correct
8236 c
8237           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8238 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8239           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8240           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8241 c
8242 c         New implementation
8243 c
8244           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8245      &                 sigma_d(k,i) ! for the grad wrt r'
8246 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8247 c
8248 c
8249 c        New implementation
8250          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8251          do jik=1,3
8252             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8253      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8254      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8255             duscdiff(jik,i)=duscdiff(jik,i)+
8256      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8257      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8258             duscdiffx(jik,i)=duscdiffx(jik,i)+
8259      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8260      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8261 c
8262 #ifdef DEBUG
8263              write(iout,*) "jik",jik,"i",i
8264              write(iout,*) "dxx, dyy, dzz"
8265              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8266              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8267 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8268 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8269 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8270 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8271 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8272 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8273 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8274 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8275 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8276 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8277 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8278 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8279 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8280 c            endif
8281 #endif
8282          enddo
8283         enddo
8284 c
8285 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8286 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8287 c
8288 c        write (iout,*) i," uscdiff",uscdiff(i)
8289 c
8290 c Put together deviations from local geometry
8291
8292 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8293 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8294         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8295 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8296 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8297 c       Uconst_back=Uconst_back+usc_diff(i)
8298 c
8299 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8300 c
8301 c     New implment: multiplied by sum_sguscdiff
8302 c
8303
8304       enddo ! (i-loop for dscdiff)
8305
8306 c      endif
8307
8308 #ifdef DEBUG
8309       write(iout,*) "------- SC restrs end -------"
8310         write (iout,*) "------ After SC loop in e_modeller ------"
8311         do i=loc_start,loc_end
8312          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8313          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8314         enddo
8315       if (waga_theta.eq.1.0d0) then
8316       write (iout,*) "in e_modeller after SC restr end: dutheta"
8317       do i=ithet_start,ithet_end
8318         write (iout,*) i,dutheta(i)
8319       enddo
8320       endif
8321       if (waga_d.eq.1.0d0) then
8322       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8323       do i=1,nres
8324         write (iout,*) i,(duscdiff(j,i),j=1,3)
8325         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8326       enddo
8327       endif
8328 #endif
8329
8330 c Total energy from homology restraints
8331 #ifdef DEBUG
8332       write (iout,*) "odleg",odleg," kat",kat
8333 #endif
8334 c
8335 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8336 c
8337 c     ehomology_constr=odleg+kat
8338 c
8339 c     For Lorentzian-type Urestr
8340 c
8341
8342       if (waga_dist.ge.0.0d0) then
8343 c
8344 c          For Gaussian-type Urestr
8345 c
8346         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8347      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8348 c     write (iout,*) "ehomology_constr=",ehomology_constr
8349       else
8350 c
8351 c          For Lorentzian-type Urestr
8352 c
8353         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8354      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8355 c     write (iout,*) "ehomology_constr=",ehomology_constr
8356       endif
8357 #ifdef DEBUG
8358       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8359      & "Eval",waga_theta,eval,
8360      &   "Erot",waga_d,Erot
8361       write (iout,*) "ehomology_constr",ehomology_constr
8362 #endif
8363       return
8364 c
8365 c FP 01/15 end
8366 c
8367   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8368   747 format(a12,i4,i4,i4,f8.3,f8.3)
8369   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8370   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8371   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8372      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8373       end
8374 c----------------------------------------------------------------------------
8375 C The rigorous attempt to derive energy function
8376       subroutine ebend_kcc(etheta)
8377
8378       implicit real*8 (a-h,o-z)
8379       include 'DIMENSIONS'
8380       include 'COMMON.VAR'
8381       include 'COMMON.GEO'
8382       include 'COMMON.LOCAL'
8383       include 'COMMON.TORSION'
8384       include 'COMMON.INTERACT'
8385       include 'COMMON.DERIV'
8386       include 'COMMON.CHAIN'
8387       include 'COMMON.NAMES'
8388       include 'COMMON.IOUNITS'
8389       include 'COMMON.FFIELD'
8390       include 'COMMON.TORCNSTR'
8391       include 'COMMON.CONTROL'
8392       logical lprn
8393       double precision thybt1(maxang_kcc)
8394 C Set lprn=.true. for debugging
8395       lprn=energy_dec
8396 c     lprn=.true.
8397 C      print *,"wchodze kcc"
8398       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8399       etheta=0.0D0
8400       do i=ithet_start,ithet_end
8401 c        print *,i,itype(i-1),itype(i),itype(i-2)
8402         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8403      &  .or.itype(i).eq.ntyp1) cycle
8404         iti=iabs(itortyp(itype(i-1)))
8405         sinthet=dsin(theta(i))
8406         costhet=dcos(theta(i))
8407         do j=1,nbend_kcc_Tb(iti)
8408           thybt1(j)=v1bend_chyb(j,iti)
8409         enddo
8410         sumth1thyb=v1bend_chyb(0,iti)+
8411      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8412         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8413      &    sumth1thyb
8414         ihelp=nbend_kcc_Tb(iti)-1
8415         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8416         etheta=etheta+sumth1thyb
8417 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8418         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8419       enddo
8420       return
8421       end
8422 c-------------------------------------------------------------------------------------
8423       subroutine etheta_constr(ethetacnstr)
8424
8425       implicit real*8 (a-h,o-z)
8426       include 'DIMENSIONS'
8427       include 'COMMON.VAR'
8428       include 'COMMON.GEO'
8429       include 'COMMON.LOCAL'
8430       include 'COMMON.TORSION'
8431       include 'COMMON.INTERACT'
8432       include 'COMMON.DERIV'
8433       include 'COMMON.CHAIN'
8434       include 'COMMON.NAMES'
8435       include 'COMMON.IOUNITS'
8436       include 'COMMON.FFIELD'
8437       include 'COMMON.TORCNSTR'
8438       include 'COMMON.CONTROL'
8439       ethetacnstr=0.0d0
8440 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8441       do i=ithetaconstr_start,ithetaconstr_end
8442         itheta=itheta_constr(i)
8443         thetiii=theta(itheta)
8444         difi=pinorm(thetiii-theta_constr0(i))
8445         if (difi.gt.theta_drange(i)) then
8446           difi=difi-theta_drange(i)
8447           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8448           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8449      &    +for_thet_constr(i)*difi**3
8450         else if (difi.lt.-drange(i)) then
8451           difi=difi+drange(i)
8452           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8453           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8454      &    +for_thet_constr(i)*difi**3
8455         else
8456           difi=0.0
8457         endif
8458        if (energy_dec) then
8459         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8460      &    i,itheta,rad2deg*thetiii,
8461      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8462      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8463      &    gloc(itheta+nphi-2,icg)
8464         endif
8465       enddo
8466       return
8467       end
8468 c------------------------------------------------------------------------------
8469       subroutine eback_sc_corr(esccor)
8470 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8471 c        conformational states; temporarily implemented as differences
8472 c        between UNRES torsional potentials (dependent on three types of
8473 c        residues) and the torsional potentials dependent on all 20 types
8474 c        of residues computed from AM1  energy surfaces of terminally-blocked
8475 c        amino-acid residues.
8476       implicit real*8 (a-h,o-z)
8477       include 'DIMENSIONS'
8478       include 'COMMON.VAR'
8479       include 'COMMON.GEO'
8480       include 'COMMON.LOCAL'
8481       include 'COMMON.TORSION'
8482       include 'COMMON.SCCOR'
8483       include 'COMMON.INTERACT'
8484       include 'COMMON.DERIV'
8485       include 'COMMON.CHAIN'
8486       include 'COMMON.NAMES'
8487       include 'COMMON.IOUNITS'
8488       include 'COMMON.FFIELD'
8489       include 'COMMON.CONTROL'
8490       logical lprn
8491 C Set lprn=.true. for debugging
8492       lprn=.false.
8493 c      lprn=.true.
8494 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8495       esccor=0.0D0
8496       do i=itau_start,itau_end
8497         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8498         esccor_ii=0.0D0
8499         isccori=isccortyp(itype(i-2))
8500         isccori1=isccortyp(itype(i-1))
8501 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8502         phii=phi(i)
8503         do intertyp=1,3 !intertyp
8504 cc Added 09 May 2012 (Adasko)
8505 cc  Intertyp means interaction type of backbone mainchain correlation:
8506 c   1 = SC...Ca...Ca...Ca
8507 c   2 = Ca...Ca...Ca...SC
8508 c   3 = SC...Ca...Ca...SCi
8509         gloci=0.0D0
8510         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8511      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8512      &      (itype(i-1).eq.ntyp1)))
8513      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8514      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8515      &     .or.(itype(i).eq.ntyp1)))
8516      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8517      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8518      &      (itype(i-3).eq.ntyp1)))) cycle
8519         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8520         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8521      & cycle
8522        do j=1,nterm_sccor(isccori,isccori1)
8523           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8524           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8525           cosphi=dcos(j*tauangle(intertyp,i))
8526           sinphi=dsin(j*tauangle(intertyp,i))
8527           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8528           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8529         enddo
8530 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8531         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8532         if (lprn)
8533      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8534      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8535      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8536      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8537         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8538        enddo !intertyp
8539       enddo
8540
8541       return
8542       end
8543 #ifdef FOURBODY
8544 c----------------------------------------------------------------------------
8545       subroutine multibody(ecorr)
8546 C This subroutine calculates multi-body contributions to energy following
8547 C the idea of Skolnick et al. If side chains I and J make a contact and
8548 C at the same time side chains I+1 and J+1 make a contact, an extra
8549 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8550       implicit real*8 (a-h,o-z)
8551       include 'DIMENSIONS'
8552       include 'COMMON.IOUNITS'
8553       include 'COMMON.DERIV'
8554       include 'COMMON.INTERACT'
8555       include 'COMMON.CONTACTS'
8556       include 'COMMON.CONTMAT'
8557       include 'COMMON.CORRMAT'
8558       double precision gx(3),gx1(3)
8559       logical lprn
8560
8561 C Set lprn=.true. for debugging
8562       lprn=.false.
8563
8564       if (lprn) then
8565         write (iout,'(a)') 'Contact function values:'
8566         do i=nnt,nct-2
8567           write (iout,'(i2,20(1x,i2,f10.5))')
8568      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8569         enddo
8570       endif
8571       ecorr=0.0D0
8572       do i=nnt,nct
8573         do j=1,3
8574           gradcorr(j,i)=0.0D0
8575           gradxorr(j,i)=0.0D0
8576         enddo
8577       enddo
8578       do i=nnt,nct-2
8579
8580         DO ISHIFT = 3,4
8581
8582         i1=i+ishift
8583         num_conti=num_cont(i)
8584         num_conti1=num_cont(i1)
8585         do jj=1,num_conti
8586           j=jcont(jj,i)
8587           do kk=1,num_conti1
8588             j1=jcont(kk,i1)
8589             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8590 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8591 cd   &                   ' ishift=',ishift
8592 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8593 C The system gains extra energy.
8594               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8595             endif   ! j1==j+-ishift
8596           enddo     ! kk
8597         enddo       ! jj
8598
8599         ENDDO ! ISHIFT
8600
8601       enddo         ! i
8602       return
8603       end
8604 c------------------------------------------------------------------------------
8605       double precision function esccorr(i,j,k,l,jj,kk)
8606       implicit real*8 (a-h,o-z)
8607       include 'DIMENSIONS'
8608       include 'COMMON.IOUNITS'
8609       include 'COMMON.DERIV'
8610       include 'COMMON.INTERACT'
8611       include 'COMMON.CONTACTS'
8612       include 'COMMON.CONTMAT'
8613       include 'COMMON.CORRMAT'
8614       include 'COMMON.SHIELD'
8615       double precision gx(3),gx1(3)
8616       logical lprn
8617       lprn=.false.
8618       eij=facont(jj,i)
8619       ekl=facont(kk,k)
8620 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8621 C Calculate the multi-body contribution to energy.
8622 C Calculate multi-body contributions to the gradient.
8623 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8624 cd   & k,l,(gacont(m,kk,k),m=1,3)
8625       do m=1,3
8626         gx(m) =ekl*gacont(m,jj,i)
8627         gx1(m)=eij*gacont(m,kk,k)
8628         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8629         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8630         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8631         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8632       enddo
8633       do m=i,j-1
8634         do ll=1,3
8635           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8636         enddo
8637       enddo
8638       do m=k,l-1
8639         do ll=1,3
8640           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8641         enddo
8642       enddo
8643       esccorr=-eij*ekl
8644       return
8645       end
8646 c------------------------------------------------------------------------------
8647       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8648 C This subroutine calculates multi-body contributions to hydrogen-bonding
8649       implicit real*8 (a-h,o-z)
8650       include 'DIMENSIONS'
8651       include 'COMMON.IOUNITS'
8652 #ifdef MPI
8653       include "mpif.h"
8654       parameter (max_cont=maxconts)
8655       parameter (max_dim=26)
8656       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8657       double precision zapas(max_dim,maxconts,max_fg_procs),
8658      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8659       common /przechowalnia/ zapas
8660       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8661      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8662 #endif
8663       include 'COMMON.SETUP'
8664       include 'COMMON.FFIELD'
8665       include 'COMMON.DERIV'
8666       include 'COMMON.INTERACT'
8667       include 'COMMON.CONTACTS'
8668       include 'COMMON.CONTMAT'
8669       include 'COMMON.CORRMAT'
8670       include 'COMMON.CONTROL'
8671       include 'COMMON.LOCAL'
8672       double precision gx(3),gx1(3),time00
8673       logical lprn,ldone
8674
8675 C Set lprn=.true. for debugging
8676       lprn=.false.
8677 #ifdef MPI
8678       n_corr=0
8679       n_corr1=0
8680       if (nfgtasks.le.1) goto 30
8681       if (lprn) then
8682         write (iout,'(a)') 'Contact function values before RECEIVE:'
8683         do i=nnt,nct-2
8684           write (iout,'(2i3,50(1x,i2,f5.2))')
8685      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8686      &    j=1,num_cont_hb(i))
8687         enddo
8688         call flush(iout)
8689       endif
8690       do i=1,ntask_cont_from
8691         ncont_recv(i)=0
8692       enddo
8693       do i=1,ntask_cont_to
8694         ncont_sent(i)=0
8695       enddo
8696 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8697 c     & ntask_cont_to
8698 C Make the list of contacts to send to send to other procesors
8699 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8700 c      call flush(iout)
8701       do i=iturn3_start,iturn3_end
8702 c        write (iout,*) "make contact list turn3",i," num_cont",
8703 c     &    num_cont_hb(i)
8704         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8705       enddo
8706       do i=iturn4_start,iturn4_end
8707 c        write (iout,*) "make contact list turn4",i," num_cont",
8708 c     &   num_cont_hb(i)
8709         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8710       enddo
8711       do ii=1,nat_sent
8712         i=iat_sent(ii)
8713 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8714 c     &    num_cont_hb(i)
8715         do j=1,num_cont_hb(i)
8716         do k=1,4
8717           jjc=jcont_hb(j,i)
8718           iproc=iint_sent_local(k,jjc,ii)
8719 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8720           if (iproc.gt.0) then
8721             ncont_sent(iproc)=ncont_sent(iproc)+1
8722             nn=ncont_sent(iproc)
8723             zapas(1,nn,iproc)=i
8724             zapas(2,nn,iproc)=jjc
8725             zapas(3,nn,iproc)=facont_hb(j,i)
8726             zapas(4,nn,iproc)=ees0p(j,i)
8727             zapas(5,nn,iproc)=ees0m(j,i)
8728             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8729             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8730             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8731             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8732             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8733             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8734             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8735             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8736             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8737             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8738             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8739             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8740             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8741             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8742             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8743             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8744             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8745             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8746             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8747             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8748             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8749           endif
8750         enddo
8751         enddo
8752       enddo
8753       if (lprn) then
8754       write (iout,*)
8755      &  "Numbers of contacts to be sent to other processors",
8756      &  (ncont_sent(i),i=1,ntask_cont_to)
8757       write (iout,*) "Contacts sent"
8758       do ii=1,ntask_cont_to
8759         nn=ncont_sent(ii)
8760         iproc=itask_cont_to(ii)
8761         write (iout,*) nn," contacts to processor",iproc,
8762      &   " of CONT_TO_COMM group"
8763         do i=1,nn
8764           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8765         enddo
8766       enddo
8767       call flush(iout)
8768       endif
8769       CorrelType=477
8770       CorrelID=fg_rank+1
8771       CorrelType1=478
8772       CorrelID1=nfgtasks+fg_rank+1
8773       ireq=0
8774 C Receive the numbers of needed contacts from other processors
8775       do ii=1,ntask_cont_from
8776         iproc=itask_cont_from(ii)
8777         ireq=ireq+1
8778         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8779      &    FG_COMM,req(ireq),IERR)
8780       enddo
8781 c      write (iout,*) "IRECV ended"
8782 c      call flush(iout)
8783 C Send the number of contacts needed by other processors
8784       do ii=1,ntask_cont_to
8785         iproc=itask_cont_to(ii)
8786         ireq=ireq+1
8787         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8788      &    FG_COMM,req(ireq),IERR)
8789       enddo
8790 c      write (iout,*) "ISEND ended"
8791 c      write (iout,*) "number of requests (nn)",ireq
8792 c      call flush(iout)
8793       if (ireq.gt.0)
8794      &  call MPI_Waitall(ireq,req,status_array,ierr)
8795 c      write (iout,*)
8796 c     &  "Numbers of contacts to be received from other processors",
8797 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8798 c      call flush(iout)
8799 C Receive contacts
8800       ireq=0
8801       do ii=1,ntask_cont_from
8802         iproc=itask_cont_from(ii)
8803         nn=ncont_recv(ii)
8804 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8805 c     &   " of CONT_TO_COMM group"
8806 c        call flush(iout)
8807         if (nn.gt.0) then
8808           ireq=ireq+1
8809           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8810      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8811 c          write (iout,*) "ireq,req",ireq,req(ireq)
8812         endif
8813       enddo
8814 C Send the contacts to processors that need them
8815       do ii=1,ntask_cont_to
8816         iproc=itask_cont_to(ii)
8817         nn=ncont_sent(ii)
8818 c        write (iout,*) nn," contacts to processor",iproc,
8819 c     &   " of CONT_TO_COMM group"
8820         if (nn.gt.0) then
8821           ireq=ireq+1
8822           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8823      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8824 c          write (iout,*) "ireq,req",ireq,req(ireq)
8825 c          do i=1,nn
8826 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8827 c          enddo
8828         endif
8829       enddo
8830 c      write (iout,*) "number of requests (contacts)",ireq
8831 c      write (iout,*) "req",(req(i),i=1,4)
8832 c      call flush(iout)
8833       if (ireq.gt.0)
8834      & call MPI_Waitall(ireq,req,status_array,ierr)
8835       do iii=1,ntask_cont_from
8836         iproc=itask_cont_from(iii)
8837         nn=ncont_recv(iii)
8838         if (lprn) then
8839         write (iout,*) "Received",nn," contacts from processor",iproc,
8840      &   " of CONT_FROM_COMM group"
8841         call flush(iout)
8842         do i=1,nn
8843           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8844         enddo
8845         call flush(iout)
8846         endif
8847         do i=1,nn
8848           ii=zapas_recv(1,i,iii)
8849 c Flag the received contacts to prevent double-counting
8850           jj=-zapas_recv(2,i,iii)
8851 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8852 c          call flush(iout)
8853           nnn=num_cont_hb(ii)+1
8854           num_cont_hb(ii)=nnn
8855           jcont_hb(nnn,ii)=jj
8856           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8857           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8858           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8859           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8860           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8861           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8862           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8863           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8864           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8865           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8866           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8867           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8868           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8869           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8870           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8871           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8872           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8873           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8874           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8875           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8876           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8877           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8878           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8879           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8880         enddo
8881       enddo
8882       if (lprn) then
8883         write (iout,'(a)') 'Contact function values after receive:'
8884         do i=nnt,nct-2
8885           write (iout,'(2i3,50(1x,i3,f5.2))')
8886      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8887      &    j=1,num_cont_hb(i))
8888         enddo
8889         call flush(iout)
8890       endif
8891    30 continue
8892 #endif
8893       if (lprn) then
8894         write (iout,'(a)') 'Contact function values:'
8895         do i=nnt,nct-2
8896           write (iout,'(2i3,50(1x,i3,f5.2))')
8897      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8898      &    j=1,num_cont_hb(i))
8899         enddo
8900         call flush(iout)
8901       endif
8902       ecorr=0.0D0
8903 C Remove the loop below after debugging !!!
8904       do i=nnt,nct
8905         do j=1,3
8906           gradcorr(j,i)=0.0D0
8907           gradxorr(j,i)=0.0D0
8908         enddo
8909       enddo
8910 C Calculate the local-electrostatic correlation terms
8911       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8912         i1=i+1
8913         num_conti=num_cont_hb(i)
8914         num_conti1=num_cont_hb(i+1)
8915         do jj=1,num_conti
8916           j=jcont_hb(jj,i)
8917           jp=iabs(j)
8918           do kk=1,num_conti1
8919             j1=jcont_hb(kk,i1)
8920             jp1=iabs(j1)
8921 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8922 c     &         ' jj=',jj,' kk=',kk
8923 c            call flush(iout)
8924             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8925      &          .or. j.lt.0 .and. j1.gt.0) .and.
8926      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8927 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8928 C The system gains extra energy.
8929               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8930               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8931      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8932               n_corr=n_corr+1
8933             else if (j1.eq.j) then
8934 C Contacts I-J and I-(J+1) occur simultaneously.
8935 C The system loses extra energy.
8936 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8937             endif
8938           enddo ! kk
8939           do kk=1,num_conti
8940             j1=jcont_hb(kk,i)
8941 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8942 c    &         ' jj=',jj,' kk=',kk
8943             if (j1.eq.j+1) then
8944 C Contacts I-J and (I+1)-J occur simultaneously.
8945 C The system loses extra energy.
8946 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8947             endif ! j1==j+1
8948           enddo ! kk
8949         enddo ! jj
8950       enddo ! i
8951       return
8952       end
8953 c------------------------------------------------------------------------------
8954       subroutine add_hb_contact(ii,jj,itask)
8955       implicit real*8 (a-h,o-z)
8956       include "DIMENSIONS"
8957       include "COMMON.IOUNITS"
8958       integer max_cont
8959       integer max_dim
8960       parameter (max_cont=maxconts)
8961       parameter (max_dim=26)
8962       include "COMMON.CONTACTS"
8963       include 'COMMON.CONTMAT'
8964       include 'COMMON.CORRMAT'
8965       double precision zapas(max_dim,maxconts,max_fg_procs),
8966      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8967       common /przechowalnia/ zapas
8968       integer i,j,ii,jj,iproc,itask(4),nn
8969 c      write (iout,*) "itask",itask
8970       do i=1,2
8971         iproc=itask(i)
8972         if (iproc.gt.0) then
8973           do j=1,num_cont_hb(ii)
8974             jjc=jcont_hb(j,ii)
8975 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8976             if (jjc.eq.jj) then
8977               ncont_sent(iproc)=ncont_sent(iproc)+1
8978               nn=ncont_sent(iproc)
8979               zapas(1,nn,iproc)=ii
8980               zapas(2,nn,iproc)=jjc
8981               zapas(3,nn,iproc)=facont_hb(j,ii)
8982               zapas(4,nn,iproc)=ees0p(j,ii)
8983               zapas(5,nn,iproc)=ees0m(j,ii)
8984               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8985               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8986               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8987               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8988               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8989               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8990               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8991               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8992               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8993               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8994               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8995               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8996               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8997               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8998               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8999               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9000               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9001               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9002               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9003               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9004               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9005               exit
9006             endif
9007           enddo
9008         endif
9009       enddo
9010       return
9011       end
9012 c------------------------------------------------------------------------------
9013       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9014      &  n_corr1)
9015 C This subroutine calculates multi-body contributions to hydrogen-bonding
9016       implicit real*8 (a-h,o-z)
9017       include 'DIMENSIONS'
9018       include 'COMMON.IOUNITS'
9019 #ifdef MPI
9020       include "mpif.h"
9021       parameter (max_cont=maxconts)
9022       parameter (max_dim=70)
9023       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9024       double precision zapas(max_dim,maxconts,max_fg_procs),
9025      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9026       common /przechowalnia/ zapas
9027       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9028      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9029 #endif
9030       include 'COMMON.SETUP'
9031       include 'COMMON.FFIELD'
9032       include 'COMMON.DERIV'
9033       include 'COMMON.LOCAL'
9034       include 'COMMON.INTERACT'
9035       include 'COMMON.CONTACTS'
9036       include 'COMMON.CONTMAT'
9037       include 'COMMON.CORRMAT'
9038       include 'COMMON.CHAIN'
9039       include 'COMMON.CONTROL'
9040       include 'COMMON.SHIELD'
9041       double precision gx(3),gx1(3)
9042       integer num_cont_hb_old(maxres)
9043       logical lprn,ldone
9044       double precision eello4,eello5,eelo6,eello_turn6
9045       external eello4,eello5,eello6,eello_turn6
9046 C Set lprn=.true. for debugging
9047       lprn=.false.
9048       eturn6=0.0d0
9049 #ifdef MPI
9050       do i=1,nres
9051         num_cont_hb_old(i)=num_cont_hb(i)
9052       enddo
9053       n_corr=0
9054       n_corr1=0
9055       if (nfgtasks.le.1) goto 30
9056       if (lprn) then
9057         write (iout,'(a)') 'Contact function values before RECEIVE:'
9058         do i=nnt,nct-2
9059           write (iout,'(2i3,50(1x,i2,f5.2))')
9060      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9061      &    j=1,num_cont_hb(i))
9062         enddo
9063       endif
9064       do i=1,ntask_cont_from
9065         ncont_recv(i)=0
9066       enddo
9067       do i=1,ntask_cont_to
9068         ncont_sent(i)=0
9069       enddo
9070 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9071 c     & ntask_cont_to
9072 C Make the list of contacts to send to send to other procesors
9073       do i=iturn3_start,iturn3_end
9074 c        write (iout,*) "make contact list turn3",i," num_cont",
9075 c     &    num_cont_hb(i)
9076         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9077       enddo
9078       do i=iturn4_start,iturn4_end
9079 c        write (iout,*) "make contact list turn4",i," num_cont",
9080 c     &   num_cont_hb(i)
9081         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9082       enddo
9083       do ii=1,nat_sent
9084         i=iat_sent(ii)
9085 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9086 c     &    num_cont_hb(i)
9087         do j=1,num_cont_hb(i)
9088         do k=1,4
9089           jjc=jcont_hb(j,i)
9090           iproc=iint_sent_local(k,jjc,ii)
9091 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9092           if (iproc.ne.0) then
9093             ncont_sent(iproc)=ncont_sent(iproc)+1
9094             nn=ncont_sent(iproc)
9095             zapas(1,nn,iproc)=i
9096             zapas(2,nn,iproc)=jjc
9097             zapas(3,nn,iproc)=d_cont(j,i)
9098             ind=3
9099             do kk=1,3
9100               ind=ind+1
9101               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9102             enddo
9103             do kk=1,2
9104               do ll=1,2
9105                 ind=ind+1
9106                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9107               enddo
9108             enddo
9109             do jj=1,5
9110               do kk=1,3
9111                 do ll=1,2
9112                   do mm=1,2
9113                     ind=ind+1
9114                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9115                   enddo
9116                 enddo
9117               enddo
9118             enddo
9119           endif
9120         enddo
9121         enddo
9122       enddo
9123       if (lprn) then
9124       write (iout,*)
9125      &  "Numbers of contacts to be sent to other processors",
9126      &  (ncont_sent(i),i=1,ntask_cont_to)
9127       write (iout,*) "Contacts sent"
9128       do ii=1,ntask_cont_to
9129         nn=ncont_sent(ii)
9130         iproc=itask_cont_to(ii)
9131         write (iout,*) nn," contacts to processor",iproc,
9132      &   " of CONT_TO_COMM group"
9133         do i=1,nn
9134           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9135         enddo
9136       enddo
9137       call flush(iout)
9138       endif
9139       CorrelType=477
9140       CorrelID=fg_rank+1
9141       CorrelType1=478
9142       CorrelID1=nfgtasks+fg_rank+1
9143       ireq=0
9144 C Receive the numbers of needed contacts from other processors
9145       do ii=1,ntask_cont_from
9146         iproc=itask_cont_from(ii)
9147         ireq=ireq+1
9148         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9149      &    FG_COMM,req(ireq),IERR)
9150       enddo
9151 c      write (iout,*) "IRECV ended"
9152 c      call flush(iout)
9153 C Send the number of contacts needed by other processors
9154       do ii=1,ntask_cont_to
9155         iproc=itask_cont_to(ii)
9156         ireq=ireq+1
9157         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9158      &    FG_COMM,req(ireq),IERR)
9159       enddo
9160 c      write (iout,*) "ISEND ended"
9161 c      write (iout,*) "number of requests (nn)",ireq
9162 c      call flush(iout)
9163       if (ireq.gt.0)
9164      &  call MPI_Waitall(ireq,req,status_array,ierr)
9165 c      write (iout,*)
9166 c     &  "Numbers of contacts to be received from other processors",
9167 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9168 c      call flush(iout)
9169 C Receive contacts
9170       ireq=0
9171       do ii=1,ntask_cont_from
9172         iproc=itask_cont_from(ii)
9173         nn=ncont_recv(ii)
9174 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9175 c     &   " of CONT_TO_COMM group"
9176 c        call flush(iout)
9177         if (nn.gt.0) then
9178           ireq=ireq+1
9179           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9180      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9181 c          write (iout,*) "ireq,req",ireq,req(ireq)
9182         endif
9183       enddo
9184 C Send the contacts to processors that need them
9185       do ii=1,ntask_cont_to
9186         iproc=itask_cont_to(ii)
9187         nn=ncont_sent(ii)
9188 c        write (iout,*) nn," contacts to processor",iproc,
9189 c     &   " of CONT_TO_COMM group"
9190         if (nn.gt.0) then
9191           ireq=ireq+1
9192           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9193      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9194 c          write (iout,*) "ireq,req",ireq,req(ireq)
9195 c          do i=1,nn
9196 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9197 c          enddo
9198         endif
9199       enddo
9200 c      write (iout,*) "number of requests (contacts)",ireq
9201 c      write (iout,*) "req",(req(i),i=1,4)
9202 c      call flush(iout)
9203       if (ireq.gt.0)
9204      & call MPI_Waitall(ireq,req,status_array,ierr)
9205       do iii=1,ntask_cont_from
9206         iproc=itask_cont_from(iii)
9207         nn=ncont_recv(iii)
9208         if (lprn) then
9209         write (iout,*) "Received",nn," contacts from processor",iproc,
9210      &   " of CONT_FROM_COMM group"
9211         call flush(iout)
9212         do i=1,nn
9213           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9214         enddo
9215         call flush(iout)
9216         endif
9217         do i=1,nn
9218           ii=zapas_recv(1,i,iii)
9219 c Flag the received contacts to prevent double-counting
9220           jj=-zapas_recv(2,i,iii)
9221 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9222 c          call flush(iout)
9223           nnn=num_cont_hb(ii)+1
9224           num_cont_hb(ii)=nnn
9225           jcont_hb(nnn,ii)=jj
9226           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9227           ind=3
9228           do kk=1,3
9229             ind=ind+1
9230             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9231           enddo
9232           do kk=1,2
9233             do ll=1,2
9234               ind=ind+1
9235               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9236             enddo
9237           enddo
9238           do jj=1,5
9239             do kk=1,3
9240               do ll=1,2
9241                 do mm=1,2
9242                   ind=ind+1
9243                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9244                 enddo
9245               enddo
9246             enddo
9247           enddo
9248         enddo
9249       enddo
9250       if (lprn) then
9251         write (iout,'(a)') 'Contact function values after receive:'
9252         do i=nnt,nct-2
9253           write (iout,'(2i3,50(1x,i3,5f6.3))')
9254      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9255      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9256         enddo
9257         call flush(iout)
9258       endif
9259    30 continue
9260 #endif
9261       if (lprn) then
9262         write (iout,'(a)') 'Contact function values:'
9263         do i=nnt,nct-2
9264           write (iout,'(2i3,50(1x,i2,5f6.3))')
9265      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9266      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9267         enddo
9268       endif
9269       ecorr=0.0D0
9270       ecorr5=0.0d0
9271       ecorr6=0.0d0
9272 C Remove the loop below after debugging !!!
9273       do i=nnt,nct
9274         do j=1,3
9275           gradcorr(j,i)=0.0D0
9276           gradxorr(j,i)=0.0D0
9277         enddo
9278       enddo
9279 C Calculate the dipole-dipole interaction energies
9280       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9281       do i=iatel_s,iatel_e+1
9282         num_conti=num_cont_hb(i)
9283         do jj=1,num_conti
9284           j=jcont_hb(jj,i)
9285 #ifdef MOMENT
9286           call dipole(i,j,jj)
9287 #endif
9288         enddo
9289       enddo
9290       endif
9291 C Calculate the local-electrostatic correlation terms
9292 c                write (iout,*) "gradcorr5 in eello5 before loop"
9293 c                do iii=1,nres
9294 c                  write (iout,'(i5,3f10.5)')
9295 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9296 c                enddo
9297       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9298 c        write (iout,*) "corr loop i",i
9299         i1=i+1
9300         num_conti=num_cont_hb(i)
9301         num_conti1=num_cont_hb(i+1)
9302         do jj=1,num_conti
9303           j=jcont_hb(jj,i)
9304           jp=iabs(j)
9305           do kk=1,num_conti1
9306             j1=jcont_hb(kk,i1)
9307             jp1=iabs(j1)
9308 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9309 c     &         ' jj=',jj,' kk=',kk
9310 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9311             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9312      &          .or. j.lt.0 .and. j1.gt.0) .and.
9313      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9314 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9315 C The system gains extra energy.
9316               n_corr=n_corr+1
9317               sqd1=dsqrt(d_cont(jj,i))
9318               sqd2=dsqrt(d_cont(kk,i1))
9319               sred_geom = sqd1*sqd2
9320               IF (sred_geom.lt.cutoff_corr) THEN
9321                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9322      &            ekont,fprimcont)
9323 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9324 cd     &         ' jj=',jj,' kk=',kk
9325                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9326                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9327                 do l=1,3
9328                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9329                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9330                 enddo
9331                 n_corr1=n_corr1+1
9332 cd               write (iout,*) 'sred_geom=',sred_geom,
9333 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9334 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9335 cd               write (iout,*) "g_contij",g_contij
9336 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9337 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9338                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9339                 if (wcorr4.gt.0.0d0)
9340      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9341 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9342                   if (energy_dec.and.wcorr4.gt.0.0d0)
9343      1                 write (iout,'(a6,4i5,0pf7.3)')
9344      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9345 c                write (iout,*) "gradcorr5 before eello5"
9346 c                do iii=1,nres
9347 c                  write (iout,'(i5,3f10.5)')
9348 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9349 c                enddo
9350                 if (wcorr5.gt.0.0d0)
9351      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9352 c                write (iout,*) "gradcorr5 after eello5"
9353 c                do iii=1,nres
9354 c                  write (iout,'(i5,3f10.5)')
9355 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9356 c                enddo
9357                   if (energy_dec.and.wcorr5.gt.0.0d0)
9358      1                 write (iout,'(a6,4i5,0pf7.3)')
9359      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9360 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9361 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9362                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9363      &               .or. wturn6.eq.0.0d0))then
9364 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9365                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9366                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9367      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9368 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9369 cd     &            'ecorr6=',ecorr6
9370 cd                write (iout,'(4e15.5)') sred_geom,
9371 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9372 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9373 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9374                 else if (wturn6.gt.0.0d0
9375      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9376 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9377                   eturn6=eturn6+eello_turn6(i,jj,kk)
9378                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9379      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9380 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9381                 endif
9382               ENDIF
9383 1111          continue
9384             endif
9385           enddo ! kk
9386         enddo ! jj
9387       enddo ! i
9388       do i=1,nres
9389         num_cont_hb(i)=num_cont_hb_old(i)
9390       enddo
9391 c                write (iout,*) "gradcorr5 in eello5"
9392 c                do iii=1,nres
9393 c                  write (iout,'(i5,3f10.5)')
9394 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9395 c                enddo
9396       return
9397       end
9398 c------------------------------------------------------------------------------
9399       subroutine add_hb_contact_eello(ii,jj,itask)
9400       implicit real*8 (a-h,o-z)
9401       include "DIMENSIONS"
9402       include "COMMON.IOUNITS"
9403       integer max_cont
9404       integer max_dim
9405       parameter (max_cont=maxconts)
9406       parameter (max_dim=70)
9407       include "COMMON.CONTACTS"
9408       include 'COMMON.CONTMAT'
9409       include 'COMMON.CORRMAT'
9410       double precision zapas(max_dim,maxconts,max_fg_procs),
9411      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9412       common /przechowalnia/ zapas
9413       integer i,j,ii,jj,iproc,itask(4),nn
9414 c      write (iout,*) "itask",itask
9415       do i=1,2
9416         iproc=itask(i)
9417         if (iproc.gt.0) then
9418           do j=1,num_cont_hb(ii)
9419             jjc=jcont_hb(j,ii)
9420 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9421             if (jjc.eq.jj) then
9422               ncont_sent(iproc)=ncont_sent(iproc)+1
9423               nn=ncont_sent(iproc)
9424               zapas(1,nn,iproc)=ii
9425               zapas(2,nn,iproc)=jjc
9426               zapas(3,nn,iproc)=d_cont(j,ii)
9427               ind=3
9428               do kk=1,3
9429                 ind=ind+1
9430                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9431               enddo
9432               do kk=1,2
9433                 do ll=1,2
9434                   ind=ind+1
9435                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9436                 enddo
9437               enddo
9438               do jj=1,5
9439                 do kk=1,3
9440                   do ll=1,2
9441                     do mm=1,2
9442                       ind=ind+1
9443                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9444                     enddo
9445                   enddo
9446                 enddo
9447               enddo
9448               exit
9449             endif
9450           enddo
9451         endif
9452       enddo
9453       return
9454       end
9455 c------------------------------------------------------------------------------
9456       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9457       implicit real*8 (a-h,o-z)
9458       include 'DIMENSIONS'
9459       include 'COMMON.IOUNITS'
9460       include 'COMMON.DERIV'
9461       include 'COMMON.INTERACT'
9462       include 'COMMON.CONTACTS'
9463       include 'COMMON.CONTMAT'
9464       include 'COMMON.CORRMAT'
9465       include 'COMMON.SHIELD'
9466       include 'COMMON.CONTROL'
9467       double precision gx(3),gx1(3)
9468       logical lprn
9469       lprn=.false.
9470 C      print *,"wchodze",fac_shield(i),shield_mode
9471       eij=facont_hb(jj,i)
9472       ekl=facont_hb(kk,k)
9473       ees0pij=ees0p(jj,i)
9474       ees0pkl=ees0p(kk,k)
9475       ees0mij=ees0m(jj,i)
9476       ees0mkl=ees0m(kk,k)
9477       ekont=eij*ekl
9478       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9479 C*
9480 C     & fac_shield(i)**2*fac_shield(j)**2
9481 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9482 C Following 4 lines for diagnostics.
9483 cd    ees0pkl=0.0D0
9484 cd    ees0pij=1.0D0
9485 cd    ees0mkl=0.0D0
9486 cd    ees0mij=1.0D0
9487 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9488 c     & 'Contacts ',i,j,
9489 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9490 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9491 c     & 'gradcorr_long'
9492 C Calculate the multi-body contribution to energy.
9493 C      ecorr=ecorr+ekont*ees
9494 C Calculate multi-body contributions to the gradient.
9495       coeffpees0pij=coeffp*ees0pij
9496       coeffmees0mij=coeffm*ees0mij
9497       coeffpees0pkl=coeffp*ees0pkl
9498       coeffmees0mkl=coeffm*ees0mkl
9499       do ll=1,3
9500 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9501         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9502      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9503      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9504         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9505      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9506      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9507 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9508         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9509      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9510      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9511         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9512      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9513      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9514         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9515      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9516      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9517         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9518         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9519         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9520      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9521      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9522         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9523         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9524 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9525       enddo
9526 c      write (iout,*)
9527 cgrad      do m=i+1,j-1
9528 cgrad        do ll=1,3
9529 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9530 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9531 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9532 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9533 cgrad        enddo
9534 cgrad      enddo
9535 cgrad      do m=k+1,l-1
9536 cgrad        do ll=1,3
9537 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9538 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9539 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9540 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9541 cgrad        enddo
9542 cgrad      enddo
9543 c      write (iout,*) "ehbcorr",ekont*ees
9544 C      print *,ekont,ees,i,k
9545       ehbcorr=ekont*ees
9546 C now gradient over shielding
9547 C      return
9548       if (shield_mode.gt.0) then
9549        j=ees0plist(jj,i)
9550        l=ees0plist(kk,k)
9551 C        print *,i,j,fac_shield(i),fac_shield(j),
9552 C     &fac_shield(k),fac_shield(l)
9553         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9554      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9555           do ilist=1,ishield_list(i)
9556            iresshield=shield_list(ilist,i)
9557            do m=1,3
9558            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9559 C     &      *2.0
9560            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9561      &              rlocshield
9562      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9563             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9564      &+rlocshield
9565            enddo
9566           enddo
9567           do ilist=1,ishield_list(j)
9568            iresshield=shield_list(ilist,j)
9569            do m=1,3
9570            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9571 C     &     *2.0
9572            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9573      &              rlocshield
9574      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9575            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9576      &     +rlocshield
9577            enddo
9578           enddo
9579
9580           do ilist=1,ishield_list(k)
9581            iresshield=shield_list(ilist,k)
9582            do m=1,3
9583            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9584 C     &     *2.0
9585            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9586      &              rlocshield
9587      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9588            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9589      &     +rlocshield
9590            enddo
9591           enddo
9592           do ilist=1,ishield_list(l)
9593            iresshield=shield_list(ilist,l)
9594            do m=1,3
9595            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9596 C     &     *2.0
9597            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9598      &              rlocshield
9599      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9600            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9601      &     +rlocshield
9602            enddo
9603           enddo
9604 C          print *,gshieldx(m,iresshield)
9605           do m=1,3
9606             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9607      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9608             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9609      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9610             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9611      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9612             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9613      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9614
9615             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9616      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9617             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9618      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9619             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9620      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9621             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9622      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9623
9624            enddo
9625       endif
9626       endif
9627       return
9628       end
9629 #ifdef MOMENT
9630 C---------------------------------------------------------------------------
9631       subroutine dipole(i,j,jj)
9632       implicit real*8 (a-h,o-z)
9633       include 'DIMENSIONS'
9634       include 'COMMON.IOUNITS'
9635       include 'COMMON.CHAIN'
9636       include 'COMMON.FFIELD'
9637       include 'COMMON.DERIV'
9638       include 'COMMON.INTERACT'
9639       include 'COMMON.CONTACTS'
9640       include 'COMMON.CONTMAT'
9641       include 'COMMON.CORRMAT'
9642       include 'COMMON.TORSION'
9643       include 'COMMON.VAR'
9644       include 'COMMON.GEO'
9645       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9646      &  auxmat(2,2)
9647       iti1 = itortyp(itype(i+1))
9648       if (j.lt.nres-1) then
9649         itj1 = itype2loc(itype(j+1))
9650       else
9651         itj1=nloctyp
9652       endif
9653       do iii=1,2
9654         dipi(iii,1)=Ub2(iii,i)
9655         dipderi(iii)=Ub2der(iii,i)
9656         dipi(iii,2)=b1(iii,i+1)
9657         dipj(iii,1)=Ub2(iii,j)
9658         dipderj(iii)=Ub2der(iii,j)
9659         dipj(iii,2)=b1(iii,j+1)
9660       enddo
9661       kkk=0
9662       do iii=1,2
9663         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9664         do jjj=1,2
9665           kkk=kkk+1
9666           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9667         enddo
9668       enddo
9669       do kkk=1,5
9670         do lll=1,3
9671           mmm=0
9672           do iii=1,2
9673             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9674      &        auxvec(1))
9675             do jjj=1,2
9676               mmm=mmm+1
9677               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9678             enddo
9679           enddo
9680         enddo
9681       enddo
9682       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9683       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9684       do iii=1,2
9685         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9686       enddo
9687       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9688       do iii=1,2
9689         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9690       enddo
9691       return
9692       end
9693 #endif
9694 C---------------------------------------------------------------------------
9695       subroutine calc_eello(i,j,k,l,jj,kk)
9696 C
9697 C This subroutine computes matrices and vectors needed to calculate
9698 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9699 C
9700       implicit real*8 (a-h,o-z)
9701       include 'DIMENSIONS'
9702       include 'COMMON.IOUNITS'
9703       include 'COMMON.CHAIN'
9704       include 'COMMON.DERIV'
9705       include 'COMMON.INTERACT'
9706       include 'COMMON.CONTACTS'
9707       include 'COMMON.CONTMAT'
9708       include 'COMMON.CORRMAT'
9709       include 'COMMON.TORSION'
9710       include 'COMMON.VAR'
9711       include 'COMMON.GEO'
9712       include 'COMMON.FFIELD'
9713       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9714      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9715       logical lprn
9716       common /kutas/ lprn
9717 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9718 cd     & ' jj=',jj,' kk=',kk
9719 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9720 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9721 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9722       do iii=1,2
9723         do jjj=1,2
9724           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9725           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9726         enddo
9727       enddo
9728       call transpose2(aa1(1,1),aa1t(1,1))
9729       call transpose2(aa2(1,1),aa2t(1,1))
9730       do kkk=1,5
9731         do lll=1,3
9732           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9733      &      aa1tder(1,1,lll,kkk))
9734           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9735      &      aa2tder(1,1,lll,kkk))
9736         enddo
9737       enddo
9738       if (l.eq.j+1) then
9739 C parallel orientation of the two CA-CA-CA frames.
9740         if (i.gt.1) then
9741           iti=itype2loc(itype(i))
9742         else
9743           iti=nloctyp
9744         endif
9745         itk1=itype2loc(itype(k+1))
9746         itj=itype2loc(itype(j))
9747         if (l.lt.nres-1) then
9748           itl1=itype2loc(itype(l+1))
9749         else
9750           itl1=nloctyp
9751         endif
9752 C A1 kernel(j+1) A2T
9753 cd        do iii=1,2
9754 cd          write (iout,'(3f10.5,5x,3f10.5)')
9755 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9756 cd        enddo
9757         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9758      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9759      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9760 C Following matrices are needed only for 6-th order cumulants
9761         IF (wcorr6.gt.0.0d0) THEN
9762         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9763      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9764      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9765         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9766      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9767      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9768      &   ADtEAderx(1,1,1,1,1,1))
9769         lprn=.false.
9770         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9771      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9772      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9773      &   ADtEA1derx(1,1,1,1,1,1))
9774         ENDIF
9775 C End 6-th order cumulants
9776 cd        lprn=.false.
9777 cd        if (lprn) then
9778 cd        write (2,*) 'In calc_eello6'
9779 cd        do iii=1,2
9780 cd          write (2,*) 'iii=',iii
9781 cd          do kkk=1,5
9782 cd            write (2,*) 'kkk=',kkk
9783 cd            do jjj=1,2
9784 cd              write (2,'(3(2f10.5),5x)')
9785 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9786 cd            enddo
9787 cd          enddo
9788 cd        enddo
9789 cd        endif
9790         call transpose2(EUgder(1,1,k),auxmat(1,1))
9791         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9792         call transpose2(EUg(1,1,k),auxmat(1,1))
9793         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9794         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9795 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9796 c    in theta; to be sriten later.
9797 c#ifdef NEWCORR
9798 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9799 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9800 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9801 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9802 c#endif
9803         do iii=1,2
9804           do kkk=1,5
9805             do lll=1,3
9806               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9807      &          EAEAderx(1,1,lll,kkk,iii,1))
9808             enddo
9809           enddo
9810         enddo
9811 C A1T kernel(i+1) A2
9812         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9813      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9814      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9815 C Following matrices are needed only for 6-th order cumulants
9816         IF (wcorr6.gt.0.0d0) THEN
9817         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9818      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9819      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9820         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9821      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9822      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9823      &   ADtEAderx(1,1,1,1,1,2))
9824         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9825      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9826      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9827      &   ADtEA1derx(1,1,1,1,1,2))
9828         ENDIF
9829 C End 6-th order cumulants
9830         call transpose2(EUgder(1,1,l),auxmat(1,1))
9831         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9832         call transpose2(EUg(1,1,l),auxmat(1,1))
9833         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9834         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9835         do iii=1,2
9836           do kkk=1,5
9837             do lll=1,3
9838               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9839      &          EAEAderx(1,1,lll,kkk,iii,2))
9840             enddo
9841           enddo
9842         enddo
9843 C AEAb1 and AEAb2
9844 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9845 C They are needed only when the fifth- or the sixth-order cumulants are
9846 C indluded.
9847         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9848         call transpose2(AEA(1,1,1),auxmat(1,1))
9849         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9850         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9851         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9852         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9853         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9854         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9855         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9856         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9857         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9858         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9859         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9860         call transpose2(AEA(1,1,2),auxmat(1,1))
9861         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9862         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9863         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9864         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9865         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9866         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9867         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9868         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9869         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9870         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9871         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9872 C Calculate the Cartesian derivatives of the vectors.
9873         do iii=1,2
9874           do kkk=1,5
9875             do lll=1,3
9876               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9877               call matvec2(auxmat(1,1),b1(1,i),
9878      &          AEAb1derx(1,lll,kkk,iii,1,1))
9879               call matvec2(auxmat(1,1),Ub2(1,i),
9880      &          AEAb2derx(1,lll,kkk,iii,1,1))
9881               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9882      &          AEAb1derx(1,lll,kkk,iii,2,1))
9883               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9884      &          AEAb2derx(1,lll,kkk,iii,2,1))
9885               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9886               call matvec2(auxmat(1,1),b1(1,j),
9887      &          AEAb1derx(1,lll,kkk,iii,1,2))
9888               call matvec2(auxmat(1,1),Ub2(1,j),
9889      &          AEAb2derx(1,lll,kkk,iii,1,2))
9890               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9891      &          AEAb1derx(1,lll,kkk,iii,2,2))
9892               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9893      &          AEAb2derx(1,lll,kkk,iii,2,2))
9894             enddo
9895           enddo
9896         enddo
9897         ENDIF
9898 C End vectors
9899       else
9900 C Antiparallel orientation of the two CA-CA-CA frames.
9901         if (i.gt.1) then
9902           iti=itype2loc(itype(i))
9903         else
9904           iti=nloctyp
9905         endif
9906         itk1=itype2loc(itype(k+1))
9907         itl=itype2loc(itype(l))
9908         itj=itype2loc(itype(j))
9909         if (j.lt.nres-1) then
9910           itj1=itype2loc(itype(j+1))
9911         else
9912           itj1=nloctyp
9913         endif
9914 C A2 kernel(j-1)T A1T
9915         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9916      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9917      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9918 C Following matrices are needed only for 6-th order cumulants
9919         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9920      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9921         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9922      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9923      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9924         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9925      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9926      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9927      &   ADtEAderx(1,1,1,1,1,1))
9928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9929      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9930      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9931      &   ADtEA1derx(1,1,1,1,1,1))
9932         ENDIF
9933 C End 6-th order cumulants
9934         call transpose2(EUgder(1,1,k),auxmat(1,1))
9935         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9936         call transpose2(EUg(1,1,k),auxmat(1,1))
9937         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9938         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9939         do iii=1,2
9940           do kkk=1,5
9941             do lll=1,3
9942               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9943      &          EAEAderx(1,1,lll,kkk,iii,1))
9944             enddo
9945           enddo
9946         enddo
9947 C A2T kernel(i+1)T A1
9948         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9949      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9950      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9951 C Following matrices are needed only for 6-th order cumulants
9952         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9953      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9954         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9955      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9956      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9957         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9958      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9959      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9960      &   ADtEAderx(1,1,1,1,1,2))
9961         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9962      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9963      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9964      &   ADtEA1derx(1,1,1,1,1,2))
9965         ENDIF
9966 C End 6-th order cumulants
9967         call transpose2(EUgder(1,1,j),auxmat(1,1))
9968         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9969         call transpose2(EUg(1,1,j),auxmat(1,1))
9970         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9971         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9972         do iii=1,2
9973           do kkk=1,5
9974             do lll=1,3
9975               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9976      &          EAEAderx(1,1,lll,kkk,iii,2))
9977             enddo
9978           enddo
9979         enddo
9980 C AEAb1 and AEAb2
9981 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9982 C They are needed only when the fifth- or the sixth-order cumulants are
9983 C indluded.
9984         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9985      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9986         call transpose2(AEA(1,1,1),auxmat(1,1))
9987         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9988         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9989         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9990         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9991         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9992         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9993         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9994         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9995         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9996         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9997         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9998         call transpose2(AEA(1,1,2),auxmat(1,1))
9999         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10000         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10001         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10002         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10003         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10004         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10005         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10006         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10007         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10008         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10009         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10010 C Calculate the Cartesian derivatives of the vectors.
10011         do iii=1,2
10012           do kkk=1,5
10013             do lll=1,3
10014               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10015               call matvec2(auxmat(1,1),b1(1,i),
10016      &          AEAb1derx(1,lll,kkk,iii,1,1))
10017               call matvec2(auxmat(1,1),Ub2(1,i),
10018      &          AEAb2derx(1,lll,kkk,iii,1,1))
10019               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10020      &          AEAb1derx(1,lll,kkk,iii,2,1))
10021               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10022      &          AEAb2derx(1,lll,kkk,iii,2,1))
10023               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10024               call matvec2(auxmat(1,1),b1(1,l),
10025      &          AEAb1derx(1,lll,kkk,iii,1,2))
10026               call matvec2(auxmat(1,1),Ub2(1,l),
10027      &          AEAb2derx(1,lll,kkk,iii,1,2))
10028               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10029      &          AEAb1derx(1,lll,kkk,iii,2,2))
10030               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10031      &          AEAb2derx(1,lll,kkk,iii,2,2))
10032             enddo
10033           enddo
10034         enddo
10035         ENDIF
10036 C End vectors
10037       endif
10038       return
10039       end
10040 C---------------------------------------------------------------------------
10041       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10042      &  KK,KKderg,AKA,AKAderg,AKAderx)
10043       implicit none
10044       integer nderg
10045       logical transp
10046       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10047      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10048      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10049       integer iii,kkk,lll
10050       integer jjj,mmm
10051       logical lprn
10052       common /kutas/ lprn
10053       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10054       do iii=1,nderg
10055         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10056      &    AKAderg(1,1,iii))
10057       enddo
10058 cd      if (lprn) write (2,*) 'In kernel'
10059       do kkk=1,5
10060 cd        if (lprn) write (2,*) 'kkk=',kkk
10061         do lll=1,3
10062           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10063      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10064 cd          if (lprn) then
10065 cd            write (2,*) 'lll=',lll
10066 cd            write (2,*) 'iii=1'
10067 cd            do jjj=1,2
10068 cd              write (2,'(3(2f10.5),5x)')
10069 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10070 cd            enddo
10071 cd          endif
10072           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10073      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10074 cd          if (lprn) then
10075 cd            write (2,*) 'lll=',lll
10076 cd            write (2,*) 'iii=2'
10077 cd            do jjj=1,2
10078 cd              write (2,'(3(2f10.5),5x)')
10079 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10080 cd            enddo
10081 cd          endif
10082         enddo
10083       enddo
10084       return
10085       end
10086 C---------------------------------------------------------------------------
10087       double precision function eello4(i,j,k,l,jj,kk)
10088       implicit real*8 (a-h,o-z)
10089       include 'DIMENSIONS'
10090       include 'COMMON.IOUNITS'
10091       include 'COMMON.CHAIN'
10092       include 'COMMON.DERIV'
10093       include 'COMMON.INTERACT'
10094       include 'COMMON.CONTACTS'
10095       include 'COMMON.CONTMAT'
10096       include 'COMMON.CORRMAT'
10097       include 'COMMON.TORSION'
10098       include 'COMMON.VAR'
10099       include 'COMMON.GEO'
10100       double precision pizda(2,2),ggg1(3),ggg2(3)
10101 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10102 cd        eello4=0.0d0
10103 cd        return
10104 cd      endif
10105 cd      print *,'eello4:',i,j,k,l,jj,kk
10106 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10107 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10108 cold      eij=facont_hb(jj,i)
10109 cold      ekl=facont_hb(kk,k)
10110 cold      ekont=eij*ekl
10111       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10112 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10113       gcorr_loc(k-1)=gcorr_loc(k-1)
10114      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10115       if (l.eq.j+1) then
10116         gcorr_loc(l-1)=gcorr_loc(l-1)
10117      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10118 C Al 4/16/16: Derivatives in theta, to be added later.
10119 c#ifdef NEWCORR
10120 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10121 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10122 c#endif
10123       else
10124         gcorr_loc(j-1)=gcorr_loc(j-1)
10125      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10126 c#ifdef NEWCORR
10127 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10128 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10129 c#endif
10130       endif
10131       do iii=1,2
10132         do kkk=1,5
10133           do lll=1,3
10134             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10135      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10136 cd            derx(lll,kkk,iii)=0.0d0
10137           enddo
10138         enddo
10139       enddo
10140 cd      gcorr_loc(l-1)=0.0d0
10141 cd      gcorr_loc(j-1)=0.0d0
10142 cd      gcorr_loc(k-1)=0.0d0
10143 cd      eel4=1.0d0
10144 cd      write (iout,*)'Contacts have occurred for peptide groups',
10145 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10146 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10147       if (j.lt.nres-1) then
10148         j1=j+1
10149         j2=j-1
10150       else
10151         j1=j-1
10152         j2=j-2
10153       endif
10154       if (l.lt.nres-1) then
10155         l1=l+1
10156         l2=l-1
10157       else
10158         l1=l-1
10159         l2=l-2
10160       endif
10161       do ll=1,3
10162 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10163 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10164         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10165         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10166 cgrad        ghalf=0.5d0*ggg1(ll)
10167         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10168         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10169         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10170         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10171         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10172         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10173 cgrad        ghalf=0.5d0*ggg2(ll)
10174         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10175         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10176         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10177         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10178         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10179         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10180       enddo
10181 cgrad      do m=i+1,j-1
10182 cgrad        do ll=1,3
10183 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10184 cgrad        enddo
10185 cgrad      enddo
10186 cgrad      do m=k+1,l-1
10187 cgrad        do ll=1,3
10188 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10189 cgrad        enddo
10190 cgrad      enddo
10191 cgrad      do m=i+2,j2
10192 cgrad        do ll=1,3
10193 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10194 cgrad        enddo
10195 cgrad      enddo
10196 cgrad      do m=k+2,l2
10197 cgrad        do ll=1,3
10198 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10199 cgrad        enddo
10200 cgrad      enddo
10201 cd      do iii=1,nres-3
10202 cd        write (2,*) iii,gcorr_loc(iii)
10203 cd      enddo
10204       eello4=ekont*eel4
10205 cd      write (2,*) 'ekont',ekont
10206 cd      write (iout,*) 'eello4',ekont*eel4
10207       return
10208       end
10209 C---------------------------------------------------------------------------
10210       double precision function eello5(i,j,k,l,jj,kk)
10211       implicit real*8 (a-h,o-z)
10212       include 'DIMENSIONS'
10213       include 'COMMON.IOUNITS'
10214       include 'COMMON.CHAIN'
10215       include 'COMMON.DERIV'
10216       include 'COMMON.INTERACT'
10217       include 'COMMON.CONTACTS'
10218       include 'COMMON.CONTMAT'
10219       include 'COMMON.CORRMAT'
10220       include 'COMMON.TORSION'
10221       include 'COMMON.VAR'
10222       include 'COMMON.GEO'
10223       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10224       double precision ggg1(3),ggg2(3)
10225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10226 C                                                                              C
10227 C                            Parallel chains                                   C
10228 C                                                                              C
10229 C          o             o                   o             o                   C
10230 C         /l\           / \             \   / \           / \   /              C
10231 C        /   \         /   \             \ /   \         /   \ /               C
10232 C       j| o |l1       | o |              o| o |         | o |o                C
10233 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10234 C      \i/   \         /   \ /             /   \         /   \                 C
10235 C       o    k1             o                                                  C
10236 C         (I)          (II)                (III)          (IV)                 C
10237 C                                                                              C
10238 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10239 C                                                                              C
10240 C                            Antiparallel chains                               C
10241 C                                                                              C
10242 C          o             o                   o             o                   C
10243 C         /j\           / \             \   / \           / \   /              C
10244 C        /   \         /   \             \ /   \         /   \ /               C
10245 C      j1| o |l        | o |              o| o |         | o |o                C
10246 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10247 C      \i/   \         /   \ /             /   \         /   \                 C
10248 C       o     k1            o                                                  C
10249 C         (I)          (II)                (III)          (IV)                 C
10250 C                                                                              C
10251 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10252 C                                                                              C
10253 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10254 C                                                                              C
10255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10256 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10257 cd        eello5=0.0d0
10258 cd        return
10259 cd      endif
10260 cd      write (iout,*)
10261 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10262 cd     &   ' and',k,l
10263       itk=itype2loc(itype(k))
10264       itl=itype2loc(itype(l))
10265       itj=itype2loc(itype(j))
10266       eello5_1=0.0d0
10267       eello5_2=0.0d0
10268       eello5_3=0.0d0
10269       eello5_4=0.0d0
10270 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10271 cd     &   eel5_3_num,eel5_4_num)
10272       do iii=1,2
10273         do kkk=1,5
10274           do lll=1,3
10275             derx(lll,kkk,iii)=0.0d0
10276           enddo
10277         enddo
10278       enddo
10279 cd      eij=facont_hb(jj,i)
10280 cd      ekl=facont_hb(kk,k)
10281 cd      ekont=eij*ekl
10282 cd      write (iout,*)'Contacts have occurred for peptide groups',
10283 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10284 cd      goto 1111
10285 C Contribution from the graph I.
10286 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10287 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10288       call transpose2(EUg(1,1,k),auxmat(1,1))
10289       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10290       vv(1)=pizda(1,1)-pizda(2,2)
10291       vv(2)=pizda(1,2)+pizda(2,1)
10292       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10293      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10294 C Explicit gradient in virtual-dihedral angles.
10295       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10296      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10297      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10298       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10299       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10300       vv(1)=pizda(1,1)-pizda(2,2)
10301       vv(2)=pizda(1,2)+pizda(2,1)
10302       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10303      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10304      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10305       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10306       vv(1)=pizda(1,1)-pizda(2,2)
10307       vv(2)=pizda(1,2)+pizda(2,1)
10308       if (l.eq.j+1) then
10309         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10310      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10311      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10312       else
10313         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10314      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10315      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10316       endif
10317 C Cartesian gradient
10318       do iii=1,2
10319         do kkk=1,5
10320           do lll=1,3
10321             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10322      &        pizda(1,1))
10323             vv(1)=pizda(1,1)-pizda(2,2)
10324             vv(2)=pizda(1,2)+pizda(2,1)
10325             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10326      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10327      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10328           enddo
10329         enddo
10330       enddo
10331 c      goto 1112
10332 c1111  continue
10333 C Contribution from graph II
10334       call transpose2(EE(1,1,k),auxmat(1,1))
10335       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10336       vv(1)=pizda(1,1)+pizda(2,2)
10337       vv(2)=pizda(2,1)-pizda(1,2)
10338       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10339      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10340 C Explicit gradient in virtual-dihedral angles.
10341       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10342      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10343       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10344       vv(1)=pizda(1,1)+pizda(2,2)
10345       vv(2)=pizda(2,1)-pizda(1,2)
10346       if (l.eq.j+1) then
10347         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10348      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10349      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10350       else
10351         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10352      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10353      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10354       endif
10355 C Cartesian gradient
10356       do iii=1,2
10357         do kkk=1,5
10358           do lll=1,3
10359             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10360      &        pizda(1,1))
10361             vv(1)=pizda(1,1)+pizda(2,2)
10362             vv(2)=pizda(2,1)-pizda(1,2)
10363             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10364      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10365      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10366           enddo
10367         enddo
10368       enddo
10369 cd      goto 1112
10370 cd1111  continue
10371       if (l.eq.j+1) then
10372 cd        goto 1110
10373 C Parallel orientation
10374 C Contribution from graph III
10375         call transpose2(EUg(1,1,l),auxmat(1,1))
10376         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10377         vv(1)=pizda(1,1)-pizda(2,2)
10378         vv(2)=pizda(1,2)+pizda(2,1)
10379         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10380      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10381 C Explicit gradient in virtual-dihedral angles.
10382         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10383      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10384      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10385         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10386         vv(1)=pizda(1,1)-pizda(2,2)
10387         vv(2)=pizda(1,2)+pizda(2,1)
10388         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10389      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10390      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10391         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10392         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10393         vv(1)=pizda(1,1)-pizda(2,2)
10394         vv(2)=pizda(1,2)+pizda(2,1)
10395         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10396      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10397      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10398 C Cartesian gradient
10399         do iii=1,2
10400           do kkk=1,5
10401             do lll=1,3
10402               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10403      &          pizda(1,1))
10404               vv(1)=pizda(1,1)-pizda(2,2)
10405               vv(2)=pizda(1,2)+pizda(2,1)
10406               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10407      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10408      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10409             enddo
10410           enddo
10411         enddo
10412 cd        goto 1112
10413 C Contribution from graph IV
10414 cd1110    continue
10415         call transpose2(EE(1,1,l),auxmat(1,1))
10416         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10417         vv(1)=pizda(1,1)+pizda(2,2)
10418         vv(2)=pizda(2,1)-pizda(1,2)
10419         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10420      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10421 C Explicit gradient in virtual-dihedral angles.
10422         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10423      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10424         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10425         vv(1)=pizda(1,1)+pizda(2,2)
10426         vv(2)=pizda(2,1)-pizda(1,2)
10427         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10428      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10429      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10430 C Cartesian gradient
10431         do iii=1,2
10432           do kkk=1,5
10433             do lll=1,3
10434               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10435      &          pizda(1,1))
10436               vv(1)=pizda(1,1)+pizda(2,2)
10437               vv(2)=pizda(2,1)-pizda(1,2)
10438               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10439      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10440      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10441             enddo
10442           enddo
10443         enddo
10444       else
10445 C Antiparallel orientation
10446 C Contribution from graph III
10447 c        goto 1110
10448         call transpose2(EUg(1,1,j),auxmat(1,1))
10449         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10450         vv(1)=pizda(1,1)-pizda(2,2)
10451         vv(2)=pizda(1,2)+pizda(2,1)
10452         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10454 C Explicit gradient in virtual-dihedral angles.
10455         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10456      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10457      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10458         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10459         vv(1)=pizda(1,1)-pizda(2,2)
10460         vv(2)=pizda(1,2)+pizda(2,1)
10461         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10462      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10463      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10464         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10465         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10466         vv(1)=pizda(1,1)-pizda(2,2)
10467         vv(2)=pizda(1,2)+pizda(2,1)
10468         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10469      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10470      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10471 C Cartesian gradient
10472         do iii=1,2
10473           do kkk=1,5
10474             do lll=1,3
10475               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10476      &          pizda(1,1))
10477               vv(1)=pizda(1,1)-pizda(2,2)
10478               vv(2)=pizda(1,2)+pizda(2,1)
10479               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10480      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10481      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10482             enddo
10483           enddo
10484         enddo
10485 cd        goto 1112
10486 C Contribution from graph IV
10487 1110    continue
10488         call transpose2(EE(1,1,j),auxmat(1,1))
10489         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10490         vv(1)=pizda(1,1)+pizda(2,2)
10491         vv(2)=pizda(2,1)-pizda(1,2)
10492         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10493      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10494 C Explicit gradient in virtual-dihedral angles.
10495         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10496      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10497         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10498         vv(1)=pizda(1,1)+pizda(2,2)
10499         vv(2)=pizda(2,1)-pizda(1,2)
10500         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10501      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10502      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10503 C Cartesian gradient
10504         do iii=1,2
10505           do kkk=1,5
10506             do lll=1,3
10507               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10508      &          pizda(1,1))
10509               vv(1)=pizda(1,1)+pizda(2,2)
10510               vv(2)=pizda(2,1)-pizda(1,2)
10511               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10512      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10513      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10514             enddo
10515           enddo
10516         enddo
10517       endif
10518 1112  continue
10519       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10520 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10521 cd        write (2,*) 'ijkl',i,j,k,l
10522 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10523 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10524 cd      endif
10525 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10526 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10527 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10528 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10529       if (j.lt.nres-1) then
10530         j1=j+1
10531         j2=j-1
10532       else
10533         j1=j-1
10534         j2=j-2
10535       endif
10536       if (l.lt.nres-1) then
10537         l1=l+1
10538         l2=l-1
10539       else
10540         l1=l-1
10541         l2=l-2
10542       endif
10543 cd      eij=1.0d0
10544 cd      ekl=1.0d0
10545 cd      ekont=1.0d0
10546 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10547 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10548 C        summed up outside the subrouine as for the other subroutines
10549 C        handling long-range interactions. The old code is commented out
10550 C        with "cgrad" to keep track of changes.
10551       do ll=1,3
10552 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10553 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10554         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10555         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10556 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10557 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10558 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10559 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10560 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10561 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10562 c     &   gradcorr5ij,
10563 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10564 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10565 cgrad        ghalf=0.5d0*ggg1(ll)
10566 cd        ghalf=0.0d0
10567         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10568         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10569         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10570         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10571         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10572         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10573 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10574 cgrad        ghalf=0.5d0*ggg2(ll)
10575 cd        ghalf=0.0d0
10576         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10577         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10578         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10579         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10580         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10581         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10582       enddo
10583 cd      goto 1112
10584 cgrad      do m=i+1,j-1
10585 cgrad        do ll=1,3
10586 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10587 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10588 cgrad        enddo
10589 cgrad      enddo
10590 cgrad      do m=k+1,l-1
10591 cgrad        do ll=1,3
10592 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10593 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10594 cgrad        enddo
10595 cgrad      enddo
10596 c1112  continue
10597 cgrad      do m=i+2,j2
10598 cgrad        do ll=1,3
10599 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10600 cgrad        enddo
10601 cgrad      enddo
10602 cgrad      do m=k+2,l2
10603 cgrad        do ll=1,3
10604 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10605 cgrad        enddo
10606 cgrad      enddo
10607 cd      do iii=1,nres-3
10608 cd        write (2,*) iii,g_corr5_loc(iii)
10609 cd      enddo
10610       eello5=ekont*eel5
10611 cd      write (2,*) 'ekont',ekont
10612 cd      write (iout,*) 'eello5',ekont*eel5
10613       return
10614       end
10615 c--------------------------------------------------------------------------
10616       double precision function eello6(i,j,k,l,jj,kk)
10617       implicit real*8 (a-h,o-z)
10618       include 'DIMENSIONS'
10619       include 'COMMON.IOUNITS'
10620       include 'COMMON.CHAIN'
10621       include 'COMMON.DERIV'
10622       include 'COMMON.INTERACT'
10623       include 'COMMON.CONTACTS'
10624       include 'COMMON.CONTMAT'
10625       include 'COMMON.CORRMAT'
10626       include 'COMMON.TORSION'
10627       include 'COMMON.VAR'
10628       include 'COMMON.GEO'
10629       include 'COMMON.FFIELD'
10630       double precision ggg1(3),ggg2(3)
10631 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10632 cd        eello6=0.0d0
10633 cd        return
10634 cd      endif
10635 cd      write (iout,*)
10636 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10637 cd     &   ' and',k,l
10638       eello6_1=0.0d0
10639       eello6_2=0.0d0
10640       eello6_3=0.0d0
10641       eello6_4=0.0d0
10642       eello6_5=0.0d0
10643       eello6_6=0.0d0
10644 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10645 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10646       do iii=1,2
10647         do kkk=1,5
10648           do lll=1,3
10649             derx(lll,kkk,iii)=0.0d0
10650           enddo
10651         enddo
10652       enddo
10653 cd      eij=facont_hb(jj,i)
10654 cd      ekl=facont_hb(kk,k)
10655 cd      ekont=eij*ekl
10656 cd      eij=1.0d0
10657 cd      ekl=1.0d0
10658 cd      ekont=1.0d0
10659       if (l.eq.j+1) then
10660         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10661         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10662         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10663         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10664         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10665         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10666       else
10667         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10668         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10669         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10670         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10671         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10672           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10673         else
10674           eello6_5=0.0d0
10675         endif
10676         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10677       endif
10678 C If turn contributions are considered, they will be handled separately.
10679       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10680 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10681 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10682 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10683 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10684 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10685 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10686 cd      goto 1112
10687       if (j.lt.nres-1) then
10688         j1=j+1
10689         j2=j-1
10690       else
10691         j1=j-1
10692         j2=j-2
10693       endif
10694       if (l.lt.nres-1) then
10695         l1=l+1
10696         l2=l-1
10697       else
10698         l1=l-1
10699         l2=l-2
10700       endif
10701       do ll=1,3
10702 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10703 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10704 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10705 cgrad        ghalf=0.5d0*ggg1(ll)
10706 cd        ghalf=0.0d0
10707         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10708         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10709         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10710         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10711         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10712         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10713         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10714         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10715 cgrad        ghalf=0.5d0*ggg2(ll)
10716 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10717 cd        ghalf=0.0d0
10718         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10719         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10720         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10721         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10722         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10723         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10724       enddo
10725 cd      goto 1112
10726 cgrad      do m=i+1,j-1
10727 cgrad        do ll=1,3
10728 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10729 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10730 cgrad        enddo
10731 cgrad      enddo
10732 cgrad      do m=k+1,l-1
10733 cgrad        do ll=1,3
10734 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10735 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10736 cgrad        enddo
10737 cgrad      enddo
10738 cgrad1112  continue
10739 cgrad      do m=i+2,j2
10740 cgrad        do ll=1,3
10741 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10742 cgrad        enddo
10743 cgrad      enddo
10744 cgrad      do m=k+2,l2
10745 cgrad        do ll=1,3
10746 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10747 cgrad        enddo
10748 cgrad      enddo
10749 cd      do iii=1,nres-3
10750 cd        write (2,*) iii,g_corr6_loc(iii)
10751 cd      enddo
10752       eello6=ekont*eel6
10753 cd      write (2,*) 'ekont',ekont
10754 cd      write (iout,*) 'eello6',ekont*eel6
10755       return
10756       end
10757 c--------------------------------------------------------------------------
10758       double precision function eello6_graph1(i,j,k,l,imat,swap)
10759       implicit real*8 (a-h,o-z)
10760       include 'DIMENSIONS'
10761       include 'COMMON.IOUNITS'
10762       include 'COMMON.CHAIN'
10763       include 'COMMON.DERIV'
10764       include 'COMMON.INTERACT'
10765       include 'COMMON.CONTACTS'
10766       include 'COMMON.CONTMAT'
10767       include 'COMMON.CORRMAT'
10768       include 'COMMON.TORSION'
10769       include 'COMMON.VAR'
10770       include 'COMMON.GEO'
10771       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10772       logical swap
10773       logical lprn
10774       common /kutas/ lprn
10775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10776 C                                                                              C
10777 C      Parallel       Antiparallel                                             C
10778 C                                                                              C
10779 C          o             o                                                     C
10780 C         /l\           /j\                                                    C
10781 C        /   \         /   \                                                   C
10782 C       /| o |         | o |\                                                  C
10783 C     \ j|/k\|  /   \  |/k\|l /                                                C
10784 C      \ /   \ /     \ /   \ /                                                 C
10785 C       o     o       o     o                                                  C
10786 C       i             i                                                        C
10787 C                                                                              C
10788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10789       itk=itype2loc(itype(k))
10790       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10791       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10792       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10793       call transpose2(EUgC(1,1,k),auxmat(1,1))
10794       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10795       vv1(1)=pizda1(1,1)-pizda1(2,2)
10796       vv1(2)=pizda1(1,2)+pizda1(2,1)
10797       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10798       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10799       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10800       s5=scalar2(vv(1),Dtobr2(1,i))
10801 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10802       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10803       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10804      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10805      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10806      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10807      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10808      & +scalar2(vv(1),Dtobr2der(1,i)))
10809       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10810       vv1(1)=pizda1(1,1)-pizda1(2,2)
10811       vv1(2)=pizda1(1,2)+pizda1(2,1)
10812       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10813       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10814       if (l.eq.j+1) then
10815         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10816      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10817      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10818      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10819      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10820       else
10821         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10822      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10823      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10824      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10825      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10826       endif
10827       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10828       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10829       vv1(1)=pizda1(1,1)-pizda1(2,2)
10830       vv1(2)=pizda1(1,2)+pizda1(2,1)
10831       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10832      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10833      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10834      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10835       do iii=1,2
10836         if (swap) then
10837           ind=3-iii
10838         else
10839           ind=iii
10840         endif
10841         do kkk=1,5
10842           do lll=1,3
10843             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10844             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10845             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10846             call transpose2(EUgC(1,1,k),auxmat(1,1))
10847             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10848      &        pizda1(1,1))
10849             vv1(1)=pizda1(1,1)-pizda1(2,2)
10850             vv1(2)=pizda1(1,2)+pizda1(2,1)
10851             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10852             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10853      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10854             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10855      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10856             s5=scalar2(vv(1),Dtobr2(1,i))
10857             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10858           enddo
10859         enddo
10860       enddo
10861       return
10862       end
10863 c----------------------------------------------------------------------------
10864       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10865       implicit real*8 (a-h,o-z)
10866       include 'DIMENSIONS'
10867       include 'COMMON.IOUNITS'
10868       include 'COMMON.CHAIN'
10869       include 'COMMON.DERIV'
10870       include 'COMMON.INTERACT'
10871       include 'COMMON.CONTACTS'
10872       include 'COMMON.CONTMAT'
10873       include 'COMMON.CORRMAT'
10874       include 'COMMON.TORSION'
10875       include 'COMMON.VAR'
10876       include 'COMMON.GEO'
10877       logical swap
10878       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10879      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10880       logical lprn
10881       common /kutas/ lprn
10882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10883 C                                                                              C
10884 C      Parallel       Antiparallel                                             C
10885 C                                                                              C
10886 C          o             o                                                     C
10887 C     \   /l\           /j\   /                                                C
10888 C      \ /   \         /   \ /                                                 C
10889 C       o| o |         | o |o                                                  C
10890 C     \ j|/k\|      \  |/k\|l                                                  C
10891 C      \ /   \       \ /   \                                                   C
10892 C       o             o                                                        C
10893 C       i             i                                                        C
10894 C                                                                              C
10895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10896 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10897 C AL 7/4/01 s1 would occur in the sixth-order moment,
10898 C           but not in a cluster cumulant
10899 #ifdef MOMENT
10900       s1=dip(1,jj,i)*dip(1,kk,k)
10901 #endif
10902       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10903       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10904       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10905       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10906       call transpose2(EUg(1,1,k),auxmat(1,1))
10907       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10908       vv(1)=pizda(1,1)-pizda(2,2)
10909       vv(2)=pizda(1,2)+pizda(2,1)
10910       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10911 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10912 #ifdef MOMENT
10913       eello6_graph2=-(s1+s2+s3+s4)
10914 #else
10915       eello6_graph2=-(s2+s3+s4)
10916 #endif
10917 c      eello6_graph2=-s3
10918 C Derivatives in gamma(i-1)
10919       if (i.gt.1) then
10920 #ifdef MOMENT
10921         s1=dipderg(1,jj,i)*dip(1,kk,k)
10922 #endif
10923         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10924         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10925         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10926         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10927 #ifdef MOMENT
10928         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10929 #else
10930         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10931 #endif
10932 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10933       endif
10934 C Derivatives in gamma(k-1)
10935 #ifdef MOMENT
10936       s1=dip(1,jj,i)*dipderg(1,kk,k)
10937 #endif
10938       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10939       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10940       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10941       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10942       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10943       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10944       vv(1)=pizda(1,1)-pizda(2,2)
10945       vv(2)=pizda(1,2)+pizda(2,1)
10946       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10947 #ifdef MOMENT
10948       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10949 #else
10950       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10951 #endif
10952 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10953 C Derivatives in gamma(j-1) or gamma(l-1)
10954       if (j.gt.1) then
10955 #ifdef MOMENT
10956         s1=dipderg(3,jj,i)*dip(1,kk,k)
10957 #endif
10958         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10959         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10960         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10961         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10962         vv(1)=pizda(1,1)-pizda(2,2)
10963         vv(2)=pizda(1,2)+pizda(2,1)
10964         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10965 #ifdef MOMENT
10966         if (swap) then
10967           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10968         else
10969           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10970         endif
10971 #endif
10972         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10973 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10974       endif
10975 C Derivatives in gamma(l-1) or gamma(j-1)
10976       if (l.gt.1) then
10977 #ifdef MOMENT
10978         s1=dip(1,jj,i)*dipderg(3,kk,k)
10979 #endif
10980         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10981         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10982         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10983         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10984         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10985         vv(1)=pizda(1,1)-pizda(2,2)
10986         vv(2)=pizda(1,2)+pizda(2,1)
10987         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10988 #ifdef MOMENT
10989         if (swap) then
10990           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10991         else
10992           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10993         endif
10994 #endif
10995         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10996 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10997       endif
10998 C Cartesian derivatives.
10999       if (lprn) then
11000         write (2,*) 'In eello6_graph2'
11001         do iii=1,2
11002           write (2,*) 'iii=',iii
11003           do kkk=1,5
11004             write (2,*) 'kkk=',kkk
11005             do jjj=1,2
11006               write (2,'(3(2f10.5),5x)')
11007      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11008             enddo
11009           enddo
11010         enddo
11011       endif
11012       do iii=1,2
11013         do kkk=1,5
11014           do lll=1,3
11015 #ifdef MOMENT
11016             if (iii.eq.1) then
11017               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11018             else
11019               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11020             endif
11021 #endif
11022             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11023      &        auxvec(1))
11024             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11025             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11026      &        auxvec(1))
11027             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11028             call transpose2(EUg(1,1,k),auxmat(1,1))
11029             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11030      &        pizda(1,1))
11031             vv(1)=pizda(1,1)-pizda(2,2)
11032             vv(2)=pizda(1,2)+pizda(2,1)
11033             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11034 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11035 #ifdef MOMENT
11036             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11037 #else
11038             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11039 #endif
11040             if (swap) then
11041               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11042             else
11043               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11044             endif
11045           enddo
11046         enddo
11047       enddo
11048       return
11049       end
11050 c----------------------------------------------------------------------------
11051       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11052       implicit real*8 (a-h,o-z)
11053       include 'DIMENSIONS'
11054       include 'COMMON.IOUNITS'
11055       include 'COMMON.CHAIN'
11056       include 'COMMON.DERIV'
11057       include 'COMMON.INTERACT'
11058       include 'COMMON.CONTACTS'
11059       include 'COMMON.CONTMAT'
11060       include 'COMMON.CORRMAT'
11061       include 'COMMON.TORSION'
11062       include 'COMMON.VAR'
11063       include 'COMMON.GEO'
11064       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11065       logical swap
11066 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11067 C                                                                              C
11068 C      Parallel       Antiparallel                                             C
11069 C                                                                              C
11070 C          o             o                                                     C
11071 C         /l\   /   \   /j\                                                    C
11072 C        /   \ /     \ /   \                                                   C
11073 C       /| o |o       o| o |\                                                  C
11074 C       j|/k\|  /      |/k\|l /                                                C
11075 C        /   \ /       /   \ /                                                 C
11076 C       /     o       /     o                                                  C
11077 C       i             i                                                        C
11078 C                                                                              C
11079 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11080 C
11081 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11082 C           energy moment and not to the cluster cumulant.
11083       iti=itortyp(itype(i))
11084       if (j.lt.nres-1) then
11085         itj1=itype2loc(itype(j+1))
11086       else
11087         itj1=nloctyp
11088       endif
11089       itk=itype2loc(itype(k))
11090       itk1=itype2loc(itype(k+1))
11091       if (l.lt.nres-1) then
11092         itl1=itype2loc(itype(l+1))
11093       else
11094         itl1=nloctyp
11095       endif
11096 #ifdef MOMENT
11097       s1=dip(4,jj,i)*dip(4,kk,k)
11098 #endif
11099       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11100       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11101       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11102       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11103       call transpose2(EE(1,1,k),auxmat(1,1))
11104       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11105       vv(1)=pizda(1,1)+pizda(2,2)
11106       vv(2)=pizda(2,1)-pizda(1,2)
11107       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11108 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11109 cd     & "sum",-(s2+s3+s4)
11110 #ifdef MOMENT
11111       eello6_graph3=-(s1+s2+s3+s4)
11112 #else
11113       eello6_graph3=-(s2+s3+s4)
11114 #endif
11115 c      eello6_graph3=-s4
11116 C Derivatives in gamma(k-1)
11117       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11118       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11119       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11120       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11121 C Derivatives in gamma(l-1)
11122       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11123       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11124       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11125       vv(1)=pizda(1,1)+pizda(2,2)
11126       vv(2)=pizda(2,1)-pizda(1,2)
11127       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11128       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11129 C Cartesian derivatives.
11130       do iii=1,2
11131         do kkk=1,5
11132           do lll=1,3
11133 #ifdef MOMENT
11134             if (iii.eq.1) then
11135               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11136             else
11137               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11138             endif
11139 #endif
11140             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11141      &        auxvec(1))
11142             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11143             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11144      &        auxvec(1))
11145             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11146             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11147      &        pizda(1,1))
11148             vv(1)=pizda(1,1)+pizda(2,2)
11149             vv(2)=pizda(2,1)-pizda(1,2)
11150             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11151 #ifdef MOMENT
11152             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11153 #else
11154             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11155 #endif
11156             if (swap) then
11157               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11158             else
11159               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11160             endif
11161 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11162           enddo
11163         enddo
11164       enddo
11165       return
11166       end
11167 c----------------------------------------------------------------------------
11168       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11169       implicit real*8 (a-h,o-z)
11170       include 'DIMENSIONS'
11171       include 'COMMON.IOUNITS'
11172       include 'COMMON.CHAIN'
11173       include 'COMMON.DERIV'
11174       include 'COMMON.INTERACT'
11175       include 'COMMON.CONTACTS'
11176       include 'COMMON.CONTMAT'
11177       include 'COMMON.CORRMAT'
11178       include 'COMMON.TORSION'
11179       include 'COMMON.VAR'
11180       include 'COMMON.GEO'
11181       include 'COMMON.FFIELD'
11182       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11183      & auxvec1(2),auxmat1(2,2)
11184       logical swap
11185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11186 C                                                                              C
11187 C      Parallel       Antiparallel                                             C
11188 C                                                                              C
11189 C          o             o                                                     C
11190 C         /l\   /   \   /j\                                                    C
11191 C        /   \ /     \ /   \                                                   C
11192 C       /| o |o       o| o |\                                                  C
11193 C     \ j|/k\|      \  |/k\|l                                                  C
11194 C      \ /   \       \ /   \                                                   C
11195 C       o     \       o     \                                                  C
11196 C       i             i                                                        C
11197 C                                                                              C
11198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11199 C
11200 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11201 C           energy moment and not to the cluster cumulant.
11202 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11203       iti=itype2loc(itype(i))
11204       itj=itype2loc(itype(j))
11205       if (j.lt.nres-1) then
11206         itj1=itype2loc(itype(j+1))
11207       else
11208         itj1=nloctyp
11209       endif
11210       itk=itype2loc(itype(k))
11211       if (k.lt.nres-1) then
11212         itk1=itype2loc(itype(k+1))
11213       else
11214         itk1=nloctyp
11215       endif
11216       itl=itype2loc(itype(l))
11217       if (l.lt.nres-1) then
11218         itl1=itype2loc(itype(l+1))
11219       else
11220         itl1=nloctyp
11221       endif
11222 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11223 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11224 cd     & ' itl',itl,' itl1',itl1
11225 #ifdef MOMENT
11226       if (imat.eq.1) then
11227         s1=dip(3,jj,i)*dip(3,kk,k)
11228       else
11229         s1=dip(2,jj,j)*dip(2,kk,l)
11230       endif
11231 #endif
11232       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11233       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11234       if (j.eq.l+1) then
11235         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11236         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11237       else
11238         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11239         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11240       endif
11241       call transpose2(EUg(1,1,k),auxmat(1,1))
11242       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11243       vv(1)=pizda(1,1)-pizda(2,2)
11244       vv(2)=pizda(2,1)+pizda(1,2)
11245       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11246 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11247 #ifdef MOMENT
11248       eello6_graph4=-(s1+s2+s3+s4)
11249 #else
11250       eello6_graph4=-(s2+s3+s4)
11251 #endif
11252 C Derivatives in gamma(i-1)
11253       if (i.gt.1) then
11254 #ifdef MOMENT
11255         if (imat.eq.1) then
11256           s1=dipderg(2,jj,i)*dip(3,kk,k)
11257         else
11258           s1=dipderg(4,jj,j)*dip(2,kk,l)
11259         endif
11260 #endif
11261         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11262         if (j.eq.l+1) then
11263           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11264           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11265         else
11266           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11267           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11268         endif
11269         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11270         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11271 cd          write (2,*) 'turn6 derivatives'
11272 #ifdef MOMENT
11273           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11274 #else
11275           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11276 #endif
11277         else
11278 #ifdef MOMENT
11279           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11280 #else
11281           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11282 #endif
11283         endif
11284       endif
11285 C Derivatives in gamma(k-1)
11286 #ifdef MOMENT
11287       if (imat.eq.1) then
11288         s1=dip(3,jj,i)*dipderg(2,kk,k)
11289       else
11290         s1=dip(2,jj,j)*dipderg(4,kk,l)
11291       endif
11292 #endif
11293       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11294       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11295       if (j.eq.l+1) then
11296         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11297         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11298       else
11299         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11300         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11301       endif
11302       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11303       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11304       vv(1)=pizda(1,1)-pizda(2,2)
11305       vv(2)=pizda(2,1)+pizda(1,2)
11306       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11307       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11308 #ifdef MOMENT
11309         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11310 #else
11311         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11312 #endif
11313       else
11314 #ifdef MOMENT
11315         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11316 #else
11317         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11318 #endif
11319       endif
11320 C Derivatives in gamma(j-1) or gamma(l-1)
11321       if (l.eq.j+1 .and. l.gt.1) then
11322         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11323         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11324         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11325         vv(1)=pizda(1,1)-pizda(2,2)
11326         vv(2)=pizda(2,1)+pizda(1,2)
11327         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11328         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11329       else if (j.gt.1) then
11330         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11331         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11332         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11333         vv(1)=pizda(1,1)-pizda(2,2)
11334         vv(2)=pizda(2,1)+pizda(1,2)
11335         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11336         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11337           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11338         else
11339           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11340         endif
11341       endif
11342 C Cartesian derivatives.
11343       do iii=1,2
11344         do kkk=1,5
11345           do lll=1,3
11346 #ifdef MOMENT
11347             if (iii.eq.1) then
11348               if (imat.eq.1) then
11349                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11350               else
11351                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11352               endif
11353             else
11354               if (imat.eq.1) then
11355                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11356               else
11357                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11358               endif
11359             endif
11360 #endif
11361             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11362      &        auxvec(1))
11363             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11364             if (j.eq.l+1) then
11365               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11366      &          b1(1,j+1),auxvec(1))
11367               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11368             else
11369               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11370      &          b1(1,l+1),auxvec(1))
11371               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11372             endif
11373             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11374      &        pizda(1,1))
11375             vv(1)=pizda(1,1)-pizda(2,2)
11376             vv(2)=pizda(2,1)+pizda(1,2)
11377             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11378             if (swap) then
11379               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11380 #ifdef MOMENT
11381                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11382      &             -(s1+s2+s4)
11383 #else
11384                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11385      &             -(s2+s4)
11386 #endif
11387                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11388               else
11389 #ifdef MOMENT
11390                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11391 #else
11392                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11393 #endif
11394                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11395               endif
11396             else
11397 #ifdef MOMENT
11398               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11399 #else
11400               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11401 #endif
11402               if (l.eq.j+1) then
11403                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11404               else
11405                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11406               endif
11407             endif
11408           enddo
11409         enddo
11410       enddo
11411       return
11412       end
11413 c----------------------------------------------------------------------------
11414       double precision function eello_turn6(i,jj,kk)
11415       implicit real*8 (a-h,o-z)
11416       include 'DIMENSIONS'
11417       include 'COMMON.IOUNITS'
11418       include 'COMMON.CHAIN'
11419       include 'COMMON.DERIV'
11420       include 'COMMON.INTERACT'
11421       include 'COMMON.CONTACTS'
11422       include 'COMMON.CONTMAT'
11423       include 'COMMON.CORRMAT'
11424       include 'COMMON.TORSION'
11425       include 'COMMON.VAR'
11426       include 'COMMON.GEO'
11427       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11428      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11429      &  ggg1(3),ggg2(3)
11430       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11431      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11432 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11433 C           the respective energy moment and not to the cluster cumulant.
11434       s1=0.0d0
11435       s8=0.0d0
11436       s13=0.0d0
11437 c
11438       eello_turn6=0.0d0
11439       j=i+4
11440       k=i+1
11441       l=i+3
11442       iti=itype2loc(itype(i))
11443       itk=itype2loc(itype(k))
11444       itk1=itype2loc(itype(k+1))
11445       itl=itype2loc(itype(l))
11446       itj=itype2loc(itype(j))
11447 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11448 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11449 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11450 cd        eello6=0.0d0
11451 cd        return
11452 cd      endif
11453 cd      write (iout,*)
11454 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11455 cd     &   ' and',k,l
11456 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11457       do iii=1,2
11458         do kkk=1,5
11459           do lll=1,3
11460             derx_turn(lll,kkk,iii)=0.0d0
11461           enddo
11462         enddo
11463       enddo
11464 cd      eij=1.0d0
11465 cd      ekl=1.0d0
11466 cd      ekont=1.0d0
11467       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11468 cd      eello6_5=0.0d0
11469 cd      write (2,*) 'eello6_5',eello6_5
11470 #ifdef MOMENT
11471       call transpose2(AEA(1,1,1),auxmat(1,1))
11472       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11473       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11474       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11475 #endif
11476       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11477       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11478       s2 = scalar2(b1(1,k),vtemp1(1))
11479 #ifdef MOMENT
11480       call transpose2(AEA(1,1,2),atemp(1,1))
11481       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11482       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11483       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11484 #endif
11485       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11486       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11487       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11488 #ifdef MOMENT
11489       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11490       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11491       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11492       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11493       ss13 = scalar2(b1(1,k),vtemp4(1))
11494       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11495 #endif
11496 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11497 c      s1=0.0d0
11498 c      s2=0.0d0
11499 c      s8=0.0d0
11500 c      s12=0.0d0
11501 c      s13=0.0d0
11502       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11503 C Derivatives in gamma(i+2)
11504       s1d =0.0d0
11505       s8d =0.0d0
11506 #ifdef MOMENT
11507       call transpose2(AEA(1,1,1),auxmatd(1,1))
11508       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11509       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11510       call transpose2(AEAderg(1,1,2),atempd(1,1))
11511       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11512       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11513 #endif
11514       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11515       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11516       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11517 c      s1d=0.0d0
11518 c      s2d=0.0d0
11519 c      s8d=0.0d0
11520 c      s12d=0.0d0
11521 c      s13d=0.0d0
11522       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11523 C Derivatives in gamma(i+3)
11524 #ifdef MOMENT
11525       call transpose2(AEA(1,1,1),auxmatd(1,1))
11526       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11527       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11528       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11529 #endif
11530       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11531       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11532       s2d = scalar2(b1(1,k),vtemp1d(1))
11533 #ifdef MOMENT
11534       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11535       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11536 #endif
11537       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11538 #ifdef MOMENT
11539       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11540       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11541       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11542 #endif
11543 c      s1d=0.0d0
11544 c      s2d=0.0d0
11545 c      s8d=0.0d0
11546 c      s12d=0.0d0
11547 c      s13d=0.0d0
11548 #ifdef MOMENT
11549       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11550      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11551 #else
11552       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11553      &               -0.5d0*ekont*(s2d+s12d)
11554 #endif
11555 C Derivatives in gamma(i+4)
11556       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11557       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11558       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11559 #ifdef MOMENT
11560       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11561       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11562       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11563 #endif
11564 c      s1d=0.0d0
11565 c      s2d=0.0d0
11566 c      s8d=0.0d0
11567 C      s12d=0.0d0
11568 c      s13d=0.0d0
11569 #ifdef MOMENT
11570       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11571 #else
11572       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11573 #endif
11574 C Derivatives in gamma(i+5)
11575 #ifdef MOMENT
11576       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11577       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11578       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11579 #endif
11580       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11581       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11582       s2d = scalar2(b1(1,k),vtemp1d(1))
11583 #ifdef MOMENT
11584       call transpose2(AEA(1,1,2),atempd(1,1))
11585       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11586       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11587 #endif
11588       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11589       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11590 #ifdef MOMENT
11591       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11592       ss13d = scalar2(b1(1,k),vtemp4d(1))
11593       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11594 #endif
11595 c      s1d=0.0d0
11596 c      s2d=0.0d0
11597 c      s8d=0.0d0
11598 c      s12d=0.0d0
11599 c      s13d=0.0d0
11600 #ifdef MOMENT
11601       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11602      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11603 #else
11604       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11605      &               -0.5d0*ekont*(s2d+s12d)
11606 #endif
11607 C Cartesian derivatives
11608       do iii=1,2
11609         do kkk=1,5
11610           do lll=1,3
11611 #ifdef MOMENT
11612             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11613             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11614             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11615 #endif
11616             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11617             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11618      &          vtemp1d(1))
11619             s2d = scalar2(b1(1,k),vtemp1d(1))
11620 #ifdef MOMENT
11621             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11622             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11623             s8d = -(atempd(1,1)+atempd(2,2))*
11624      &           scalar2(cc(1,1,l),vtemp2(1))
11625 #endif
11626             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11627      &           auxmatd(1,1))
11628             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11629             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11630 c      s1d=0.0d0
11631 c      s2d=0.0d0
11632 c      s8d=0.0d0
11633 c      s12d=0.0d0
11634 c      s13d=0.0d0
11635 #ifdef MOMENT
11636             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11637      &        - 0.5d0*(s1d+s2d)
11638 #else
11639             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11640      &        - 0.5d0*s2d
11641 #endif
11642 #ifdef MOMENT
11643             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11644      &        - 0.5d0*(s8d+s12d)
11645 #else
11646             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11647      &        - 0.5d0*s12d
11648 #endif
11649           enddo
11650         enddo
11651       enddo
11652 #ifdef MOMENT
11653       do kkk=1,5
11654         do lll=1,3
11655           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11656      &      achuj_tempd(1,1))
11657           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11658           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11659           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11660           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11661           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11662      &      vtemp4d(1))
11663           ss13d = scalar2(b1(1,k),vtemp4d(1))
11664           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11665           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11666         enddo
11667       enddo
11668 #endif
11669 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11670 cd     &  16*eel_turn6_num
11671 cd      goto 1112
11672       if (j.lt.nres-1) then
11673         j1=j+1
11674         j2=j-1
11675       else
11676         j1=j-1
11677         j2=j-2
11678       endif
11679       if (l.lt.nres-1) then
11680         l1=l+1
11681         l2=l-1
11682       else
11683         l1=l-1
11684         l2=l-2
11685       endif
11686       do ll=1,3
11687 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11688 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11689 cgrad        ghalf=0.5d0*ggg1(ll)
11690 cd        ghalf=0.0d0
11691         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11692         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11693         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11694      &    +ekont*derx_turn(ll,2,1)
11695         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11696         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11697      &    +ekont*derx_turn(ll,4,1)
11698         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11699         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11700         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11701 cgrad        ghalf=0.5d0*ggg2(ll)
11702 cd        ghalf=0.0d0
11703         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11704      &    +ekont*derx_turn(ll,2,2)
11705         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11706         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11707      &    +ekont*derx_turn(ll,4,2)
11708         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11709         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11710         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11711       enddo
11712 cd      goto 1112
11713 cgrad      do m=i+1,j-1
11714 cgrad        do ll=1,3
11715 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11716 cgrad        enddo
11717 cgrad      enddo
11718 cgrad      do m=k+1,l-1
11719 cgrad        do ll=1,3
11720 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11721 cgrad        enddo
11722 cgrad      enddo
11723 cgrad1112  continue
11724 cgrad      do m=i+2,j2
11725 cgrad        do ll=1,3
11726 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11727 cgrad        enddo
11728 cgrad      enddo
11729 cgrad      do m=k+2,l2
11730 cgrad        do ll=1,3
11731 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11732 cgrad        enddo
11733 cgrad      enddo
11734 cd      do iii=1,nres-3
11735 cd        write (2,*) iii,g_corr6_loc(iii)
11736 cd      enddo
11737       eello_turn6=ekont*eel_turn6
11738 cd      write (2,*) 'ekont',ekont
11739 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11740       return
11741       end
11742 C-----------------------------------------------------------------------------
11743 #endif
11744       double precision function scalar(u,v)
11745 !DIR$ INLINEALWAYS scalar
11746 #ifndef OSF
11747 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11748 #endif
11749       implicit none
11750       double precision u(3),v(3)
11751 cd      double precision sc
11752 cd      integer i
11753 cd      sc=0.0d0
11754 cd      do i=1,3
11755 cd        sc=sc+u(i)*v(i)
11756 cd      enddo
11757 cd      scalar=sc
11758
11759       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11760       return
11761       end
11762 crc-------------------------------------------------
11763       SUBROUTINE MATVEC2(A1,V1,V2)
11764 !DIR$ INLINEALWAYS MATVEC2
11765 #ifndef OSF
11766 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11767 #endif
11768       implicit real*8 (a-h,o-z)
11769       include 'DIMENSIONS'
11770       DIMENSION A1(2,2),V1(2),V2(2)
11771 c      DO 1 I=1,2
11772 c        VI=0.0
11773 c        DO 3 K=1,2
11774 c    3     VI=VI+A1(I,K)*V1(K)
11775 c        Vaux(I)=VI
11776 c    1 CONTINUE
11777
11778       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11779       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11780
11781       v2(1)=vaux1
11782       v2(2)=vaux2
11783       END
11784 C---------------------------------------
11785       SUBROUTINE MATMAT2(A1,A2,A3)
11786 #ifndef OSF
11787 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11788 #endif
11789       implicit real*8 (a-h,o-z)
11790       include 'DIMENSIONS'
11791       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11792 c      DIMENSION AI3(2,2)
11793 c        DO  J=1,2
11794 c          A3IJ=0.0
11795 c          DO K=1,2
11796 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11797 c          enddo
11798 c          A3(I,J)=A3IJ
11799 c       enddo
11800 c      enddo
11801
11802       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11803       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11804       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11805       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11806
11807       A3(1,1)=AI3_11
11808       A3(2,1)=AI3_21
11809       A3(1,2)=AI3_12
11810       A3(2,2)=AI3_22
11811       END
11812
11813 c-------------------------------------------------------------------------
11814       double precision function scalar2(u,v)
11815 !DIR$ INLINEALWAYS scalar2
11816       implicit none
11817       double precision u(2),v(2)
11818       double precision sc
11819       integer i
11820       scalar2=u(1)*v(1)+u(2)*v(2)
11821       return
11822       end
11823
11824 C-----------------------------------------------------------------------------
11825
11826       subroutine transpose2(a,at)
11827 !DIR$ INLINEALWAYS transpose2
11828 #ifndef OSF
11829 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11830 #endif
11831       implicit none
11832       double precision a(2,2),at(2,2)
11833       at(1,1)=a(1,1)
11834       at(1,2)=a(2,1)
11835       at(2,1)=a(1,2)
11836       at(2,2)=a(2,2)
11837       return
11838       end
11839 c--------------------------------------------------------------------------
11840       subroutine transpose(n,a,at)
11841       implicit none
11842       integer n,i,j
11843       double precision a(n,n),at(n,n)
11844       do i=1,n
11845         do j=1,n
11846           at(j,i)=a(i,j)
11847         enddo
11848       enddo
11849       return
11850       end
11851 C---------------------------------------------------------------------------
11852       subroutine prodmat3(a1,a2,kk,transp,prod)
11853 !DIR$ INLINEALWAYS prodmat3
11854 #ifndef OSF
11855 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11856 #endif
11857       implicit none
11858       integer i,j
11859       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11860       logical transp
11861 crc      double precision auxmat(2,2),prod_(2,2)
11862
11863       if (transp) then
11864 crc        call transpose2(kk(1,1),auxmat(1,1))
11865 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11866 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11867
11868            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11869      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11870            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11871      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11872            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11873      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11874            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11875      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11876
11877       else
11878 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11879 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11880
11881            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11882      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11883            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11884      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11885            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11886      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11887            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11888      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11889
11890       endif
11891 c      call transpose2(a2(1,1),a2t(1,1))
11892
11893 crc      print *,transp
11894 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11895 crc      print *,((prod(i,j),i=1,2),j=1,2)
11896
11897       return
11898       end
11899 CCC----------------------------------------------
11900       subroutine Eliptransfer(eliptran)
11901       implicit real*8 (a-h,o-z)
11902       include 'DIMENSIONS'
11903       include 'COMMON.GEO'
11904       include 'COMMON.VAR'
11905       include 'COMMON.LOCAL'
11906       include 'COMMON.CHAIN'
11907       include 'COMMON.DERIV'
11908       include 'COMMON.NAMES'
11909       include 'COMMON.INTERACT'
11910       include 'COMMON.IOUNITS'
11911       include 'COMMON.CALC'
11912       include 'COMMON.CONTROL'
11913       include 'COMMON.SPLITELE'
11914       include 'COMMON.SBRIDGE'
11915 C this is done by Adasko
11916 C      print *,"wchodze"
11917 C structure of box:
11918 C      water
11919 C--bordliptop-- buffore starts
11920 C--bufliptop--- here true lipid starts
11921 C      lipid
11922 C--buflipbot--- lipid ends buffore starts
11923 C--bordlipbot--buffore ends
11924 c      call cartprint
11925       eliptran=0.0
11926       do i=ilip_start,ilip_end
11927 C       do i=1,1
11928         if (itype(i).eq.ntyp1) cycle
11929
11930         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11931         if (positi.le.0.0) positi=positi+boxzsize
11932 C        print *,i
11933 C first for peptide groups
11934 c for each residue check if it is in lipid or lipid water border area
11935        if ((positi.gt.bordlipbot)
11936      &.and.(positi.lt.bordliptop)) then
11937 C the energy transfer exist
11938         if (positi.lt.buflipbot) then
11939 C what fraction I am in
11940          fracinbuf=1.0d0-
11941      &        ((positi-bordlipbot)/lipbufthick)
11942 C lipbufthick is thickenes of lipid buffore
11943          sslip=sscalelip(fracinbuf)
11944          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11945          eliptran=eliptran+sslip*pepliptran
11946          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11947          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11948 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11949
11950 C        print *,"doing sccale for lower part"
11951 C         print *,i,sslip,fracinbuf,ssgradlip
11952         elseif (positi.gt.bufliptop) then
11953          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11954          sslip=sscalelip(fracinbuf)
11955          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11956          eliptran=eliptran+sslip*pepliptran
11957          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11958          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11959 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11960 C          print *, "doing sscalefor top part"
11961 C         print *,i,sslip,fracinbuf,ssgradlip
11962         else
11963          eliptran=eliptran+pepliptran
11964 C         print *,"I am in true lipid"
11965         endif
11966 C       else
11967 C       eliptran=elpitran+0.0 ! I am in water
11968        endif
11969        enddo
11970 C       print *, "nic nie bylo w lipidzie?"
11971 C now multiply all by the peptide group transfer factor
11972 C       eliptran=eliptran*pepliptran
11973 C now the same for side chains
11974 CV       do i=1,1
11975        do i=ilip_start,ilip_end
11976         if (itype(i).eq.ntyp1) cycle
11977         positi=(mod(c(3,i+nres),boxzsize))
11978         if (positi.le.0) positi=positi+boxzsize
11979 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
11980 c     &   bordliptop
11981 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11982 c for each residue check if it is in lipid or lipid water border area
11983 C       respos=mod(c(3,i+nres),boxzsize)
11984 C       print *,positi,bordlipbot,buflipbot
11985        if ((positi.gt.bordlipbot)
11986      & .and.(positi.lt.bordliptop)) then
11987 C the energy transfer exist
11988         if (positi.lt.buflipbot) then
11989          fracinbuf=1.0d0-
11990      &     ((positi-bordlipbot)/lipbufthick)
11991 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
11992 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
11993 C lipbufthick is thickenes of lipid buffore
11994          sslip=sscalelip(fracinbuf)
11995          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11996          eliptran=eliptran+sslip*liptranene(itype(i))
11997          gliptranx(3,i)=gliptranx(3,i)
11998      &+ssgradlip*liptranene(itype(i))
11999          gliptranc(3,i-1)= gliptranc(3,i-1)
12000      &+ssgradlip*liptranene(itype(i))
12001 C         print *,"doing sccale for lower part"
12002         elseif (positi.gt.bufliptop) then
12003          fracinbuf=1.0d0-
12004      &((bordliptop-positi)/lipbufthick)
12005          sslip=sscalelip(fracinbuf)
12006          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12007          eliptran=eliptran+sslip*liptranene(itype(i))
12008          gliptranx(3,i)=gliptranx(3,i)
12009      &+ssgradlip*liptranene(itype(i))
12010          gliptranc(3,i-1)= gliptranc(3,i-1)
12011      &+ssgradlip*liptranene(itype(i))
12012 C          print *, "doing sscalefor top part",sslip,fracinbuf
12013         else
12014          eliptran=eliptran+liptranene(itype(i))
12015 C         print *,"I am in true lipid"
12016         endif
12017         endif ! if in lipid or buffor
12018 C       else
12019 C       eliptran=elpitran+0.0 ! I am in water
12020        enddo
12021        return
12022        end
12023 C---------------------------------------------------------
12024 C AFM soubroutine for constant force
12025        subroutine AFMforce(Eafmforce)
12026        implicit real*8 (a-h,o-z)
12027       include 'DIMENSIONS'
12028       include 'COMMON.GEO'
12029       include 'COMMON.VAR'
12030       include 'COMMON.LOCAL'
12031       include 'COMMON.CHAIN'
12032       include 'COMMON.DERIV'
12033       include 'COMMON.NAMES'
12034       include 'COMMON.INTERACT'
12035       include 'COMMON.IOUNITS'
12036       include 'COMMON.CALC'
12037       include 'COMMON.CONTROL'
12038       include 'COMMON.SPLITELE'
12039       include 'COMMON.SBRIDGE'
12040       real*8 diffafm(3)
12041       dist=0.0d0
12042       Eafmforce=0.0d0
12043       do i=1,3
12044       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12045       dist=dist+diffafm(i)**2
12046       enddo
12047       dist=dsqrt(dist)
12048       Eafmforce=-forceAFMconst*(dist-distafminit)
12049       do i=1,3
12050       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12051       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12052       enddo
12053 C      print *,'AFM',Eafmforce
12054       return
12055       end
12056 C---------------------------------------------------------
12057 C AFM subroutine with pseudoconstant velocity
12058        subroutine AFMvel(Eafmforce)
12059        implicit real*8 (a-h,o-z)
12060       include 'DIMENSIONS'
12061       include 'COMMON.GEO'
12062       include 'COMMON.VAR'
12063       include 'COMMON.LOCAL'
12064       include 'COMMON.CHAIN'
12065       include 'COMMON.DERIV'
12066       include 'COMMON.NAMES'
12067       include 'COMMON.INTERACT'
12068       include 'COMMON.IOUNITS'
12069       include 'COMMON.CALC'
12070       include 'COMMON.CONTROL'
12071       include 'COMMON.SPLITELE'
12072       include 'COMMON.SBRIDGE'
12073       real*8 diffafm(3)
12074 C Only for check grad COMMENT if not used for checkgrad
12075 C      totT=3.0d0
12076 C--------------------------------------------------------
12077 C      print *,"wchodze"
12078       dist=0.0d0
12079       Eafmforce=0.0d0
12080       do i=1,3
12081       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12082       dist=dist+diffafm(i)**2
12083       enddo
12084       dist=dsqrt(dist)
12085       Eafmforce=0.5d0*forceAFMconst
12086      & *(distafminit+totTafm*velAFMconst-dist)**2
12087 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12088       do i=1,3
12089       gradafm(i,afmend-1)=-forceAFMconst*
12090      &(distafminit+totTafm*velAFMconst-dist)
12091      &*diffafm(i)/dist
12092       gradafm(i,afmbeg-1)=forceAFMconst*
12093      &(distafminit+totTafm*velAFMconst-dist)
12094      &*diffafm(i)/dist
12095       enddo
12096 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12097       return
12098       end
12099 C-----------------------------------------------------------
12100 C first for shielding is setting of function of side-chains
12101        subroutine set_shield_fac
12102       implicit real*8 (a-h,o-z)
12103       include 'DIMENSIONS'
12104       include 'COMMON.CHAIN'
12105       include 'COMMON.DERIV'
12106       include 'COMMON.IOUNITS'
12107       include 'COMMON.SHIELD'
12108       include 'COMMON.INTERACT'
12109 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12110       double precision div77_81/0.974996043d0/,
12111      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12112
12113 C the vector between center of side_chain and peptide group
12114        double precision pep_side(3),long,side_calf(3),
12115      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12116      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12117 C the line belowe needs to be changed for FGPROC>1
12118       do i=1,nres-1
12119       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12120       ishield_list(i)=0
12121 Cif there two consequtive dummy atoms there is no peptide group between them
12122 C the line below has to be changed for FGPROC>1
12123       VolumeTotal=0.0
12124       do k=1,nres
12125        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12126        dist_pep_side=0.0
12127        dist_side_calf=0.0
12128        do j=1,3
12129 C first lets set vector conecting the ithe side-chain with kth side-chain
12130       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12131 C      pep_side(j)=2.0d0
12132 C and vector conecting the side-chain with its proper calfa
12133       side_calf(j)=c(j,k+nres)-c(j,k)
12134 C      side_calf(j)=2.0d0
12135       pept_group(j)=c(j,i)-c(j,i+1)
12136 C lets have their lenght
12137       dist_pep_side=pep_side(j)**2+dist_pep_side
12138       dist_side_calf=dist_side_calf+side_calf(j)**2
12139       dist_pept_group=dist_pept_group+pept_group(j)**2
12140       enddo
12141        dist_pep_side=dsqrt(dist_pep_side)
12142        dist_pept_group=dsqrt(dist_pept_group)
12143        dist_side_calf=dsqrt(dist_side_calf)
12144       do j=1,3
12145         pep_side_norm(j)=pep_side(j)/dist_pep_side
12146         side_calf_norm(j)=dist_side_calf
12147       enddo
12148 C now sscale fraction
12149        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12150 C       print *,buff_shield,"buff"
12151 C now sscale
12152         if (sh_frac_dist.le.0.0) cycle
12153 C If we reach here it means that this side chain reaches the shielding sphere
12154 C Lets add him to the list for gradient
12155         ishield_list(i)=ishield_list(i)+1
12156 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12157 C this list is essential otherwise problem would be O3
12158         shield_list(ishield_list(i),i)=k
12159 C Lets have the sscale value
12160         if (sh_frac_dist.gt.1.0) then
12161          scale_fac_dist=1.0d0
12162          do j=1,3
12163          sh_frac_dist_grad(j)=0.0d0
12164          enddo
12165         else
12166          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12167      &                   *(2.0*sh_frac_dist-3.0d0)
12168          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12169      &                  /dist_pep_side/buff_shield*0.5
12170 C remember for the final gradient multiply sh_frac_dist_grad(j)
12171 C for side_chain by factor -2 !
12172          do j=1,3
12173          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12174 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12175 C     &                    sh_frac_dist_grad(j)
12176          enddo
12177         endif
12178 C        if ((i.eq.3).and.(k.eq.2)) then
12179 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12180 C     & ,"TU"
12181 C        endif
12182
12183 C this is what is now we have the distance scaling now volume...
12184       short=short_r_sidechain(itype(k))
12185       long=long_r_sidechain(itype(k))
12186       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12187 C now costhet_grad
12188 C       costhet=0.0d0
12189        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12190 C       costhet_fac=0.0d0
12191        do j=1,3
12192          costhet_grad(j)=costhet_fac*pep_side(j)
12193        enddo
12194 C remember for the final gradient multiply costhet_grad(j)
12195 C for side_chain by factor -2 !
12196 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12197 C pep_side0pept_group is vector multiplication
12198       pep_side0pept_group=0.0
12199       do j=1,3
12200       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12201       enddo
12202       cosalfa=(pep_side0pept_group/
12203      & (dist_pep_side*dist_side_calf))
12204       fac_alfa_sin=1.0-cosalfa**2
12205       fac_alfa_sin=dsqrt(fac_alfa_sin)
12206       rkprim=fac_alfa_sin*(long-short)+short
12207 C now costhet_grad
12208        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12209        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12210
12211        do j=1,3
12212          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12213      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12214      &*(long-short)/fac_alfa_sin*cosalfa/
12215      &((dist_pep_side*dist_side_calf))*
12216      &((side_calf(j))-cosalfa*
12217      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12218
12219         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12220      &*(long-short)/fac_alfa_sin*cosalfa
12221      &/((dist_pep_side*dist_side_calf))*
12222      &(pep_side(j)-
12223      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12224        enddo
12225
12226       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12227      &                    /VSolvSphere_div
12228      &                    *wshield
12229 C now the gradient...
12230 C grad_shield is gradient of Calfa for peptide groups
12231 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12232 C     &               costhet,cosphi
12233 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12234 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12235       do j=1,3
12236       grad_shield(j,i)=grad_shield(j,i)
12237 C gradient po skalowaniu
12238      &                +(sh_frac_dist_grad(j)
12239 C  gradient po costhet
12240      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12241      &-scale_fac_dist*(cosphi_grad_long(j))
12242      &/(1.0-cosphi) )*div77_81
12243      &*VofOverlap
12244 C grad_shield_side is Cbeta sidechain gradient
12245       grad_shield_side(j,ishield_list(i),i)=
12246      &        (sh_frac_dist_grad(j)*(-2.0d0)
12247      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12248      &       +scale_fac_dist*(cosphi_grad_long(j))
12249      &        *2.0d0/(1.0-cosphi))
12250      &        *div77_81*VofOverlap
12251
12252        grad_shield_loc(j,ishield_list(i),i)=
12253      &   scale_fac_dist*cosphi_grad_loc(j)
12254      &        *2.0d0/(1.0-cosphi)
12255      &        *div77_81*VofOverlap
12256       enddo
12257       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12258       enddo
12259       fac_shield(i)=VolumeTotal*div77_81+div4_81
12260 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12261       enddo
12262       return
12263       end
12264 C--------------------------------------------------------------------------
12265       double precision function tschebyshev(m,n,x,y)
12266       implicit none
12267       include "DIMENSIONS"
12268       integer i,m,n
12269       double precision x(n),y,yy(0:maxvar),aux
12270 c Tschebyshev polynomial. Note that the first term is omitted
12271 c m=0: the constant term is included
12272 c m=1: the constant term is not included
12273       yy(0)=1.0d0
12274       yy(1)=y
12275       do i=2,n
12276         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12277       enddo
12278       aux=0.0d0
12279       do i=m,n
12280         aux=aux+x(i)*yy(i)
12281       enddo
12282       tschebyshev=aux
12283       return
12284       end
12285 C--------------------------------------------------------------------------
12286       double precision function gradtschebyshev(m,n,x,y)
12287       implicit none
12288       include "DIMENSIONS"
12289       integer i,m,n
12290       double precision x(n+1),y,yy(0:maxvar),aux
12291 c Tschebyshev polynomial. Note that the first term is omitted
12292 c m=0: the constant term is included
12293 c m=1: the constant term is not included
12294       yy(0)=1.0d0
12295       yy(1)=2.0d0*y
12296       do i=2,n
12297         yy(i)=2*y*yy(i-1)-yy(i-2)
12298       enddo
12299       aux=0.0d0
12300       do i=m,n
12301         aux=aux+x(i+1)*yy(i)*(i+1)
12302 C        print *, x(i+1),yy(i),i
12303       enddo
12304       gradtschebyshev=aux
12305       return
12306       end
12307 C------------------------------------------------------------------------
12308 C first for shielding is setting of function of side-chains
12309        subroutine set_shield_fac2
12310       implicit real*8 (a-h,o-z)
12311       include 'DIMENSIONS'
12312       include 'COMMON.CHAIN'
12313       include 'COMMON.DERIV'
12314       include 'COMMON.IOUNITS'
12315       include 'COMMON.SHIELD'
12316       include 'COMMON.INTERACT'
12317 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12318       double precision div77_81/0.974996043d0/,
12319      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12320
12321 C the vector between center of side_chain and peptide group
12322        double precision pep_side(3),long,side_calf(3),
12323      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12324      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12325 C the line belowe needs to be changed for FGPROC>1
12326       do i=1,nres-1
12327       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12328       ishield_list(i)=0
12329 Cif there two consequtive dummy atoms there is no peptide group between them
12330 C the line below has to be changed for FGPROC>1
12331       VolumeTotal=0.0
12332       do k=1,nres
12333        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12334        dist_pep_side=0.0
12335        dist_side_calf=0.0
12336        do j=1,3
12337 C first lets set vector conecting the ithe side-chain with kth side-chain
12338       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12339 C      pep_side(j)=2.0d0
12340 C and vector conecting the side-chain with its proper calfa
12341       side_calf(j)=c(j,k+nres)-c(j,k)
12342 C      side_calf(j)=2.0d0
12343       pept_group(j)=c(j,i)-c(j,i+1)
12344 C lets have their lenght
12345       dist_pep_side=pep_side(j)**2+dist_pep_side
12346       dist_side_calf=dist_side_calf+side_calf(j)**2
12347       dist_pept_group=dist_pept_group+pept_group(j)**2
12348       enddo
12349        dist_pep_side=dsqrt(dist_pep_side)
12350        dist_pept_group=dsqrt(dist_pept_group)
12351        dist_side_calf=dsqrt(dist_side_calf)
12352       do j=1,3
12353         pep_side_norm(j)=pep_side(j)/dist_pep_side
12354         side_calf_norm(j)=dist_side_calf
12355       enddo
12356 C now sscale fraction
12357        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12358 C       print *,buff_shield,"buff"
12359 C now sscale
12360         if (sh_frac_dist.le.0.0) cycle
12361 C If we reach here it means that this side chain reaches the shielding sphere
12362 C Lets add him to the list for gradient
12363         ishield_list(i)=ishield_list(i)+1
12364 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12365 C this list is essential otherwise problem would be O3
12366         shield_list(ishield_list(i),i)=k
12367 C Lets have the sscale value
12368         if (sh_frac_dist.gt.1.0) then
12369          scale_fac_dist=1.0d0
12370          do j=1,3
12371          sh_frac_dist_grad(j)=0.0d0
12372          enddo
12373         else
12374          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12375      &                   *(2.0d0*sh_frac_dist-3.0d0)
12376          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12377      &                  /dist_pep_side/buff_shield*0.5d0
12378 C remember for the final gradient multiply sh_frac_dist_grad(j)
12379 C for side_chain by factor -2 !
12380          do j=1,3
12381          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12382 C         sh_frac_dist_grad(j)=0.0d0
12383 C         scale_fac_dist=1.0d0
12384 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12385 C     &                    sh_frac_dist_grad(j)
12386          enddo
12387         endif
12388 C this is what is now we have the distance scaling now volume...
12389       short=short_r_sidechain(itype(k))
12390       long=long_r_sidechain(itype(k))
12391       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12392       sinthet=short/dist_pep_side*costhet
12393 C now costhet_grad
12394 C       costhet=0.6d0
12395 C       sinthet=0.8
12396        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12397 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12398 C     &             -short/dist_pep_side**2/costhet)
12399 C       costhet_fac=0.0d0
12400        do j=1,3
12401          costhet_grad(j)=costhet_fac*pep_side(j)
12402        enddo
12403 C remember for the final gradient multiply costhet_grad(j)
12404 C for side_chain by factor -2 !
12405 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12406 C pep_side0pept_group is vector multiplication
12407       pep_side0pept_group=0.0d0
12408       do j=1,3
12409       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12410       enddo
12411       cosalfa=(pep_side0pept_group/
12412      & (dist_pep_side*dist_side_calf))
12413       fac_alfa_sin=1.0d0-cosalfa**2
12414       fac_alfa_sin=dsqrt(fac_alfa_sin)
12415       rkprim=fac_alfa_sin*(long-short)+short
12416 C      rkprim=short
12417
12418 C now costhet_grad
12419        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12420 C       cosphi=0.6
12421        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12422        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12423      &      dist_pep_side**2)
12424 C       sinphi=0.8
12425        do j=1,3
12426          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12427      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12428      &*(long-short)/fac_alfa_sin*cosalfa/
12429      &((dist_pep_side*dist_side_calf))*
12430      &((side_calf(j))-cosalfa*
12431      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12432 C       cosphi_grad_long(j)=0.0d0
12433         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12434      &*(long-short)/fac_alfa_sin*cosalfa
12435      &/((dist_pep_side*dist_side_calf))*
12436      &(pep_side(j)-
12437      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12438 C       cosphi_grad_loc(j)=0.0d0
12439        enddo
12440 C      print *,sinphi,sinthet
12441 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12442 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12443       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12444      &                    /VSolvSphere_div
12445 C     &                    *wshield
12446 C now the gradient...
12447       do j=1,3
12448       grad_shield(j,i)=grad_shield(j,i)
12449 C gradient po skalowaniu
12450      &                +(sh_frac_dist_grad(j)*VofOverlap
12451 C  gradient po costhet
12452      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12453      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12454      &       sinphi/sinthet*costhet*costhet_grad(j)
12455      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12456      & )*wshield
12457 C grad_shield_side is Cbeta sidechain gradient
12458       grad_shield_side(j,ishield_list(i),i)=
12459      &        (sh_frac_dist_grad(j)*(-2.0d0)
12460      &        *VofOverlap
12461      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12462      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12463      &       sinphi/sinthet*costhet*costhet_grad(j)
12464      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12465      &       )*wshield
12466
12467        grad_shield_loc(j,ishield_list(i),i)=
12468      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12469      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12470      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12471      &        ))
12472      &        *wshield
12473       enddo
12474 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12475 c     & scale_fac_dist
12476       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12477       enddo
12478       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12479 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12480 c     &  " wshield",wshield
12481 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12482       enddo
12483       return
12484       end
12485 C-----------------------------------------------------------------------
12486 C-----------------------------------------------------------
12487 C This subroutine is to mimic the histone like structure but as well can be
12488 C utilizet to nanostructures (infinit) small modification has to be used to
12489 C make it finite (z gradient at the ends has to be changes as well as the x,y
12490 C gradient has to be modified at the ends
12491 C The energy function is Kihara potential
12492 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12493 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12494 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12495 C simple Kihara potential
12496       subroutine calctube(Etube)
12497        implicit real*8 (a-h,o-z)
12498       include 'DIMENSIONS'
12499       include 'COMMON.GEO'
12500       include 'COMMON.VAR'
12501       include 'COMMON.LOCAL'
12502       include 'COMMON.CHAIN'
12503       include 'COMMON.DERIV'
12504       include 'COMMON.NAMES'
12505       include 'COMMON.INTERACT'
12506       include 'COMMON.IOUNITS'
12507       include 'COMMON.CALC'
12508       include 'COMMON.CONTROL'
12509       include 'COMMON.SPLITELE'
12510       include 'COMMON.SBRIDGE'
12511       double precision tub_r,vectube(3),enetube(maxres*2)
12512       Etube=0.0d0
12513       do i=1,2*nres
12514         enetube(i)=0.0d0
12515       enddo
12516 C first we calculate the distance from tube center
12517 C first sugare-phosphate group for NARES this would be peptide group
12518 C for UNRES
12519       do i=1,nres
12520 C lets ommit dummy atoms for now
12521        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12522 C now calculate distance from center of tube and direction vectors
12523       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12524           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12525       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12526           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12527       vectube(1)=vectube(1)-tubecenter(1)
12528       vectube(2)=vectube(2)-tubecenter(2)
12529
12530 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12531 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12532
12533 C as the tube is infinity we do not calculate the Z-vector use of Z
12534 C as chosen axis
12535       vectube(3)=0.0d0
12536 C now calculte the distance
12537        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12538 C now normalize vector
12539       vectube(1)=vectube(1)/tub_r
12540       vectube(2)=vectube(2)/tub_r
12541 C calculte rdiffrence between r and r0
12542       rdiff=tub_r-tubeR0
12543 C and its 6 power
12544       rdiff6=rdiff**6.0d0
12545 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12546        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12547 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12548 C       print *,rdiff,rdiff6,pep_aa_tube
12549 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12550 C now we calculate gradient
12551        fac=(-12.0d0*pep_aa_tube/rdiff6+
12552      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12553 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12554 C     &rdiff,fac
12555
12556 C now direction of gg_tube vector
12557         do j=1,3
12558         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12559         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12560         enddo
12561         enddo
12562 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12563         do i=1,nres
12564 C Lets not jump over memory as we use many times iti
12565          iti=itype(i)
12566 C lets ommit dummy atoms for now
12567          if ((iti.eq.ntyp1)
12568 C in UNRES uncomment the line below as GLY has no side-chain...
12569 C      .or.(iti.eq.10)
12570      &   ) cycle
12571           vectube(1)=c(1,i+nres)
12572           vectube(1)=mod(vectube(1),boxxsize)
12573           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12574           vectube(2)=c(2,i+nres)
12575           vectube(2)=mod(vectube(2),boxxsize)
12576           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12577
12578       vectube(1)=vectube(1)-tubecenter(1)
12579       vectube(2)=vectube(2)-tubecenter(2)
12580
12581 C as the tube is infinity we do not calculate the Z-vector use of Z
12582 C as chosen axis
12583       vectube(3)=0.0d0
12584 C now calculte the distance
12585        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12586 C now normalize vector
12587       vectube(1)=vectube(1)/tub_r
12588       vectube(2)=vectube(2)/tub_r
12589 C calculte rdiffrence between r and r0
12590       rdiff=tub_r-tubeR0
12591 C and its 6 power
12592       rdiff6=rdiff**6.0d0
12593 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12594        sc_aa_tube=sc_aa_tube_par(iti)
12595        sc_bb_tube=sc_bb_tube_par(iti)
12596        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12597 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12598 C now we calculate gradient
12599        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12600      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12601 C now direction of gg_tube vector
12602          do j=1,3
12603           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12604           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12605          enddo
12606         enddo
12607         do i=1,2*nres
12608           Etube=Etube+enetube(i)
12609         enddo
12610 C        print *,"ETUBE", etube
12611         return
12612         end
12613 C TO DO 1) add to total energy
12614 C       2) add to gradient summation
12615 C       3) add reading parameters (AND of course oppening of PARAM file)
12616 C       4) add reading the center of tube
12617 C       5) add COMMONs
12618 C       6) add to zerograd
12619
12620 C-----------------------------------------------------------------------
12621 C-----------------------------------------------------------
12622 C This subroutine is to mimic the histone like structure but as well can be
12623 C utilizet to nanostructures (infinit) small modification has to be used to
12624 C make it finite (z gradient at the ends has to be changes as well as the x,y
12625 C gradient has to be modified at the ends
12626 C The energy function is Kihara potential
12627 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12628 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12629 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12630 C simple Kihara potential
12631       subroutine calctube2(Etube)
12632        implicit real*8 (a-h,o-z)
12633       include 'DIMENSIONS'
12634       include 'COMMON.GEO'
12635       include 'COMMON.VAR'
12636       include 'COMMON.LOCAL'
12637       include 'COMMON.CHAIN'
12638       include 'COMMON.DERIV'
12639       include 'COMMON.NAMES'
12640       include 'COMMON.INTERACT'
12641       include 'COMMON.IOUNITS'
12642       include 'COMMON.CALC'
12643       include 'COMMON.CONTROL'
12644       include 'COMMON.SPLITELE'
12645       include 'COMMON.SBRIDGE'
12646       double precision tub_r,vectube(3),enetube(maxres*2)
12647       Etube=0.0d0
12648       do i=1,2*nres
12649         enetube(i)=0.0d0
12650       enddo
12651 C first we calculate the distance from tube center
12652 C first sugare-phosphate group for NARES this would be peptide group
12653 C for UNRES
12654       do i=1,nres
12655 C lets ommit dummy atoms for now
12656        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12657 C now calculate distance from center of tube and direction vectors
12658       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12659           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12660       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12661           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12662       vectube(1)=vectube(1)-tubecenter(1)
12663       vectube(2)=vectube(2)-tubecenter(2)
12664
12665 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12666 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12667
12668 C as the tube is infinity we do not calculate the Z-vector use of Z
12669 C as chosen axis
12670       vectube(3)=0.0d0
12671 C now calculte the distance
12672        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12673 C now normalize vector
12674       vectube(1)=vectube(1)/tub_r
12675       vectube(2)=vectube(2)/tub_r
12676 C calculte rdiffrence between r and r0
12677       rdiff=tub_r-tubeR0
12678 C and its 6 power
12679       rdiff6=rdiff**6.0d0
12680 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12681        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12682 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12683 C       print *,rdiff,rdiff6,pep_aa_tube
12684 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12685 C now we calculate gradient
12686        fac=(-12.0d0*pep_aa_tube/rdiff6+
12687      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12688 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12689 C     &rdiff,fac
12690
12691 C now direction of gg_tube vector
12692         do j=1,3
12693         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12694         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12695         enddo
12696         enddo
12697 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12698         do i=1,nres
12699 C Lets not jump over memory as we use many times iti
12700          iti=itype(i)
12701 C lets ommit dummy atoms for now
12702          if ((iti.eq.ntyp1)
12703 C in UNRES uncomment the line below as GLY has no side-chain...
12704      &      .or.(iti.eq.10)
12705      &   ) cycle
12706           vectube(1)=c(1,i+nres)
12707           vectube(1)=mod(vectube(1),boxxsize)
12708           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12709           vectube(2)=c(2,i+nres)
12710           vectube(2)=mod(vectube(2),boxxsize)
12711           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12712
12713       vectube(1)=vectube(1)-tubecenter(1)
12714       vectube(2)=vectube(2)-tubecenter(2)
12715 C THIS FRAGMENT MAKES TUBE FINITE
12716         positi=(mod(c(3,i+nres),boxzsize))
12717         if (positi.le.0) positi=positi+boxzsize
12718 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12719 c for each residue check if it is in lipid or lipid water border area
12720 C       respos=mod(c(3,i+nres),boxzsize)
12721        print *,positi,bordtubebot,buftubebot,bordtubetop
12722        if ((positi.gt.bordtubebot)
12723      & .and.(positi.lt.bordtubetop)) then
12724 C the energy transfer exist
12725         if (positi.lt.buftubebot) then
12726          fracinbuf=1.0d0-
12727      &     ((positi-bordtubebot)/tubebufthick)
12728 C lipbufthick is thickenes of lipid buffore
12729          sstube=sscalelip(fracinbuf)
12730          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12731          print *,ssgradtube, sstube,tubetranene(itype(i))
12732          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12733          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12734      &+ssgradtube*tubetranene(itype(i))
12735          gg_tube(3,i-1)= gg_tube(3,i-1)
12736      &+ssgradtube*tubetranene(itype(i))
12737 C         print *,"doing sccale for lower part"
12738         elseif (positi.gt.buftubetop) then
12739          fracinbuf=1.0d0-
12740      &((bordtubetop-positi)/tubebufthick)
12741          sstube=sscalelip(fracinbuf)
12742          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12743          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12744 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12745 C     &+ssgradtube*tubetranene(itype(i))
12746 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12747 C     &+ssgradtube*tubetranene(itype(i))
12748 C          print *, "doing sscalefor top part",sslip,fracinbuf
12749         else
12750          sstube=1.0d0
12751          ssgradtube=0.0d0
12752          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12753 C         print *,"I am in true lipid"
12754         endif
12755         else
12756 C          sstube=0.0d0
12757 C          ssgradtube=0.0d0
12758         cycle
12759         endif ! if in lipid or buffor
12760 CEND OF FINITE FRAGMENT
12761 C as the tube is infinity we do not calculate the Z-vector use of Z
12762 C as chosen axis
12763       vectube(3)=0.0d0
12764 C now calculte the distance
12765        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12766 C now normalize vector
12767       vectube(1)=vectube(1)/tub_r
12768       vectube(2)=vectube(2)/tub_r
12769 C calculte rdiffrence between r and r0
12770       rdiff=tub_r-tubeR0
12771 C and its 6 power
12772       rdiff6=rdiff**6.0d0
12773 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12774        sc_aa_tube=sc_aa_tube_par(iti)
12775        sc_bb_tube=sc_bb_tube_par(iti)
12776        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12777      &                 *sstube+enetube(i+nres)
12778 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12779 C now we calculate gradient
12780        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12781      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12782 C now direction of gg_tube vector
12783          do j=1,3
12784           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12785           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12786          enddo
12787          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12788      &+ssgradtube*enetube(i+nres)/sstube
12789          gg_tube(3,i-1)= gg_tube(3,i-1)
12790      &+ssgradtube*enetube(i+nres)/sstube
12791
12792         enddo
12793         do i=1,2*nres
12794           Etube=Etube+enetube(i)
12795         enddo
12796 C        print *,"ETUBE", etube
12797         return
12798         end
12799 C TO DO 1) add to total energy
12800 C       2) add to gradient summation
12801 C       3) add reading parameters (AND of course oppening of PARAM file)
12802 C       4) add reading the center of tube
12803 C       5) add COMMONs
12804 C       6) add to zerograd
12805 c----------------------------------------------------------------------------
12806       subroutine e_saxs(Esaxs_constr)
12807       implicit none
12808       include 'DIMENSIONS'
12809 #ifdef MPI
12810       include "mpif.h"
12811       include "COMMON.SETUP"
12812       integer IERR
12813 #endif
12814       include 'COMMON.SBRIDGE'
12815       include 'COMMON.CHAIN'
12816       include 'COMMON.GEO'
12817       include 'COMMON.DERIV'
12818       include 'COMMON.LOCAL'
12819       include 'COMMON.INTERACT'
12820       include 'COMMON.VAR'
12821       include 'COMMON.IOUNITS'
12822 c      include 'COMMON.MD'
12823 #ifdef LANG0
12824 #ifdef FIVEDIAG
12825       include 'COMMON.LANGEVIN.lang0.5diag'
12826 #else
12827       include 'COMMON.LANGEVIN.lang0'
12828 #endif
12829 #else
12830       include 'COMMON.LANGEVIN'
12831 #endif
12832       include 'COMMON.CONTROL'
12833       include 'COMMON.SAXS'
12834       include 'COMMON.NAMES'
12835       include 'COMMON.TIME1'
12836       include 'COMMON.FFIELD'
12837 c
12838       double precision Esaxs_constr
12839       integer i,iint,j,k,l
12840       double precision PgradC(maxSAXS,3,maxres),
12841      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12842 #ifdef MPI
12843       double precision PgradC_(maxSAXS,3,maxres),
12844      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12845 #endif
12846       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12847      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12848      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12849      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12850       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12851       double precision dist,mygauss,mygaussder
12852       external dist
12853       integer llicz,lllicz
12854       double precision time01
12855 c  SAXS restraint penalty function
12856 #ifdef DEBUG
12857       write(iout,*) "------- SAXS penalty function start -------"
12858       write (iout,*) "nsaxs",nsaxs
12859       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12860       write (iout,*) "Psaxs"
12861       do i=1,nsaxs
12862         write (iout,'(i5,e15.5)') i, Psaxs(i)
12863       enddo
12864 #endif
12865 #ifdef TIMING
12866       time01=MPI_Wtime()
12867 #endif
12868       Esaxs_constr = 0.0d0
12869       do k=1,nsaxs
12870         Pcalc(k)=0.0d0
12871         do j=1,nres
12872           do l=1,3
12873             PgradC(k,l,j)=0.0d0
12874             PgradX(k,l,j)=0.0d0
12875           enddo
12876         enddo
12877       enddo
12878 c      lllicz=0
12879       do i=iatsc_s,iatsc_e
12880        if (itype(i).eq.ntyp1) cycle
12881        do iint=1,nint_gr(i)
12882          do j=istart(i,iint),iend(i,iint)
12883            if (itype(j).eq.ntyp1) cycle
12884 #ifdef ALLSAXS
12885            dijCACA=dist(i,j)
12886            dijCASC=dist(i,j+nres)
12887            dijSCCA=dist(i+nres,j)
12888            dijSCSC=dist(i+nres,j+nres)
12889            sigma2CACA=2.0d0/(pstok**2)
12890            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12891            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12892            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12893            do k=1,nsaxs
12894              dk = distsaxs(k)
12895              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12896              if (itype(j).ne.10) then
12897              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12898              else
12899              endif
12900              expCASC = 0.0d0
12901              if (itype(i).ne.10) then
12902              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12903              else
12904              expSCCA = 0.0d0
12905              endif
12906              if (itype(i).ne.10 .and. itype(j).ne.10) then
12907              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12908              else
12909              expSCSC = 0.0d0
12910              endif
12911              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12912 #ifdef DEBUG
12913              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12914 #endif
12915              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12916              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12917              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12918              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12919              do l=1,3
12920 c CA CA
12921                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12922                PgradC(k,l,i) = PgradC(k,l,i)-aux
12923                PgradC(k,l,j) = PgradC(k,l,j)+aux
12924 c CA SC
12925                if (itype(j).ne.10) then
12926                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12927                PgradC(k,l,i) = PgradC(k,l,i)-aux
12928                PgradC(k,l,j) = PgradC(k,l,j)+aux
12929                PgradX(k,l,j) = PgradX(k,l,j)+aux
12930                endif
12931 c SC CA
12932                if (itype(i).ne.10) then
12933                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12934                PgradX(k,l,i) = PgradX(k,l,i)-aux
12935                PgradC(k,l,i) = PgradC(k,l,i)-aux
12936                PgradC(k,l,j) = PgradC(k,l,j)+aux
12937                endif
12938 c SC SC
12939                if (itype(i).ne.10 .and. itype(j).ne.10) then
12940                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12941                PgradC(k,l,i) = PgradC(k,l,i)-aux
12942                PgradC(k,l,j) = PgradC(k,l,j)+aux
12943                PgradX(k,l,i) = PgradX(k,l,i)-aux
12944                PgradX(k,l,j) = PgradX(k,l,j)+aux
12945                endif
12946              enddo ! l
12947            enddo ! k
12948 #else
12949            dijCACA=dist(i,j)
12950            sigma2CACA=scal_rad**2*0.25d0/
12951      &        (restok(itype(j))**2+restok(itype(i))**2)
12952 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12953 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12954 #ifdef MYGAUSS
12955            sigmaCACA=dsqrt(sigma2CACA)
12956            threesig=3.0d0/sigmaCACA
12957 c           llicz=0
12958            do k=1,nsaxs
12959              dk = distsaxs(k)
12960              if (dabs(dijCACA-dk).ge.threesig) cycle
12961 c             llicz=llicz+1
12962 c             lllicz=lllicz+1
12963              aux = sigmaCACA*(dijCACA-dk)
12964              expCACA = mygauss(aux)
12965 c             if (expcaca.eq.0.0d0) cycle
12966              Pcalc(k) = Pcalc(k)+expCACA
12967              CACAgrad = -sigmaCACA*mygaussder(aux)
12968 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12969              do l=1,3
12970                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12971                PgradC(k,l,i) = PgradC(k,l,i)-aux
12972                PgradC(k,l,j) = PgradC(k,l,j)+aux
12973              enddo ! l
12974            enddo ! k
12975 c           write (iout,*) "i",i," j",j," llicz",llicz
12976 #else
12977            IF (saxs_cutoff.eq.0) THEN
12978            do k=1,nsaxs
12979              dk = distsaxs(k)
12980              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12981              Pcalc(k) = Pcalc(k)+expCACA
12982              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12983              do l=1,3
12984                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12985                PgradC(k,l,i) = PgradC(k,l,i)-aux
12986                PgradC(k,l,j) = PgradC(k,l,j)+aux
12987              enddo ! l
12988            enddo ! k
12989            ELSE
12990            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12991            do k=1,nsaxs
12992              dk = distsaxs(k)
12993 c             write (2,*) "ijk",i,j,k
12994              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12995              if (sss2.eq.0.0d0) cycle
12996              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12997              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12998      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12999      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13000      &           sss2,ssgrad2
13001              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13002              Pcalc(k) = Pcalc(k)+expCACA
13003 #ifdef DEBUG
13004              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13005 #endif
13006              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13007      &             ssgrad2*expCACA/sss2
13008              do l=1,3
13009 c CA CA
13010                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13011                PgradC(k,l,i) = PgradC(k,l,i)+aux
13012                PgradC(k,l,j) = PgradC(k,l,j)-aux
13013              enddo ! l
13014            enddo ! k
13015            ENDIF
13016 #endif
13017 #endif
13018          enddo ! j
13019        enddo ! iint
13020       enddo ! i
13021 c#ifdef TIMING
13022 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13023 c#endif
13024 c      write (iout,*) "lllicz",lllicz
13025 c#ifdef TIMING
13026 c      time01=MPI_Wtime()
13027 c#endif
13028 #ifdef MPI
13029       if (nfgtasks.gt.1) then
13030        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13031      &    MPI_SUM,FG_COMM,IERR)
13032 c        if (fg_rank.eq.king) then
13033           do k=1,nsaxs
13034             Pcalc(k) = Pcalc_(k)
13035           enddo
13036 c        endif
13037 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13038 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13039 c        if (fg_rank.eq.king) then
13040 c          do i=1,nres
13041 c            do l=1,3
13042 c              do k=1,nsaxs
13043 c                PgradC(k,l,i) = PgradC_(k,l,i)
13044 c              enddo
13045 c            enddo
13046 c          enddo
13047 c        endif
13048 #ifdef ALLSAXS
13049 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13050 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13051 c        if (fg_rank.eq.king) then
13052 c          do i=1,nres
13053 c            do l=1,3
13054 c              do k=1,nsaxs
13055 c                PgradX(k,l,i) = PgradX_(k,l,i)
13056 c              enddo
13057 c            enddo
13058 c          enddo
13059 c        endif
13060 #endif
13061       endif
13062 #endif
13063       Cnorm = 0.0d0
13064       do k=1,nsaxs
13065         Cnorm = Cnorm + Pcalc(k)
13066       enddo
13067 #ifdef MPI
13068       if (fg_rank.eq.king) then
13069 #endif
13070       Esaxs_constr = dlog(Cnorm)-wsaxs0
13071       do k=1,nsaxs
13072         if (Pcalc(k).gt.0.0d0)
13073      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13074 #ifdef DEBUG
13075         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13076 #endif
13077       enddo
13078 #ifdef DEBUG
13079       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13080 #endif
13081 #ifdef MPI
13082       endif
13083 #endif
13084       gsaxsC=0.0d0
13085       gsaxsX=0.0d0
13086       do i=nnt,nct
13087         do l=1,3
13088           auxC=0.0d0
13089           auxC1=0.0d0
13090           auxX=0.0d0
13091           auxX1=0.d0
13092           do k=1,nsaxs
13093             if (Pcalc(k).gt.0)
13094      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13095             auxC1 = auxC1+PgradC(k,l,i)
13096 #ifdef ALLSAXS
13097             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13098             auxX1 = auxX1+PgradX(k,l,i)
13099 #endif
13100           enddo
13101           gsaxsC(l,i) = auxC - auxC1/Cnorm
13102 #ifdef ALLSAXS
13103           gsaxsX(l,i) = auxX - auxX1/Cnorm
13104 #endif
13105 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13106 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13107 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13108 c     *     " gradX",wsaxs*gsaxsX(l,i)
13109         enddo
13110       enddo
13111 #ifdef TIMING
13112       time_SAXS=time_SAXS+MPI_Wtime()-time01
13113 #endif
13114 #ifdef DEBUG
13115       write (iout,*) "gsaxsc"
13116       do i=nnt,nct
13117         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13118       enddo
13119 #endif
13120 #ifdef MPI
13121 c      endif
13122 #endif
13123       return
13124       end
13125 c----------------------------------------------------------------------------
13126       subroutine e_saxsC(Esaxs_constr)
13127       implicit none
13128       include 'DIMENSIONS'
13129 #ifdef MPI
13130       include "mpif.h"
13131       include "COMMON.SETUP"
13132       integer IERR
13133 #endif
13134       include 'COMMON.SBRIDGE'
13135       include 'COMMON.CHAIN'
13136       include 'COMMON.GEO'
13137       include 'COMMON.DERIV'
13138       include 'COMMON.LOCAL'
13139       include 'COMMON.INTERACT'
13140       include 'COMMON.VAR'
13141       include 'COMMON.IOUNITS'
13142 c      include 'COMMON.MD'
13143 #ifdef LANG0
13144 #ifdef FIVEDIAG
13145       include 'COMMON.LANGEVIN.lang0.5diag'
13146 #else
13147       include 'COMMON.LANGEVIN.lang0'
13148 #endif
13149 #else
13150       include 'COMMON.LANGEVIN'
13151 #endif
13152       include 'COMMON.CONTROL'
13153       include 'COMMON.SAXS'
13154       include 'COMMON.NAMES'
13155       include 'COMMON.TIME1'
13156       include 'COMMON.FFIELD'
13157 c
13158       double precision Esaxs_constr
13159       integer i,iint,j,k,l
13160       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13161 #ifdef MPI
13162       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13163 #endif
13164       double precision dk,dijCASPH,dijSCSPH,
13165      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13166      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13167      & auxX,auxX1,Cnorm
13168 c  SAXS restraint penalty function
13169 #ifdef DEBUG
13170       write(iout,*) "------- SAXS penalty function start -------"
13171       write (iout,*) "nsaxs",nsaxs
13172
13173       do i=nnt,nct
13174         print *,MyRank,"C",i,(C(j,i),j=1,3)
13175       enddo
13176       do i=nnt,nct
13177         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13178       enddo
13179 #endif
13180       Esaxs_constr = 0.0d0
13181       logPtot=0.0d0
13182       do j=isaxs_start,isaxs_end
13183         Pcalc=0.0d0
13184         do i=1,nres
13185           do l=1,3
13186             PgradC(l,i)=0.0d0
13187             PgradX(l,i)=0.0d0
13188           enddo
13189         enddo
13190         do i=nnt,nct
13191           if (itype(i).eq.ntyp1) cycle
13192           dijCASPH=0.0d0
13193           dijSCSPH=0.0d0
13194           do l=1,3
13195             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13196           enddo
13197           if (itype(i).ne.10) then
13198           do l=1,3
13199             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13200           enddo
13201           endif
13202           sigma2CA=2.0d0/pstok**2
13203           sigma2SC=4.0d0/restok(itype(i))**2
13204           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13205           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13206           Pcalc = Pcalc+expCASPH+expSCSPH
13207 #ifdef DEBUG
13208           write(*,*) "processor i j Pcalc",
13209      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13210 #endif
13211           CASPHgrad = sigma2CA*expCASPH
13212           SCSPHgrad = sigma2SC*expSCSPH
13213           do l=1,3
13214             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13215             PgradX(l,i) = PgradX(l,i) + aux
13216             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13217           enddo ! l
13218         enddo ! i
13219         do i=nnt,nct
13220           do l=1,3
13221             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13222             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13223           enddo
13224         enddo
13225         logPtot = logPtot - dlog(Pcalc)
13226 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13227 c     &    " logPtot",logPtot
13228       enddo ! j
13229 #ifdef MPI
13230       if (nfgtasks.gt.1) then
13231 c        write (iout,*) "logPtot before reduction",logPtot
13232         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13233      &    MPI_SUM,king,FG_COMM,IERR)
13234         logPtot = logPtot_
13235 c        write (iout,*) "logPtot after reduction",logPtot
13236         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13237      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13238         if (fg_rank.eq.king) then
13239           do i=1,nres
13240             do l=1,3
13241               gsaxsC(l,i) = gsaxsC_(l,i)
13242             enddo
13243           enddo
13244         endif
13245         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13246      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13247         if (fg_rank.eq.king) then
13248           do i=1,nres
13249             do l=1,3
13250               gsaxsX(l,i) = gsaxsX_(l,i)
13251             enddo
13252           enddo
13253         endif
13254       endif
13255 #endif
13256       Esaxs_constr = logPtot
13257       return
13258       end
13259 c----------------------------------------------------------------------------
13260       double precision function sscale2(r,r_cut,r0,rlamb)
13261       implicit none
13262       double precision r,gamm,r_cut,r0,rlamb,rr
13263       rr = dabs(r-r0)
13264 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13265 c      write (2,*) "rr",rr
13266       if(rr.lt.r_cut-rlamb) then
13267         sscale2=1.0d0
13268       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13269         gamm=(rr-(r_cut-rlamb))/rlamb
13270         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13271       else
13272         sscale2=0d0
13273       endif
13274       return
13275       end
13276 C-----------------------------------------------------------------------
13277       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13278       implicit none
13279       double precision r,gamm,r_cut,r0,rlamb,rr
13280       rr = dabs(r-r0)
13281       if(rr.lt.r_cut-rlamb) then
13282         sscalgrad2=0.0d0
13283       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13284         gamm=(rr-(r_cut-rlamb))/rlamb
13285         if (r.ge.r0) then
13286           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13287         else
13288           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13289         endif
13290       else
13291         sscalgrad2=0.0d0
13292       endif
13293       return
13294       end
13295 c------------------------------------------------------------------------
13296       double precision function boxshift(x,boxsize)
13297       implicit none
13298       double precision x,boxsize
13299       double precision xtemp
13300       xtemp=dmod(x,boxsize)
13301       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13302         boxshift=xtemp-boxsize
13303       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13304         boxshift=xtemp+boxsize
13305       else
13306         boxshift=xtemp
13307       endif
13308       return
13309       end
13310 c--------------------------------------------------------------------------
13311       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13312       include 'DIMENSIONS'
13313       include 'COMMON.CHAIN'
13314       integer xshift,yshift,zshift,subchap
13315       double precision dist_init,xj_safe,yj_safe,zj_safe,
13316      & xj_temp,yj_temp,zj_temp,dist_temp
13317       xj_safe=xj
13318       yj_safe=yj
13319       zj_safe=zj
13320       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13321       subchap=0
13322       do xshift=-1,1
13323         do yshift=-1,1
13324           do zshift=-1,1
13325             xj=xj_safe+xshift*boxxsize
13326             yj=yj_safe+yshift*boxysize
13327             zj=zj_safe+zshift*boxzsize
13328             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13329             if(dist_temp.lt.dist_init) then
13330               dist_init=dist_temp
13331               xj_temp=xj
13332               yj_temp=yj
13333               zj_temp=zj
13334               subchap=1
13335             endif
13336           enddo
13337         enddo
13338       enddo
13339       if (subchap.eq.1) then
13340         xj=xj_temp-xi
13341         yj=yj_temp-yi
13342         zj=zj_temp-zi
13343       else
13344         xj=xj_safe-xi
13345         yj=yj_safe-yi
13346         zj=zj_safe-zi
13347       endif
13348       return
13349       end
13350 c--------------------------------------------------------------------------
13351       subroutine to_box(xi,yi,zi)
13352       implicit none
13353       include 'DIMENSIONS'
13354       include 'COMMON.CHAIN'
13355       double precision xi,yi,zi
13356       xi=dmod(xi,boxxsize)
13357       if (xi.lt.0.0d0) xi=xi+boxxsize
13358       yi=dmod(yi,boxysize)
13359       if (yi.lt.0.0d0) yi=yi+boxysize
13360       zi=dmod(zi,boxzsize)
13361       if (zi.lt.0.0d0) zi=zi+boxzsize
13362       return
13363       end
13364 c--------------------------------------------------------------------------
13365       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13366       implicit none
13367       include 'DIMENSIONS'
13368       include 'COMMON.IOUNITS'
13369       include 'COMMON.CHAIN'
13370       double precision xi,yi,zi,sslipi,ssgradlipi
13371       double precision fracinbuf
13372       double precision sscalelip,sscagradlip
13373 #ifdef DEBUG
13374       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13375       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13376       write (iout,*) "xi yi zi",xi,yi,zi
13377 #endif
13378       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13379 C the energy transfer exist
13380         if (zi.lt.buflipbot) then
13381 C what fraction I am in
13382           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13383 C lipbufthick is thickenes of lipid buffore
13384           sslipi=sscalelip(fracinbuf)
13385           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13386         elseif (zi.gt.bufliptop) then
13387           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13388           sslipi=sscalelip(fracinbuf)
13389           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13390         else
13391           sslipi=1.0d0
13392           ssgradlipi=0.0
13393         endif
13394       else
13395         sslipi=0.0d0
13396         ssgradlipi=0.0
13397       endif
13398 #ifdef DEBUG
13399       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
13400 #endif
13401       return
13402       end