source/unres/src_MD-M-SAXS-homology/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   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 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28       include 'COMMON.TORCNSTR'
  29 #ifdef MPI
  30 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  31 c     & " nfgtasks",nfgtasks
  32       if (nfgtasks.gt.1) then
  33         time00=MPI_Wtime()
  34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  35         if (fg_rank.eq.0) then
  36           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  37 c          print *,"Processor",myrank," BROADCAST iorder"
  38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  39 C FG slaves as WEIGHTS array.
  40           weights_(1)=wsc
  41           weights_(2)=wscp
  42           weights_(3)=welec
  43           weights_(4)=wcorr
  44           weights_(5)=wcorr5
  45           weights_(6)=wcorr6
  46           weights_(7)=wel_loc
  47           weights_(8)=wturn3
  48           weights_(9)=wturn4
  49           weights_(10)=wturn6
  50           weights_(11)=wang
  51           weights_(12)=wscloc
  52           weights_(13)=wtor
  53           weights_(14)=wtor_d
  54           weights_(15)=wstrain
  55           weights_(16)=wvdwpp
  56           weights_(17)=wbond
  57           weights_(18)=scal14
  58           weights_(21)=wsccor
  59           weights_(22)=wtube
  60           weights_(26)=wsaxs
  61           weights_(28)=wdfa_dist
  62           weights_(29)=wdfa_tor
  63           weights_(30)=wdfa_nei
  64           weights_(31)=wdfa_beta
  65 C FG Master broadcasts the WEIGHTS_ array
  66           call MPI_Bcast(weights_(1),n_ene,
  67      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  68         else
  69 C FG slaves receive the WEIGHTS array
  70           call MPI_Bcast(weights(1),n_ene,
  71      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  72           wsc=weights(1)
  73           wscp=weights(2)
  74           welec=weights(3)
  75           wcorr=weights(4)
  76           wcorr5=weights(5)
  77           wcorr6=weights(6)
  78           wel_loc=weights(7)
  79           wturn3=weights(8)
  80           wturn4=weights(9)
  81           wturn6=weights(10)
  82           wang=weights(11)
  83           wscloc=weights(12)
  84           wtor=weights(13)
  85           wtor_d=weights(14)
  86           wstrain=weights(15)
  87           wvdwpp=weights(16)
  88           wbond=weights(17)
  89           scal14=weights(18)
  90           wsccor=weights(21)
  91           wtube=weights(22)
  92           wsaxs=weights(26)
  93           wdfa_dist=weights_(28)
  94           wdfa_tor=weights_(29)
  95           wdfa_nei=weights_(30)
  96           wdfa_beta=weights_(31)
  97         endif
  98         time_Bcast=time_Bcast+MPI_Wtime()-time00
  99         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 100 c        call chainbuild_cart
 101       endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 109 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 110 #else
 111 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 112 c        call int_from_cart1(.false.)
 113 c      endif
 114 #endif
 115 #ifdef TIMING
 116       time00=MPI_Wtime()
 117 #endif
 118 C
 119 C Compute the side-chain and electrostatic interaction energy
 120 C
 121 C      print *,ipot
 122       goto (101,102,103,104,105,106) ipot
 123 C Lennard-Jones potential.
 124   101 call elj(evdw)
 125 cd    print '(a)','Exit ELJ'
 126       goto 107
 127 C Lennard-Jones-Kihara potential (shifted).
 128   102 call eljk(evdw)
 129       goto 107
 130 C Berne-Pechukas potential (dilated LJ, angular dependence).
 131   103 call ebp(evdw)
 132       goto 107
 133 C Gay-Berne potential (shifted LJ, angular dependence).
 134   104 call egb(evdw)
 135 C      print *,"bylem w egb"
 136       goto 107
 137 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 138   105 call egbv(evdw)
 139       goto 107
 140 C Soft-sphere potential
 141   106 call e_softsphere(evdw)
 142 C
 143 C Calculate electrostatic (H-bonding) energy of the main chain.
 144 C
 145   107 continue
 146 #ifdef DFA
 147 C     BARTEK for dfa test!
 148       if (wdfa_dist.gt.0) then
 149         call edfad(edfadis)
 150       else
 151         edfadis=0
 152       endif
 153 c      print*, 'edfad is finished!', edfadis
 154       if (wdfa_tor.gt.0) then
 155         call edfat(edfator)
 156       else
 157         edfator=0
 158       endif
 159 c      print*, 'edfat is finished!', edfator
 160       if (wdfa_nei.gt.0) then
 161         call edfan(edfanei)
 162       else
 163         edfanei=0
 164       endif
 165 c      print*, 'edfan is finished!', edfanei
 166       if (wdfa_beta.gt.0) then
 167         call edfab(edfabet)
 168       else
 169         edfabet=0
 170       endif
 171 #endif
 172 cmc
 173 cmc Sep-06: egb takes care of dynamic ss bonds too
 174 cmc
 175 c      if (dyn_ss) call dyn_set_nss
 176
 177 c      print *,"Processor",myrank," computed USCSC"
 178 #ifdef TIMING
 179       time01=MPI_Wtime()
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183       time_vec=time_vec+MPI_Wtime()-time01
 184 #endif
 185 C Introduction of shielding effect first for each peptide group
 186 C the shielding factor is set this factor is describing how each
 187 C peptide group is shielded by side-chains
 188 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 189 C      write (iout,*) "shield_mode",shield_mode
 190       if (shield_mode.eq.1) then
 191        call set_shield_fac
 192       else if  (shield_mode.eq.2) then
 193        call set_shield_fac2
 194       endif
 195 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 196       if (ipot.lt.6) then
 197 #ifdef SPLITELE
 198          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 199      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 200      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 201      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 202 #else
 203          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 204      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 205      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 206      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 207 #endif
 208             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 209          else
 210             ees=0.0d0
 211             evdw1=0.0d0
 212             eel_loc=0.0d0
 213             eello_turn3=0.0d0
 214             eello_turn4=0.0d0
 215          endif
 216       else
 217         write (iout,*) "Soft-spheer ELEC potential"
 218 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 219 c     &   eello_turn4)
 220       endif
 221 c#ifdef TIMING
 222 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 223 c#endif
 224 c      print *,"Processor",myrank," computed UELEC"
 225 C
 226 C Calculate excluded-volume interaction energy between peptide groups
 227 C and side chains.
 228 C
 229       if (ipot.lt.6) then
 230        if(wscp.gt.0d0) then
 231         call escp(evdw2,evdw2_14)
 232        else
 233         evdw2=0
 234         evdw2_14=0
 235        endif
 236       else
 237 c        write (iout,*) "Soft-sphere SCP potential"
 238         call escp_soft_sphere(evdw2,evdw2_14)
 239       endif
 240 c
 241 c Calculate the bond-stretching energy
 242 c
 243       call ebond(estr)
 244 C
 245 C Calculate the disulfide-bridge and other energy and the contributions
 246 C from other distance constraints.
 247 cd      write (iout,*) 'Calling EHPB'
 248       call edis(ehpb)
 249 cd    print *,'EHPB exitted succesfully.'
 250 C
 251 C Calculate the virtual-bond-angle energy.
 252 C
 253       if (wang.gt.0d0) then
 254        if (tor_mode.eq.0) then
 255          call ebend(ebe)
 256        else
 257 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 258 C energy function
 259          call ebend_kcc(ebe)
 260        endif
 261       else
 262         ebe=0.0d0
 263       endif
 264       ethetacnstr=0.0d0
 265       if (with_theta_constr) call etheta_constr(ethetacnstr)
 266 c      print *,"Processor",myrank," computed UB"
 267 C
 268 C Calculate the SC local energy.
 269 C
 270 C      print *,"TU DOCHODZE?"
 271       call esc(escloc)
 272 c      print *,"Processor",myrank," computed USC"
 273 C
 274 C Calculate the virtual-bond torsional energy.
 275 C
 276 cd    print *,'nterm=',nterm
 277 C      print *,"tor",tor_mode
 278       if (wtor.gt.0.0d0) then
 279          if (tor_mode.eq.0) then
 280            call etor(etors)
 281          else
 282 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 283 C energy function
 284            call etor_kcc(etors)
 285          endif
 286       else
 287         etors=0.0d0
 288       endif
 289       edihcnstr=0.0d0
 290       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 291 c      print *,"Processor",myrank," computed Utor"
 292       if (constr_homology.ge.1) then
 293         call e_modeller(ehomology_constr)
 294 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 295 c     &  'Processor',fg_rank,' CG group',kolor,
 296 c     &  ' absolute rank',MyRank
 297       else
 298         ehomology_constr=0.0d0
 299       endif
 300 C
 301 C 6/23/01 Calculate double-torsional energy
 302 C
 303       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 304         call etor_d(etors_d)
 305       else
 306         etors_d=0
 307       endif
 308 c      print *,"Processor",myrank," computed Utord"
 309 C
 310 C 21/5/07 Calculate local sicdechain correlation energy
 311 C
 312       if (wsccor.gt.0.0d0) then
 313         call eback_sc_corr(esccor)
 314       else
 315         esccor=0.0d0
 316       endif
 317 C      print *,"PRZED MULIt"
 318 c      print *,"Processor",myrank," computed Usccorr"
 319 C
 320 C 12/1/95 Multi-body terms
 321 C
 322       n_corr=0
 323       n_corr1=0
 324       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 325      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 326          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 327 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 328 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 329 c        call flush(iout)
 330       else
 331          ecorr=0.0d0
 332          ecorr5=0.0d0
 333          ecorr6=0.0d0
 334          eturn6=0.0d0
 335       endif
 336       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 337 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 338 c     &     n_corr,n_corr1
 339 c         call flush(iout)
 340          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 341 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 342 c     &     n_corr1
 343 c         call flush(iout)
 344       endif
 345 c      print *,"Processor",myrank," computed Ucorr"
 346 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 347       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 348         call e_saxs(Esaxs_constr)
 349 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 350       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 351         call e_saxsC(Esaxs_constr)
 352 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 353       else
 354         Esaxs_constr = 0.0d0
 355       endif
 356 C
 357 C If performing constraint dynamics, call the constraint energy
 358 C  after the equilibration time
 359 c      if(usampl.and.totT.gt.eq_time) then
 360 c      write (iout,*) "usampl",usampl
 361       if(usampl) then
 362          call EconstrQ
 363          if (loc_qlike) then
 364            call Econstr_back_qlike
 365          else
 366            call Econstr_back
 367          endif
 368       else
 369          Uconst=0.0d0
 370          Uconst_back=0.0d0
 371       endif
 372 C 01/27/2015 added by adasko
 373 C the energy component below is energy transfer into lipid environment
 374 C based on partition function
 375 C      print *,"przed lipidami"
 376       if (wliptran.gt.0) then
 377         call Eliptransfer(eliptran)
 378       endif
 379 C      print *,"za lipidami"
 380       if (AFMlog.gt.0) then
 381         call AFMforce(Eafmforce)
 382       else if (selfguide.gt.0) then
 383         call AFMvel(Eafmforce)
 384       endif
 385       if (TUBElog.eq.1) then
 386 C      print *,"just before call"
 387         call calctube(Etube)
 388        elseif (TUBElog.eq.2) then
 389         call calctube2(Etube)
 390        else
 391        Etube=0.0d0
 392        endif
 393
 394 #ifdef TIMING
 395       time_enecalc=time_enecalc+MPI_Wtime()-time00
 396 #endif
 397 c      print *,"Processor",myrank," computed Uconstr"
 398 #ifdef TIMING
 399       time00=MPI_Wtime()
 400 #endif
 401 c
 402 C Sum the energies
 403 C
 404       energia(1)=evdw
 405 #ifdef SCP14
 406       energia(2)=evdw2-evdw2_14
 407       energia(18)=evdw2_14
 408 #else
 409       energia(2)=evdw2
 410       energia(18)=0.0d0
 411 #endif
 412 #ifdef SPLITELE
 413       energia(3)=ees
 414       energia(16)=evdw1
 415 #else
 416       energia(3)=ees+evdw1
 417       energia(16)=0.0d0
 418 #endif
 419       energia(4)=ecorr
 420       energia(5)=ecorr5
 421       energia(6)=ecorr6
 422       energia(7)=eel_loc
 423       energia(8)=eello_turn3
 424       energia(9)=eello_turn4
 425       energia(10)=eturn6
 426       energia(11)=ebe
 427       energia(12)=escloc
 428       energia(13)=etors
 429       energia(14)=etors_d
 430       energia(15)=ehpb
 431       energia(19)=edihcnstr
 432       energia(17)=estr
 433       energia(20)=Uconst+Uconst_back
 434       energia(21)=esccor
 435       energia(22)=eliptran
 436       energia(23)=Eafmforce
 437       energia(24)=ethetacnstr
 438       energia(25)=Etube
 439       energia(26)=Esaxs_constr
 440       energia(27)=ehomology_constr
 441       energia(28)=edfadis
 442       energia(29)=edfator
 443       energia(30)=edfanei
 444       energia(31)=edfabet
 445 c      write (iout,*) "esaxs_constr",energia(26)
 446 c    Here are the energies showed per procesor if the are more processors
 447 c    per molecule then we sum it up in sum_energy subroutine
 448 c      print *," Processor",myrank," calls SUM_ENERGY"
 449       call sum_energy(energia,.true.)
 450 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 451       if (dyn_ss) call dyn_set_nss
 452 c      print *," Processor",myrank," left SUM_ENERGY"
 453 #ifdef TIMING
 454       time_sumene=time_sumene+MPI_Wtime()-time00
 455 #endif
 456       return
 457       end
 458 c-------------------------------------------------------------------------------
 459       subroutine sum_energy(energia,reduce)
 460       implicit real*8 (a-h,o-z)
 461       include 'DIMENSIONS'
 462 #ifndef ISNAN
 463       external proc_proc
 464 #ifdef WINPGI
 465 cMS$ATTRIBUTES C ::  proc_proc
 466 #endif
 467 #endif
 468 #ifdef MPI
 469       include "mpif.h"
 470 #endif
 471       include 'COMMON.SETUP'
 472       include 'COMMON.IOUNITS'
 473       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 474       include 'COMMON.FFIELD'
 475       include 'COMMON.DERIV'
 476       include 'COMMON.INTERACT'
 477       include 'COMMON.SBRIDGE'
 478       include 'COMMON.CHAIN'
 479       include 'COMMON.VAR'
 480       include 'COMMON.CONTROL'
 481       include 'COMMON.TIME1'
 482       logical reduce
 483 #ifdef MPI
 484       if (nfgtasks.gt.1 .and. reduce) then
 485 #ifdef DEBUG
 486         write (iout,*) "energies before REDUCE"
 487         call enerprint(energia)
 488         call flush(iout)
 489 #endif
 490         do i=0,n_ene
 491           enebuff(i)=energia(i)
 492         enddo
 493         time00=MPI_Wtime()
 494         call MPI_Barrier(FG_COMM,IERR)
 495         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 496         time00=MPI_Wtime()
 497         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 498      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 499 #ifdef DEBUG
 500         write (iout,*) "energies after REDUCE"
 501         call enerprint(energia)
 502         call flush(iout)
 503 #endif
 504         time_Reduce=time_Reduce+MPI_Wtime()-time00
 505       endif
 506       if (fg_rank.eq.0) then
 507 #endif
 508       evdw=energia(1)
 509 #ifdef SCP14
 510       evdw2=energia(2)+energia(18)
 511       evdw2_14=energia(18)
 512 #else
 513       evdw2=energia(2)
 514 #endif
 515 #ifdef SPLITELE
 516       ees=energia(3)
 517       evdw1=energia(16)
 518 #else
 519       ees=energia(3)
 520       evdw1=0.0d0
 521 #endif
 522       ecorr=energia(4)
 523       ecorr5=energia(5)
 524       ecorr6=energia(6)
 525       eel_loc=energia(7)
 526       eello_turn3=energia(8)
 527       eello_turn4=energia(9)
 528       eturn6=energia(10)
 529       ebe=energia(11)
 530       escloc=energia(12)
 531       etors=energia(13)
 532       etors_d=energia(14)
 533       ehpb=energia(15)
 534       edihcnstr=energia(19)
 535       estr=energia(17)
 536       Uconst=energia(20)
 537       esccor=energia(21)
 538       eliptran=energia(22)
 539       Eafmforce=energia(23)
 540       ethetacnstr=energia(24)
 541       Etube=energia(25)
 542       esaxs_constr=energia(26)
 543       ehomology_constr=energia(27)
 544       edfadis=energia(28)
 545       edfator=energia(29)
 546       edfanei=energia(30)
 547       edfabet=energia(31)
 548 #ifdef SPLITELE
 549       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 550      & +wang*ebe+wtor*etors+wscloc*escloc
 551      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 552      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 553      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 554      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 555      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 556      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 557      & +wdfa_beta*edfabet
 558 #else
 559       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 560      & +wang*ebe+wtor*etors+wscloc*escloc
 561      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 562      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 563      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 564      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 565      & +Eafmforce
 566      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 567      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 568      & +wdfa_beta*edfabet
 569 #endif
 570       energia(0)=etot
 571 c detecting NaNQ
 572 #ifdef ISNAN
 573 #ifdef AIX
 574       if (isnan(etot).ne.0) energia(0)=1.0d+99
 575 #else
 576       if (isnan(etot)) energia(0)=1.0d+99
 577 #endif
 578 #else
 579       i=0
 580 #ifdef WINPGI
 581       idumm=proc_proc(etot,i)
 582 #else
 583       call proc_proc(etot,i)
 584 #endif
 585       if(i.eq.1)energia(0)=1.0d+99
 586 #endif
 587 #ifdef MPI
 588       endif
 589 #endif
 590       return
 591       end
 592 c-------------------------------------------------------------------------------
 593       subroutine sum_gradient
 594       implicit real*8 (a-h,o-z)
 595       include 'DIMENSIONS'
 596 #ifndef ISNAN
 597       external proc_proc
 598 #ifdef WINPGI
 599 cMS$ATTRIBUTES C ::  proc_proc
 600 #endif
 601 #endif
 602 #ifdef MPI
 603       include 'mpif.h'
 604 #endif
 605       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 606      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 607      & ,gloc_scbuf(3,-1:maxres)
 608       include 'COMMON.SETUP'
 609       include 'COMMON.IOUNITS'
 610       include 'COMMON.FFIELD'
 611       include 'COMMON.DERIV'
 612       include 'COMMON.INTERACT'
 613       include 'COMMON.SBRIDGE'
 614       include 'COMMON.CHAIN'
 615       include 'COMMON.VAR'
 616       include 'COMMON.CONTROL'
 617       include 'COMMON.TIME1'
 618       include 'COMMON.MAXGRAD'
 619       include 'COMMON.SCCOR'
 620       include 'COMMON.MD'
 621 #ifdef TIMING
 622       time01=MPI_Wtime()
 623 #endif
 624 #ifdef DEBUG
 625       write (iout,*) "sum_gradient gvdwc, gvdwx"
 626       do i=1,nres
 627         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 628      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef DEBUG
 633       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 634       do i=0,nres
 635         write (iout,'(i3,3e15.5,5x,3e15.5)')
 636      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640 #ifdef MPI
 641 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 642         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 643      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 644 #endif
 645 C
 646 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 647 C            in virtual-bond-vector coordinates
 648 C
 649 #ifdef DEBUG
 650 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 651 c      do i=1,nres-1
 652 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 653 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 654 c      enddo
 655 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 656 c      do i=1,nres-1
 657 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 658 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 659 c      enddo
 660       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 661       do i=1,nres
 662         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 663      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 664      &   g_corr5_loc(i)
 665       enddo
 666       call flush(iout)
 667 #endif
 668 #ifdef DEBUG
 669       write (iout,*) "gsaxsc"
 670       do i=1,nres
 671         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 672       enddo
 673       call flush(iout)
 674 #endif
 675 #ifdef SPLITELE
 676       do i=0,nct
 677         do j=1,3
 678           gradbufc(j,i)=wsc*gvdwc(j,i)+
 679      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 680      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 681      &                wel_loc*gel_loc_long(j,i)+
 682      &                wcorr*gradcorr_long(j,i)+
 683      &                wcorr5*gradcorr5_long(j,i)+
 684      &                wcorr6*gradcorr6_long(j,i)+
 685      &                wturn6*gcorr6_turn_long(j,i)+
 686      &                wstrain*ghpbc(j,i)
 687      &                +wliptran*gliptranc(j,i)
 688      &                +gradafm(j,i)
 689      &                +welec*gshieldc(j,i)
 690      &                +wcorr*gshieldc_ec(j,i)
 691      &                +wturn3*gshieldc_t3(j,i)
 692      &                +wturn4*gshieldc_t4(j,i)
 693      &                +wel_loc*gshieldc_ll(j,i)
 694      &                +wtube*gg_tube(j,i)
 695      &                +wsaxs*gsaxsc(j,i)
 696         enddo
 697       enddo
 698 #else
 699       do i=0,nct
 700         do j=1,3
 701           gradbufc(j,i)=wsc*gvdwc(j,i)+
 702      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 703      &                welec*gelc_long(j,i)+
 704      &                wbond*gradb(j,i)+
 705      &                wel_loc*gel_loc_long(j,i)+
 706      &                wcorr*gradcorr_long(j,i)+
 707      &                wcorr5*gradcorr5_long(j,i)+
 708      &                wcorr6*gradcorr6_long(j,i)+
 709      &                wturn6*gcorr6_turn_long(j,i)+
 710      &                wstrain*ghpbc(j,i)
 711      &                +wliptran*gliptranc(j,i)
 712      &                +gradafm(j,i)
 713      &                 +welec*gshieldc(j,i)
 714      &                 +wcorr*gshieldc_ec(j,i)
 715      &                 +wturn4*gshieldc_t4(j,i)
 716      &                 +wel_loc*gshieldc_ll(j,i)
 717      &                +wtube*gg_tube(j,i)
 718      &                +wsaxs*gsaxsc(j,i)
 719         enddo
 720       enddo
 721 #endif
 722       do i=1,nct
 723         do j=1,3
 724           gradbufc(j,i)=gradbufc(j,i)+
 725      &                wdfa_dist*gdfad(j,i)+
 726      &                wdfa_tor*gdfat(j,i)+
 727      &                wdfa_nei*gdfan(j,i)+
 728      &                wdfa_beta*gdfab(j,i)
 729         enddo
 730       enddo
 731 #ifdef DEBUG
 732       write (iout,*) "gradc from gradbufc"
 733       do i=1,nres
 734         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 735       enddo
 736       call flush(iout)
 737 #endif
 738 #ifdef MPI
 739       if (nfgtasks.gt.1) then
 740       time00=MPI_Wtime()
 741 #ifdef DEBUG
 742       write (iout,*) "gradbufc before allreduce"
 743       do i=1,nres
 744         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 745       enddo
 746       call flush(iout)
 747 #endif
 748       do i=0,nres
 749         do j=1,3
 750           gradbufc_sum(j,i)=gradbufc(j,i)
 751         enddo
 752       enddo
 753 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 754 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 755 c      time_reduce=time_reduce+MPI_Wtime()-time00
 756 #ifdef DEBUG
 757 c      write (iout,*) "gradbufc_sum after allreduce"
 758 c      do i=1,nres
 759 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 760 c      enddo
 761 c      call flush(iout)
 762 #endif
 763 #ifdef TIMING
 764 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 765 #endif
 766       do i=nnt,nres
 767         do k=1,3
 768           gradbufc(k,i)=0.0d0
 769         enddo
 770       enddo
 771 #ifdef DEBUG
 772       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 773       write (iout,*) (i," jgrad_start",jgrad_start(i),
 774      &                  " jgrad_end  ",jgrad_end(i),
 775      &                  i=igrad_start,igrad_end)
 776 #endif
 777 c
 778 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 779 c do not parallelize this part.
 780 c
 781 c      do i=igrad_start,igrad_end
 782 c        do j=jgrad_start(i),jgrad_end(i)
 783 c          do k=1,3
 784 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 785 c          enddo
 786 c        enddo
 787 c      enddo
 788       do j=1,3
 789         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 790       enddo
 791       do i=nres-2,-1,-1
 792         do j=1,3
 793           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 794         enddo
 795       enddo
 796 #ifdef DEBUG
 797       write (iout,*) "gradbufc after summing"
 798       do i=1,nres
 799         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 800       enddo
 801       call flush(iout)
 802 #endif
 803       else
 804 #endif
 805 #ifdef DEBUG
 806       write (iout,*) "gradbufc"
 807       do i=1,nres
 808         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 809       enddo
 810       call flush(iout)
 811 #endif
 812       do i=-1,nres
 813         do j=1,3
 814           gradbufc_sum(j,i)=gradbufc(j,i)
 815           gradbufc(j,i)=0.0d0
 816         enddo
 817       enddo
 818       do j=1,3
 819         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 820       enddo
 821       do i=nres-2,-1,-1
 822         do j=1,3
 823           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 824         enddo
 825       enddo
 826 c      do i=nnt,nres-1
 827 c        do k=1,3
 828 c          gradbufc(k,i)=0.0d0
 829 c        enddo
 830 c        do j=i+1,nres
 831 c          do k=1,3
 832 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 833 c          enddo
 834 c        enddo
 835 c      enddo
 836 #ifdef DEBUG
 837       write (iout,*) "gradbufc after summing"
 838       do i=1,nres
 839         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 840       enddo
 841       call flush(iout)
 842 #endif
 843 #ifdef MPI
 844       endif
 845 #endif
 846       do k=1,3
 847         gradbufc(k,nres)=0.0d0
 848       enddo
 849       do i=-1,nct
 850         do j=1,3
 851 #ifdef SPLITELE
 852 C          print *,gradbufc(1,13)
 853 C          print *,welec*gelc(1,13)
 854 C          print *,wel_loc*gel_loc(1,13)
 855 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 856 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 857 C          print *,wel_loc*gel_loc_long(1,13)
 858 C          print *,gradafm(1,13),"AFM"
 859           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 860      &                wel_loc*gel_loc(j,i)+
 861      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 862      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 863      &                wel_loc*gel_loc_long(j,i)+
 864      &                wcorr*gradcorr_long(j,i)+
 865      &                wcorr5*gradcorr5_long(j,i)+
 866      &                wcorr6*gradcorr6_long(j,i)+
 867      &                wturn6*gcorr6_turn_long(j,i))+
 868      &                wbond*gradb(j,i)+
 869      &                wcorr*gradcorr(j,i)+
 870      &                wturn3*gcorr3_turn(j,i)+
 871      &                wturn4*gcorr4_turn(j,i)+
 872      &                wcorr5*gradcorr5(j,i)+
 873      &                wcorr6*gradcorr6(j,i)+
 874      &                wturn6*gcorr6_turn(j,i)+
 875      &                wsccor*gsccorc(j,i)
 876      &               +wscloc*gscloc(j,i)
 877      &               +wliptran*gliptranc(j,i)
 878      &                +gradafm(j,i)
 879      &                 +welec*gshieldc(j,i)
 880      &                 +welec*gshieldc_loc(j,i)
 881      &                 +wcorr*gshieldc_ec(j,i)
 882      &                 +wcorr*gshieldc_loc_ec(j,i)
 883      &                 +wturn3*gshieldc_t3(j,i)
 884      &                 +wturn3*gshieldc_loc_t3(j,i)
 885      &                 +wturn4*gshieldc_t4(j,i)
 886      &                 +wturn4*gshieldc_loc_t4(j,i)
 887      &                 +wel_loc*gshieldc_ll(j,i)
 888      &                 +wel_loc*gshieldc_loc_ll(j,i)
 889      &                +wtube*gg_tube(j,i)
 890
 891 #else
 892           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 893      &                wel_loc*gel_loc(j,i)+
 894      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 895      &                welec*gelc_long(j,i)+
 896      &                wel_loc*gel_loc_long(j,i)+
 897      &                wcorr*gcorr_long(j,i)+
 898      &                wcorr5*gradcorr5_long(j,i)+
 899      &                wcorr6*gradcorr6_long(j,i)+
 900      &                wturn6*gcorr6_turn_long(j,i))+
 901      &                wbond*gradb(j,i)+
 902      &                wcorr*gradcorr(j,i)+
 903      &                wturn3*gcorr3_turn(j,i)+
 904      &                wturn4*gcorr4_turn(j,i)+
 905      &                wcorr5*gradcorr5(j,i)+
 906      &                wcorr6*gradcorr6(j,i)+
 907      &                wturn6*gcorr6_turn(j,i)+
 908      &                wsccor*gsccorc(j,i)
 909      &               +wscloc*gscloc(j,i)
 910      &               +wliptran*gliptranc(j,i)
 911      &                +gradafm(j,i)
 912      &                 +welec*gshieldc(j,i)
 913      &                 +welec*gshieldc_loc(j,i)
 914      &                 +wcorr*gshieldc_ec(j,i)
 915      &                 +wcorr*gshieldc_loc_ec(j,i)
 916      &                 +wturn3*gshieldc_t3(j,i)
 917      &                 +wturn3*gshieldc_loc_t3(j,i)
 918      &                 +wturn4*gshieldc_t4(j,i)
 919      &                 +wturn4*gshieldc_loc_t4(j,i)
 920      &                 +wel_loc*gshieldc_ll(j,i)
 921      &                 +wel_loc*gshieldc_loc_ll(j,i)
 922      &                +wtube*gg_tube(j,i)
 923
 924
 925 #endif
 926           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 927      &                  wbond*gradbx(j,i)+
 928      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 929      &                  wsccor*gsccorx(j,i)
 930      &                 +wscloc*gsclocx(j,i)
 931      &                 +wliptran*gliptranx(j,i)
 932      &                 +welec*gshieldx(j,i)
 933      &                 +wcorr*gshieldx_ec(j,i)
 934      &                 +wturn3*gshieldx_t3(j,i)
 935      &                 +wturn4*gshieldx_t4(j,i)
 936      &                 +wel_loc*gshieldx_ll(j,i)
 937      &                 +wtube*gg_tube_sc(j,i)
 938      &                 +wsaxs*gsaxsx(j,i)
 939
 940
 941
 942         enddo
 943       enddo
 944       if (constr_homology.gt.0) then
 945         do i=1,nct
 946           do j=1,3
 947             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 948             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 949           enddo
 950         enddo
 951       endif
 952 #ifdef DEBUG
 953       write (iout,*) "gradc gradx gloc after adding"
 954       do i=1,nres
 955         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 956      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 957       enddo
 958 #endif
 959 #ifdef DEBUG
 960       write (iout,*) "gloc before adding corr"
 961       do i=1,4*nres
 962         write (iout,*) i,gloc(i,icg)
 963       enddo
 964 #endif
 965       do i=1,nres-3
 966         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 967      &   +wcorr5*g_corr5_loc(i)
 968      &   +wcorr6*g_corr6_loc(i)
 969      &   +wturn4*gel_loc_turn4(i)
 970      &   +wturn3*gel_loc_turn3(i)
 971      &   +wturn6*gel_loc_turn6(i)
 972      &   +wel_loc*gel_loc_loc(i)
 973       enddo
 974 #ifdef DEBUG
 975       write (iout,*) "gloc after adding corr"
 976       do i=1,4*nres
 977         write (iout,*) i,gloc(i,icg)
 978       enddo
 979 #endif
 980 #ifdef MPI
 981       if (nfgtasks.gt.1) then
 982         do j=1,3
 983           do i=1,nres
 984             gradbufc(j,i)=gradc(j,i,icg)
 985             gradbufx(j,i)=gradx(j,i,icg)
 986           enddo
 987         enddo
 988         do i=1,4*nres
 989           glocbuf(i)=gloc(i,icg)
 990         enddo
 991 c#define DEBUG
 992 #ifdef DEBUG
 993       write (iout,*) "gloc_sc before reduce"
 994       do i=1,nres
 995        do j=1,1
 996         write (iout,*) i,j,gloc_sc(j,i,icg)
 997        enddo
 998       enddo
 999 #endif
1000 c#undef DEBUG
1001         do i=1,nres
1002          do j=1,3
1003           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1004          enddo
1005         enddo
1006         time00=MPI_Wtime()
1007         call MPI_Barrier(FG_COMM,IERR)
1008         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1009         time00=MPI_Wtime()
1010         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1011      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1012         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1013      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1014         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1015      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1016         time_reduce=time_reduce+MPI_Wtime()-time00
1017         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1018      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019         time_reduce=time_reduce+MPI_Wtime()-time00
1020 #ifdef DEBUG
1021       write (iout,*) "gradc after reduce"
1022       do i=1,nres
1023        do j=1,3
1024         write (iout,*) i,j,gradc(j,i,icg)
1025        enddo
1026       enddo
1027 #endif
1028 #ifdef DEBUG
1029       write (iout,*) "gloc_sc after reduce"
1030       do i=1,nres
1031        do j=1,1
1032         write (iout,*) i,j,gloc_sc(j,i,icg)
1033        enddo
1034       enddo
1035 #endif
1036 #ifdef DEBUG
1037       write (iout,*) "gloc after reduce"
1038       do i=1,4*nres
1039         write (iout,*) i,gloc(i,icg)
1040       enddo
1041 #endif
1042       endif
1043 #endif
1044       if (gnorm_check) then
1045 c
1046 c Compute the maximum elements of the gradient
1047 c
1048       gvdwc_max=0.0d0
1049       gvdwc_scp_max=0.0d0
1050       gelc_max=0.0d0
1051       gvdwpp_max=0.0d0
1052       gradb_max=0.0d0
1053       ghpbc_max=0.0d0
1054       gradcorr_max=0.0d0
1055       gel_loc_max=0.0d0
1056       gcorr3_turn_max=0.0d0
1057       gcorr4_turn_max=0.0d0
1058       gradcorr5_max=0.0d0
1059       gradcorr6_max=0.0d0
1060       gcorr6_turn_max=0.0d0
1061       gsccorc_max=0.0d0
1062       gscloc_max=0.0d0
1063       gvdwx_max=0.0d0
1064       gradx_scp_max=0.0d0
1065       ghpbx_max=0.0d0
1066       gradxorr_max=0.0d0
1067       gsccorx_max=0.0d0
1068       gsclocx_max=0.0d0
1069       do i=1,nct
1070         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1071         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1072         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1073         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1074      &   gvdwc_scp_max=gvdwc_scp_norm
1075         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1076         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1077         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1078         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1079         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1080         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1081         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1082         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1083         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1084         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1085         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1086         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1087         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1088      &    gcorr3_turn(1,i)))
1089         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1090      &    gcorr3_turn_max=gcorr3_turn_norm
1091         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1092      &    gcorr4_turn(1,i)))
1093         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1094      &    gcorr4_turn_max=gcorr4_turn_norm
1095         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1096         if (gradcorr5_norm.gt.gradcorr5_max)
1097      &    gradcorr5_max=gradcorr5_norm
1098         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1099         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1100         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1101      &    gcorr6_turn(1,i)))
1102         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1103      &    gcorr6_turn_max=gcorr6_turn_norm
1104         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1105         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1106         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1107         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1108         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1109         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1110         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1111         if (gradx_scp_norm.gt.gradx_scp_max)
1112      &    gradx_scp_max=gradx_scp_norm
1113         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1114         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1115         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1116         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1117         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1118         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1119         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1120         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1121       enddo
1122       if (gradout) then
1123 #if (defined AIX || defined CRAY)
1124         open(istat,file=statname,position="append")
1125 #else
1126         open(istat,file=statname,access="append")
1127 #endif
1128         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1129      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1130      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1131      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1132      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1133      &     gsccorx_max,gsclocx_max
1134         close(istat)
1135         if (gvdwc_max.gt.1.0d4) then
1136           write (iout,*) "gvdwc gvdwx gradb gradbx"
1137           do i=nnt,nct
1138             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1139      &        gradb(j,i),gradbx(j,i),j=1,3)
1140           enddo
1141           call pdbout(0.0d0,'cipiszcze',iout)
1142           call flush(iout)
1143         endif
1144       endif
1145       endif
1146 #ifdef DEBUG
1147       write (iout,*) "gradc gradx gloc"
1148       do i=1,nres
1149         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1150      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1151       enddo
1152 #endif
1153 #ifdef TIMING
1154       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1155 #endif
1156       return
1157       end
1158 c-------------------------------------------------------------------------------
1159       subroutine rescale_weights(t_bath)
1160       implicit real*8 (a-h,o-z)
1161       include 'DIMENSIONS'
1162       include 'COMMON.IOUNITS'
1163       include 'COMMON.FFIELD'
1164       include 'COMMON.SBRIDGE'
1165       include 'COMMON.CONTROL'
1166       double precision kfac /2.4d0/
1167       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1168 c      facT=temp0/t_bath
1169 c      facT=2*temp0/(t_bath+temp0)
1170       if (rescale_mode.eq.0) then
1171         facT=1.0d0
1172         facT2=1.0d0
1173         facT3=1.0d0
1174         facT4=1.0d0
1175         facT5=1.0d0
1176       else if (rescale_mode.eq.1) then
1177         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1178         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1179         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1180         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1181         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1182       else if (rescale_mode.eq.2) then
1183         x=t_bath/temp0
1184         x2=x*x
1185         x3=x2*x
1186         x4=x3*x
1187         x5=x4*x
1188         facT=licznik/dlog(dexp(x)+dexp(-x))
1189         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1190         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1191         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1192         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1193       else
1194         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1195         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1196 #ifdef MPI
1197        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1198 #endif
1199        stop 555
1200       endif
1201       if (shield_mode.gt.0) then
1202        wscp=weights(2)*fact
1203        wsc=weights(1)*fact
1204        wvdwpp=weights(16)*fact
1205       endif
1206       welec=weights(3)*fact
1207       wcorr=weights(4)*fact3
1208       wcorr5=weights(5)*fact4
1209       wcorr6=weights(6)*fact5
1210       wel_loc=weights(7)*fact2
1211       wturn3=weights(8)*fact2
1212       wturn4=weights(9)*fact3
1213       wturn6=weights(10)*fact5
1214       wtor=weights(13)*fact
1215       wtor_d=weights(14)*fact2
1216       wsccor=weights(21)*fact
1217       if (scale_umb) wumb=t_bath/temp0
1218 c      write (iout,*) "scale_umb",scale_umb
1219 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1220
1221       return
1222       end
1223 C------------------------------------------------------------------------
1224       subroutine enerprint(energia)
1225       implicit real*8 (a-h,o-z)
1226       include 'DIMENSIONS'
1227       include 'COMMON.IOUNITS'
1228       include 'COMMON.FFIELD'
1229       include 'COMMON.SBRIDGE'
1230       include 'COMMON.MD'
1231       double precision energia(0:n_ene)
1232       etot=energia(0)
1233       evdw=energia(1)
1234       evdw2=energia(2)
1235 #ifdef SCP14
1236       evdw2=energia(2)+energia(18)
1237 #else
1238       evdw2=energia(2)
1239 #endif
1240       ees=energia(3)
1241 #ifdef SPLITELE
1242       evdw1=energia(16)
1243 #endif
1244       ecorr=energia(4)
1245       ecorr5=energia(5)
1246       ecorr6=energia(6)
1247       eel_loc=energia(7)
1248       eello_turn3=energia(8)
1249       eello_turn4=energia(9)
1250       eello_turn6=energia(10)
1251       ebe=energia(11)
1252       escloc=energia(12)
1253       etors=energia(13)
1254       etors_d=energia(14)
1255       ehpb=energia(15)
1256       edihcnstr=energia(19)
1257       estr=energia(17)
1258       Uconst=energia(20)
1259       esccor=energia(21)
1260       eliptran=energia(22)
1261       Eafmforce=energia(23)
1262       ethetacnstr=energia(24)
1263       etube=energia(25)
1264       esaxs=energia(26)
1265       ehomology_constr=energia(27)
1266 C     Bartek
1267       edfadis = energia(28)
1268       edfator = energia(29)
1269       edfanei = energia(30)
1270       edfabet = energia(31)
1271 #ifdef SPLITELE
1272       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1273      &  estr,wbond,ebe,wang,
1274      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1275      &  ecorr,wcorr,
1276      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1277      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1278      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1279      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1280      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1281      &  edfabet,wdfa_beta,
1282      &  etot
1283    10 format (/'Virtual-chain energies:'//
1284      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1285      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1286      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1287      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1288      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1289      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1290      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1291      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1292      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1293      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1294      & ' (SS bridges & dist. cnstr.)'/
1295      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1296      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1297      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1298      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1299      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1300      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1301      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1302      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1303      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1304      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1305      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1306      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1307      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1308      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1309      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1310      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1311      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1312      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1313      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1314      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1315      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1316      & 'ETOT=  ',1pE16.6,' (total)')
1317
1318 #else
1319       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1320      &  estr,wbond,ebe,wang,
1321      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1322      &  ecorr,wcorr,
1323      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1324      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1325      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1326      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1327      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1328      &  edfabet,wdfa_beta,
1329      &  etot
1330    10 format (/'Virtual-chain energies:'//
1331      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1332      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1333      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1334      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1335      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1336      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1337      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1338      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1339      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1340      & ' (SS bridges & dist. restr.)'/
1341      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1342      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1343      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1344      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1345      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1346      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1347      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1348      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1349      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1350      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1351      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1352      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1353      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1354      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1355      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1356      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1357      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1358      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1359      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1360      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1361      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1362      & 'ETOT=  ',1pE16.6,' (total)')
1363 #endif
1364       return
1365       end
1366 C-----------------------------------------------------------------------
1367       subroutine elj(evdw)
1368 C
1369 C This subroutine calculates the interaction energy of nonbonded side chains
1370 C assuming the LJ potential of interaction.
1371 C
1372       implicit real*8 (a-h,o-z)
1373       include 'DIMENSIONS'
1374       parameter (accur=1.0d-10)
1375       include 'COMMON.GEO'
1376       include 'COMMON.VAR'
1377       include 'COMMON.LOCAL'
1378       include 'COMMON.CHAIN'
1379       include 'COMMON.DERIV'
1380       include 'COMMON.INTERACT'
1381       include 'COMMON.TORSION'
1382       include 'COMMON.SBRIDGE'
1383       include 'COMMON.NAMES'
1384       include 'COMMON.IOUNITS'
1385       include 'COMMON.CONTACTS'
1386       dimension gg(3)
1387 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1388       evdw=0.0D0
1389       do i=iatsc_s,iatsc_e
1390         itypi=iabs(itype(i))
1391         if (itypi.eq.ntyp1) cycle
1392         itypi1=iabs(itype(i+1))
1393         xi=c(1,nres+i)
1394         yi=c(2,nres+i)
1395         zi=c(3,nres+i)
1396 C Change 12/1/95
1397         num_conti=0
1398 C
1399 C Calculate SC interaction energy.
1400 C
1401         do iint=1,nint_gr(i)
1402 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1403 cd   &                  'iend=',iend(i,iint)
1404           do j=istart(i,iint),iend(i,iint)
1405             itypj=iabs(itype(j))
1406             if (itypj.eq.ntyp1) cycle
1407             xj=c(1,nres+j)-xi
1408             yj=c(2,nres+j)-yi
1409             zj=c(3,nres+j)-zi
1410 C Change 12/1/95 to calculate four-body interactions
1411             rij=xj*xj+yj*yj+zj*zj
1412             rrij=1.0D0/rij
1413 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1414             eps0ij=eps(itypi,itypj)
1415             fac=rrij**expon2
1416 C have you changed here?
1417             e1=fac*fac*aa
1418             e2=fac*bb
1419             evdwij=e1+e2
1420 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1421 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1422 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1423 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1424 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1425 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1426             evdw=evdw+evdwij
1427 C
1428 C Calculate the components of the gradient in DC and X
1429 C
1430             fac=-rrij*(e1+evdwij)
1431             gg(1)=xj*fac
1432             gg(2)=yj*fac
1433             gg(3)=zj*fac
1434             do k=1,3
1435               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1436               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1437               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1438               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1439             enddo
1440 cgrad            do k=i,j-1
1441 cgrad              do l=1,3
1442 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1443 cgrad              enddo
1444 cgrad            enddo
1445 C
1446 C 12/1/95, revised on 5/20/97
1447 C
1448 C Calculate the contact function. The ith column of the array JCONT will
1449 C contain the numbers of atoms that make contacts with the atom I (of numbers
1450 C greater than I). The arrays FACONT and GACONT will contain the values of
1451 C the contact function and its derivative.
1452 C
1453 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1454 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1455 C Uncomment next line, if the correlation interactions are contact function only
1456             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1457               rij=dsqrt(rij)
1458               sigij=sigma(itypi,itypj)
1459               r0ij=rs0(itypi,itypj)
1460 C
1461 C Check whether the SC's are not too far to make a contact.
1462 C
1463               rcut=1.5d0*r0ij
1464               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1465 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1466 C
1467               if (fcont.gt.0.0D0) then
1468 C If the SC-SC distance if close to sigma, apply spline.
1469 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1470 cAdam &             fcont1,fprimcont1)
1471 cAdam           fcont1=1.0d0-fcont1
1472 cAdam           if (fcont1.gt.0.0d0) then
1473 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1474 cAdam             fcont=fcont*fcont1
1475 cAdam           endif
1476 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1477 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1478 cga             do k=1,3
1479 cga               gg(k)=gg(k)*eps0ij
1480 cga             enddo
1481 cga             eps0ij=-evdwij*eps0ij
1482 C Uncomment for AL's type of SC correlation interactions.
1483 cadam           eps0ij=-evdwij
1484                 num_conti=num_conti+1
1485                 jcont(num_conti,i)=j
1486                 facont(num_conti,i)=fcont*eps0ij
1487                 fprimcont=eps0ij*fprimcont/rij
1488                 fcont=expon*fcont
1489 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1490 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1491 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1492 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1493                 gacont(1,num_conti,i)=-fprimcont*xj
1494                 gacont(2,num_conti,i)=-fprimcont*yj
1495                 gacont(3,num_conti,i)=-fprimcont*zj
1496 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1497 cd              write (iout,'(2i3,3f10.5)')
1498 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1499               endif
1500             endif
1501           enddo      ! j
1502         enddo        ! iint
1503 C Change 12/1/95
1504         num_cont(i)=num_conti
1505       enddo          ! i
1506       do i=1,nct
1507         do j=1,3
1508           gvdwc(j,i)=expon*gvdwc(j,i)
1509           gvdwx(j,i)=expon*gvdwx(j,i)
1510         enddo
1511       enddo
1512 C******************************************************************************
1513 C
1514 C                              N O T E !!!
1515 C
1516 C To save time, the factor of EXPON has been extracted from ALL components
1517 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1518 C use!
1519 C
1520 C******************************************************************************
1521       return
1522       end
1523 C-----------------------------------------------------------------------------
1524       subroutine eljk(evdw)
1525 C
1526 C This subroutine calculates the interaction energy of nonbonded side chains
1527 C assuming the LJK potential of interaction.
1528 C
1529       implicit real*8 (a-h,o-z)
1530       include 'DIMENSIONS'
1531       include 'COMMON.GEO'
1532       include 'COMMON.VAR'
1533       include 'COMMON.LOCAL'
1534       include 'COMMON.CHAIN'
1535       include 'COMMON.DERIV'
1536       include 'COMMON.INTERACT'
1537       include 'COMMON.IOUNITS'
1538       include 'COMMON.NAMES'
1539       dimension gg(3)
1540       logical scheck
1541 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1542       evdw=0.0D0
1543       do i=iatsc_s,iatsc_e
1544         itypi=iabs(itype(i))
1545         if (itypi.eq.ntyp1) cycle
1546         itypi1=iabs(itype(i+1))
1547         xi=c(1,nres+i)
1548         yi=c(2,nres+i)
1549         zi=c(3,nres+i)
1550 C
1551 C Calculate SC interaction energy.
1552 C
1553         do iint=1,nint_gr(i)
1554           do j=istart(i,iint),iend(i,iint)
1555             itypj=iabs(itype(j))
1556             if (itypj.eq.ntyp1) cycle
1557             xj=c(1,nres+j)-xi
1558             yj=c(2,nres+j)-yi
1559             zj=c(3,nres+j)-zi
1560             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1561             fac_augm=rrij**expon
1562             e_augm=augm(itypi,itypj)*fac_augm
1563             r_inv_ij=dsqrt(rrij)
1564             rij=1.0D0/r_inv_ij
1565             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1566             fac=r_shift_inv**expon
1567 C have you changed here?
1568             e1=fac*fac*aa
1569             e2=fac*bb
1570             evdwij=e_augm+e1+e2
1571 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1572 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1573 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1574 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1575 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1576 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1577 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1578             evdw=evdw+evdwij
1579 C
1580 C Calculate the components of the gradient in DC and X
1581 C
1582             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1583             gg(1)=xj*fac
1584             gg(2)=yj*fac
1585             gg(3)=zj*fac
1586             do k=1,3
1587               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1588               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1589               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1590               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1591             enddo
1592 cgrad            do k=i,j-1
1593 cgrad              do l=1,3
1594 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1595 cgrad              enddo
1596 cgrad            enddo
1597           enddo      ! j
1598         enddo        ! iint
1599       enddo          ! i
1600       do i=1,nct
1601         do j=1,3
1602           gvdwc(j,i)=expon*gvdwc(j,i)
1603           gvdwx(j,i)=expon*gvdwx(j,i)
1604         enddo
1605       enddo
1606       return
1607       end
1608 C-----------------------------------------------------------------------------
1609       subroutine ebp(evdw)
1610 C
1611 C This subroutine calculates the interaction energy of nonbonded side chains
1612 C assuming the Berne-Pechukas potential of interaction.
1613 C
1614       implicit real*8 (a-h,o-z)
1615       include 'DIMENSIONS'
1616       include 'COMMON.GEO'
1617       include 'COMMON.VAR'
1618       include 'COMMON.LOCAL'
1619       include 'COMMON.CHAIN'
1620       include 'COMMON.DERIV'
1621       include 'COMMON.NAMES'
1622       include 'COMMON.INTERACT'
1623       include 'COMMON.IOUNITS'
1624       include 'COMMON.CALC'
1625       common /srutu/ icall
1626 c     double precision rrsave(maxdim)
1627       logical lprn
1628       evdw=0.0D0
1629 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1630       evdw=0.0D0
1631 c     if (icall.eq.0) then
1632 c       lprn=.true.
1633 c     else
1634         lprn=.false.
1635 c     endif
1636       ind=0
1637       do i=iatsc_s,iatsc_e
1638         itypi=iabs(itype(i))
1639         if (itypi.eq.ntyp1) cycle
1640         itypi1=iabs(itype(i+1))
1641         xi=c(1,nres+i)
1642         yi=c(2,nres+i)
1643         zi=c(3,nres+i)
1644         dxi=dc_norm(1,nres+i)
1645         dyi=dc_norm(2,nres+i)
1646         dzi=dc_norm(3,nres+i)
1647 c        dsci_inv=dsc_inv(itypi)
1648         dsci_inv=vbld_inv(i+nres)
1649 C
1650 C Calculate SC interaction energy.
1651 C
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             ind=ind+1
1655             itypj=iabs(itype(j))
1656             if (itypj.eq.ntyp1) cycle
1657 c            dscj_inv=dsc_inv(itypj)
1658             dscj_inv=vbld_inv(j+nres)
1659             chi1=chi(itypi,itypj)
1660             chi2=chi(itypj,itypi)
1661             chi12=chi1*chi2
1662             chip1=chip(itypi)
1663             chip2=chip(itypj)
1664             chip12=chip1*chip2
1665             alf1=alp(itypi)
1666             alf2=alp(itypj)
1667             alf12=0.5D0*(alf1+alf2)
1668 C For diagnostics only!!!
1669 c           chi1=0.0D0
1670 c           chi2=0.0D0
1671 c           chi12=0.0D0
1672 c           chip1=0.0D0
1673 c           chip2=0.0D0
1674 c           chip12=0.0D0
1675 c           alf1=0.0D0
1676 c           alf2=0.0D0
1677 c           alf12=0.0D0
1678             xj=c(1,nres+j)-xi
1679             yj=c(2,nres+j)-yi
1680             zj=c(3,nres+j)-zi
1681             dxj=dc_norm(1,nres+j)
1682             dyj=dc_norm(2,nres+j)
1683             dzj=dc_norm(3,nres+j)
1684             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1685 cd          if (icall.eq.0) then
1686 cd            rrsave(ind)=rrij
1687 cd          else
1688 cd            rrij=rrsave(ind)
1689 cd          endif
1690             rij=dsqrt(rrij)
1691 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1692             call sc_angular
1693 C Calculate whole angle-dependent part of epsilon and contributions
1694 C to its derivatives
1695 C have you changed here?
1696             fac=(rrij*sigsq)**expon2
1697             e1=fac*fac*aa
1698             e2=fac*bb
1699             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1700             eps2der=evdwij*eps3rt
1701             eps3der=evdwij*eps2rt
1702             evdwij=evdwij*eps2rt*eps3rt
1703             evdw=evdw+evdwij
1704             if (lprn) then
1705             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1706             epsi=bb**2/aa
1707 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1708 cd     &        restyp(itypi),i,restyp(itypj),j,
1709 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1710 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1711 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1712 cd     &        evdwij
1713             endif
1714 C Calculate gradient components.
1715             e1=e1*eps1*eps2rt**2*eps3rt**2
1716             fac=-expon*(e1+evdwij)
1717             sigder=fac/sigsq
1718             fac=rrij*fac
1719 C Calculate radial part of the gradient
1720             gg(1)=xj*fac
1721             gg(2)=yj*fac
1722             gg(3)=zj*fac
1723 C Calculate the angular part of the gradient and sum add the contributions
1724 C to the appropriate components of the Cartesian gradient.
1725             call sc_grad
1726           enddo      ! j
1727         enddo        ! iint
1728       enddo          ! i
1729 c     stop
1730       return
1731       end
1732 C-----------------------------------------------------------------------------
1733       subroutine egb(evdw)
1734 C
1735 C This subroutine calculates the interaction energy of nonbonded side chains
1736 C assuming the Gay-Berne potential of interaction.
1737 C
1738       implicit real*8 (a-h,o-z)
1739       include 'DIMENSIONS'
1740       include 'COMMON.GEO'
1741       include 'COMMON.VAR'
1742       include 'COMMON.LOCAL'
1743       include 'COMMON.CHAIN'
1744       include 'COMMON.DERIV'
1745       include 'COMMON.NAMES'
1746       include 'COMMON.INTERACT'
1747       include 'COMMON.IOUNITS'
1748       include 'COMMON.CALC'
1749       include 'COMMON.CONTROL'
1750       include 'COMMON.SPLITELE'
1751       include 'COMMON.SBRIDGE'
1752       logical lprn
1753       integer xshift,yshift,zshift
1754
1755       evdw=0.0D0
1756 ccccc      energy_dec=.false.
1757 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1758       evdw=0.0D0
1759       lprn=.false.
1760 c     if (icall.eq.0) lprn=.false.
1761       ind=0
1762 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1763 C we have the original box)
1764 C      do xshift=-1,1
1765 C      do yshift=-1,1
1766 C      do zshift=-1,1
1767       do i=iatsc_s,iatsc_e
1768         itypi=iabs(itype(i))
1769         if (itypi.eq.ntyp1) cycle
1770         itypi1=iabs(itype(i+1))
1771         xi=c(1,nres+i)
1772         yi=c(2,nres+i)
1773         zi=c(3,nres+i)
1774 C Return atom into box, boxxsize is size of box in x dimension
1775 c  134   continue
1776 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1777 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1778 C Condition for being inside the proper box
1779 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1780 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1781 c        go to 134
1782 c        endif
1783 c  135   continue
1784 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1785 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1786 C Condition for being inside the proper box
1787 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1788 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1789 c        go to 135
1790 c        endif
1791 c  136   continue
1792 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1793 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1794 C Condition for being inside the proper box
1795 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1796 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1797 c        go to 136
1798 c        endif
1799           xi=mod(xi,boxxsize)
1800           if (xi.lt.0) xi=xi+boxxsize
1801           yi=mod(yi,boxysize)
1802           if (yi.lt.0) yi=yi+boxysize
1803           zi=mod(zi,boxzsize)
1804           if (zi.lt.0) zi=zi+boxzsize
1805 C define scaling factor for lipids
1806
1807 C        if (positi.le.0) positi=positi+boxzsize
1808 C        print *,i
1809 C first for peptide groups
1810 c for each residue check if it is in lipid or lipid water border area
1811        if ((zi.gt.bordlipbot)
1812      &.and.(zi.lt.bordliptop)) then
1813 C the energy transfer exist
1814         if (zi.lt.buflipbot) then
1815 C what fraction I am in
1816          fracinbuf=1.0d0-
1817      &        ((zi-bordlipbot)/lipbufthick)
1818 C lipbufthick is thickenes of lipid buffore
1819          sslipi=sscalelip(fracinbuf)
1820          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1821         elseif (zi.gt.bufliptop) then
1822          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1823          sslipi=sscalelip(fracinbuf)
1824          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1825         else
1826          sslipi=1.0d0
1827          ssgradlipi=0.0
1828         endif
1829        else
1830          sslipi=0.0d0
1831          ssgradlipi=0.0
1832        endif
1833
1834 C          xi=xi+xshift*boxxsize
1835 C          yi=yi+yshift*boxysize
1836 C          zi=zi+zshift*boxzsize
1837
1838         dxi=dc_norm(1,nres+i)
1839         dyi=dc_norm(2,nres+i)
1840         dzi=dc_norm(3,nres+i)
1841 c        dsci_inv=dsc_inv(itypi)
1842         dsci_inv=vbld_inv(i+nres)
1843 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1844 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1845 C
1846 C Calculate SC interaction energy.
1847 C
1848         do iint=1,nint_gr(i)
1849           do j=istart(i,iint),iend(i,iint)
1850             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1851
1852 c              write(iout,*) "PRZED ZWYKLE", evdwij
1853               call dyn_ssbond_ene(i,j,evdwij)
1854 c              write(iout,*) "PO ZWYKLE", evdwij
1855
1856               evdw=evdw+evdwij
1857               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1858      &                        'evdw',i,j,evdwij,' ss'
1859 C triple bond artifac removal
1860              do k=j+1,iend(i,iint)
1861 C search over all next residues
1862               if (dyn_ss_mask(k)) then
1863 C check if they are cysteins
1864 C              write(iout,*) 'k=',k
1865
1866 c              write(iout,*) "PRZED TRI", evdwij
1867                evdwij_przed_tri=evdwij
1868               call triple_ssbond_ene(i,j,k,evdwij)
1869 c               if(evdwij_przed_tri.ne.evdwij) then
1870 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1871 c               endif
1872
1873 c              write(iout,*) "PO TRI", evdwij
1874 C call the energy function that removes the artifical triple disulfide
1875 C bond the soubroutine is located in ssMD.F
1876               evdw=evdw+evdwij
1877               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1878      &                        'evdw',i,j,evdwij,'tss'
1879               endif!dyn_ss_mask(k)
1880              enddo! k
1881             ELSE
1882             ind=ind+1
1883             itypj=iabs(itype(j))
1884             if (itypj.eq.ntyp1) cycle
1885 c            dscj_inv=dsc_inv(itypj)
1886             dscj_inv=vbld_inv(j+nres)
1887 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1888 c     &       1.0d0/vbld(j+nres)
1889 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1890             sig0ij=sigma(itypi,itypj)
1891             chi1=chi(itypi,itypj)
1892             chi2=chi(itypj,itypi)
1893             chi12=chi1*chi2
1894             chip1=chip(itypi)
1895             chip2=chip(itypj)
1896             chip12=chip1*chip2
1897             alf1=alp(itypi)
1898             alf2=alp(itypj)
1899             alf12=0.5D0*(alf1+alf2)
1900 C For diagnostics only!!!
1901 c           chi1=0.0D0
1902 c           chi2=0.0D0
1903 c           chi12=0.0D0
1904 c           chip1=0.0D0
1905 c           chip2=0.0D0
1906 c           chip12=0.0D0
1907 c           alf1=0.0D0
1908 c           alf2=0.0D0
1909 c           alf12=0.0D0
1910             xj=c(1,nres+j)
1911             yj=c(2,nres+j)
1912             zj=c(3,nres+j)
1913 C Return atom J into box the original box
1914 c  137   continue
1915 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1916 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1917 C Condition for being inside the proper box
1918 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1919 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1920 c        go to 137
1921 c        endif
1922 c  138   continue
1923 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1924 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1925 C Condition for being inside the proper box
1926 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1927 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1928 c        go to 138
1929 c        endif
1930 c  139   continue
1931 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1932 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1933 C Condition for being inside the proper box
1934 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1935 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1936 c        go to 139
1937 c        endif
1938           xj=mod(xj,boxxsize)
1939           if (xj.lt.0) xj=xj+boxxsize
1940           yj=mod(yj,boxysize)
1941           if (yj.lt.0) yj=yj+boxysize
1942           zj=mod(zj,boxzsize)
1943           if (zj.lt.0) zj=zj+boxzsize
1944        if ((zj.gt.bordlipbot)
1945      &.and.(zj.lt.bordliptop)) then
1946 C the energy transfer exist
1947         if (zj.lt.buflipbot) then
1948 C what fraction I am in
1949          fracinbuf=1.0d0-
1950      &        ((zj-bordlipbot)/lipbufthick)
1951 C lipbufthick is thickenes of lipid buffore
1952          sslipj=sscalelip(fracinbuf)
1953          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1954         elseif (zj.gt.bufliptop) then
1955          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1956          sslipj=sscalelip(fracinbuf)
1957          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1958         else
1959          sslipj=1.0d0
1960          ssgradlipj=0.0
1961         endif
1962        else
1963          sslipj=0.0d0
1964          ssgradlipj=0.0
1965        endif
1966       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1967      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1968       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1969      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1970 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1971 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1972 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1973 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1974 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1975       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1976       xj_safe=xj
1977       yj_safe=yj
1978       zj_safe=zj
1979       subchap=0
1980       do xshift=-1,1
1981       do yshift=-1,1
1982       do zshift=-1,1
1983           xj=xj_safe+xshift*boxxsize
1984           yj=yj_safe+yshift*boxysize
1985           zj=zj_safe+zshift*boxzsize
1986           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1987           if(dist_temp.lt.dist_init) then
1988             dist_init=dist_temp
1989             xj_temp=xj
1990             yj_temp=yj
1991             zj_temp=zj
1992             subchap=1
1993           endif
1994        enddo
1995        enddo
1996        enddo
1997        if (subchap.eq.1) then
1998           xj=xj_temp-xi
1999           yj=yj_temp-yi
2000           zj=zj_temp-zi
2001        else
2002           xj=xj_safe-xi
2003           yj=yj_safe-yi
2004           zj=zj_safe-zi
2005        endif
2006             dxj=dc_norm(1,nres+j)
2007             dyj=dc_norm(2,nres+j)
2008             dzj=dc_norm(3,nres+j)
2009 C            xj=xj-xi
2010 C            yj=yj-yi
2011 C            zj=zj-zi
2012 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2013 c            write (iout,*) "j",j," dc_norm",
2014 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2016             rij=dsqrt(rrij)
2017             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2018             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2019
2020 c            write (iout,'(a7,4f8.3)')
2021 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2022             if (sss.gt.0.0d0) then
2023 C Calculate angle-dependent terms of energy and contributions to their
2024 C derivatives.
2025             call sc_angular
2026             sigsq=1.0D0/sigsq
2027             sig=sig0ij*dsqrt(sigsq)
2028             rij_shift=1.0D0/rij-sig+sig0ij
2029 c for diagnostics; uncomment
2030 c            rij_shift=1.2*sig0ij
2031 C I hate to put IF's in the loops, but here don't have another choice!!!!
2032             if (rij_shift.le.0.0D0) then
2033               evdw=1.0D20
2034 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2035 cd     &        restyp(itypi),i,restyp(itypj),j,
2036 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2037               return
2038             endif
2039             sigder=-sig*sigsq
2040 c---------------------------------------------------------------
2041             rij_shift=1.0D0/rij_shift
2042             fac=rij_shift**expon
2043 C here to start with
2044 C            if (c(i,3).gt.
2045             faclip=fac
2046             e1=fac*fac*aa
2047             e2=fac*bb
2048             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2049             eps2der=evdwij*eps3rt
2050             eps3der=evdwij*eps2rt
2051 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2052 C     &((sslipi+sslipj)/2.0d0+
2053 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2054 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2055 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2056             evdwij=evdwij*eps2rt*eps3rt
2057             evdw=evdw+evdwij*sss
2058             if (lprn) then
2059             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2060             epsi=bb**2/aa
2061             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062      &        restyp(itypi),i,restyp(itypj),j,
2063      &        epsi,sigm,chi1,chi2,chip1,chip2,
2064      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2065      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2066      &        evdwij
2067             endif
2068
2069             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2070      &                        'evdw',i,j,evdwij
2071
2072 C Calculate gradient components.
2073             e1=e1*eps1*eps2rt**2*eps3rt**2
2074             fac=-expon*(e1+evdwij)*rij_shift
2075             sigder=fac*sigder
2076             fac=rij*fac
2077 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2078 c     &      evdwij,fac,sigma(itypi,itypj),expon
2079             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2080 c            fac=0.0d0
2081 C Calculate the radial part of the gradient
2082             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2083      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2084      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2085      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2086             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2087             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2088 C            gg_lipi(3)=0.0d0
2089 C            gg_lipj(3)=0.0d0
2090             gg(1)=xj*fac
2091             gg(2)=yj*fac
2092             gg(3)=zj*fac
2093 C Calculate angular part of the gradient.
2094             call sc_grad
2095             endif
2096             ENDIF    ! dyn_ss
2097           enddo      ! j
2098         enddo        ! iint
2099       enddo          ! i
2100 C      enddo          ! zshift
2101 C      enddo          ! yshift
2102 C      enddo          ! xshift
2103 c      write (iout,*) "Number of loop steps in EGB:",ind
2104 cccc      energy_dec=.false.
2105       return
2106       end
2107 C-----------------------------------------------------------------------------
2108       subroutine egbv(evdw)
2109 C
2110 C This subroutine calculates the interaction energy of nonbonded side chains
2111 C assuming the Gay-Berne-Vorobjev potential of interaction.
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'COMMON.GEO'
2116       include 'COMMON.VAR'
2117       include 'COMMON.LOCAL'
2118       include 'COMMON.CHAIN'
2119       include 'COMMON.DERIV'
2120       include 'COMMON.NAMES'
2121       include 'COMMON.INTERACT'
2122       include 'COMMON.IOUNITS'
2123       include 'COMMON.CALC'
2124       integer xshift,yshift,zshift
2125       common /srutu/ icall
2126       logical lprn
2127       evdw=0.0D0
2128 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2129       evdw=0.0D0
2130       lprn=.false.
2131 c     if (icall.eq.0) lprn=.true.
2132       ind=0
2133       do i=iatsc_s,iatsc_e
2134         itypi=iabs(itype(i))
2135         if (itypi.eq.ntyp1) cycle
2136         itypi1=iabs(itype(i+1))
2137         xi=c(1,nres+i)
2138         yi=c(2,nres+i)
2139         zi=c(3,nres+i)
2140           xi=mod(xi,boxxsize)
2141           if (xi.lt.0) xi=xi+boxxsize
2142           yi=mod(yi,boxysize)
2143           if (yi.lt.0) yi=yi+boxysize
2144           zi=mod(zi,boxzsize)
2145           if (zi.lt.0) zi=zi+boxzsize
2146 C define scaling factor for lipids
2147
2148 C        if (positi.le.0) positi=positi+boxzsize
2149 C        print *,i
2150 C first for peptide groups
2151 c for each residue check if it is in lipid or lipid water border area
2152        if ((zi.gt.bordlipbot)
2153      &.and.(zi.lt.bordliptop)) then
2154 C the energy transfer exist
2155         if (zi.lt.buflipbot) then
2156 C what fraction I am in
2157          fracinbuf=1.0d0-
2158      &        ((zi-bordlipbot)/lipbufthick)
2159 C lipbufthick is thickenes of lipid buffore
2160          sslipi=sscalelip(fracinbuf)
2161          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2162         elseif (zi.gt.bufliptop) then
2163          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2164          sslipi=sscalelip(fracinbuf)
2165          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2166         else
2167          sslipi=1.0d0
2168          ssgradlipi=0.0
2169         endif
2170        else
2171          sslipi=0.0d0
2172          ssgradlipi=0.0
2173        endif
2174
2175         dxi=dc_norm(1,nres+i)
2176         dyi=dc_norm(2,nres+i)
2177         dzi=dc_norm(3,nres+i)
2178 c        dsci_inv=dsc_inv(itypi)
2179         dsci_inv=vbld_inv(i+nres)
2180 C
2181 C Calculate SC interaction energy.
2182 C
2183         do iint=1,nint_gr(i)
2184           do j=istart(i,iint),iend(i,iint)
2185             ind=ind+1
2186             itypj=iabs(itype(j))
2187             if (itypj.eq.ntyp1) cycle
2188 c            dscj_inv=dsc_inv(itypj)
2189             dscj_inv=vbld_inv(j+nres)
2190             sig0ij=sigma(itypi,itypj)
2191             r0ij=r0(itypi,itypj)
2192             chi1=chi(itypi,itypj)
2193             chi2=chi(itypj,itypi)
2194             chi12=chi1*chi2
2195             chip1=chip(itypi)
2196             chip2=chip(itypj)
2197             chip12=chip1*chip2
2198             alf1=alp(itypi)
2199             alf2=alp(itypj)
2200             alf12=0.5D0*(alf1+alf2)
2201 C For diagnostics only!!!
2202 c           chi1=0.0D0
2203 c           chi2=0.0D0
2204 c           chi12=0.0D0
2205 c           chip1=0.0D0
2206 c           chip2=0.0D0
2207 c           chip12=0.0D0
2208 c           alf1=0.0D0
2209 c           alf2=0.0D0
2210 c           alf12=0.0D0
2211 C            xj=c(1,nres+j)-xi
2212 C            yj=c(2,nres+j)-yi
2213 C            zj=c(3,nres+j)-zi
2214           xj=mod(xj,boxxsize)
2215           if (xj.lt.0) xj=xj+boxxsize
2216           yj=mod(yj,boxysize)
2217           if (yj.lt.0) yj=yj+boxysize
2218           zj=mod(zj,boxzsize)
2219           if (zj.lt.0) zj=zj+boxzsize
2220        if ((zj.gt.bordlipbot)
2221      &.and.(zj.lt.bordliptop)) then
2222 C the energy transfer exist
2223         if (zj.lt.buflipbot) then
2224 C what fraction I am in
2225          fracinbuf=1.0d0-
2226      &        ((zj-bordlipbot)/lipbufthick)
2227 C lipbufthick is thickenes of lipid buffore
2228          sslipj=sscalelip(fracinbuf)
2229          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2230         elseif (zj.gt.bufliptop) then
2231          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2232          sslipj=sscalelip(fracinbuf)
2233          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2234         else
2235          sslipj=1.0d0
2236          ssgradlipj=0.0
2237         endif
2238        else
2239          sslipj=0.0d0
2240          ssgradlipj=0.0
2241        endif
2242       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2243      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2244       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2245      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2246 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2247 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2248 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2249       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2250       xj_safe=xj
2251       yj_safe=yj
2252       zj_safe=zj
2253       subchap=0
2254       do xshift=-1,1
2255       do yshift=-1,1
2256       do zshift=-1,1
2257           xj=xj_safe+xshift*boxxsize
2258           yj=yj_safe+yshift*boxysize
2259           zj=zj_safe+zshift*boxzsize
2260           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2261           if(dist_temp.lt.dist_init) then
2262             dist_init=dist_temp
2263             xj_temp=xj
2264             yj_temp=yj
2265             zj_temp=zj
2266             subchap=1
2267           endif
2268        enddo
2269        enddo
2270        enddo
2271        if (subchap.eq.1) then
2272           xj=xj_temp-xi
2273           yj=yj_temp-yi
2274           zj=zj_temp-zi
2275        else
2276           xj=xj_safe-xi
2277           yj=yj_safe-yi
2278           zj=zj_safe-zi
2279        endif
2280             dxj=dc_norm(1,nres+j)
2281             dyj=dc_norm(2,nres+j)
2282             dzj=dc_norm(3,nres+j)
2283             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2284             rij=dsqrt(rrij)
2285 C Calculate angle-dependent terms of energy and contributions to their
2286 C derivatives.
2287             call sc_angular
2288             sigsq=1.0D0/sigsq
2289             sig=sig0ij*dsqrt(sigsq)
2290             rij_shift=1.0D0/rij-sig+r0ij
2291 C I hate to put IF's in the loops, but here don't have another choice!!!!
2292             if (rij_shift.le.0.0D0) then
2293               evdw=1.0D20
2294               return
2295             endif
2296             sigder=-sig*sigsq
2297 c---------------------------------------------------------------
2298             rij_shift=1.0D0/rij_shift
2299             fac=rij_shift**expon
2300             e1=fac*fac*aa
2301             e2=fac*bb
2302             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2303             eps2der=evdwij*eps3rt
2304             eps3der=evdwij*eps2rt
2305             fac_augm=rrij**expon
2306             e_augm=augm(itypi,itypj)*fac_augm
2307             evdwij=evdwij*eps2rt*eps3rt
2308             evdw=evdw+evdwij+e_augm
2309             if (lprn) then
2310             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2311             epsi=bb**2/aa
2312             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2313      &        restyp(itypi),i,restyp(itypj),j,
2314      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2315      &        chi1,chi2,chip1,chip2,
2316      &        eps1,eps2rt**2,eps3rt**2,
2317      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2318      &        evdwij+e_augm
2319             endif
2320 C Calculate gradient components.
2321             e1=e1*eps1*eps2rt**2*eps3rt**2
2322             fac=-expon*(e1+evdwij)*rij_shift
2323             sigder=fac*sigder
2324             fac=rij*fac-2*expon*rrij*e_augm
2325             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2326 C Calculate the radial part of the gradient
2327             gg(1)=xj*fac
2328             gg(2)=yj*fac
2329             gg(3)=zj*fac
2330 C Calculate angular part of the gradient.
2331             call sc_grad
2332           enddo      ! j
2333         enddo        ! iint
2334       enddo          ! i
2335       end
2336 C-----------------------------------------------------------------------------
2337       subroutine sc_angular
2338 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2339 C om12. Called by ebp, egb, and egbv.
2340       implicit none
2341       include 'COMMON.CALC'
2342       include 'COMMON.IOUNITS'
2343       erij(1)=xj*rij
2344       erij(2)=yj*rij
2345       erij(3)=zj*rij
2346       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2347       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2348       om12=dxi*dxj+dyi*dyj+dzi*dzj
2349       chiom12=chi12*om12
2350 C Calculate eps1(om12) and its derivative in om12
2351       faceps1=1.0D0-om12*chiom12
2352       faceps1_inv=1.0D0/faceps1
2353       eps1=dsqrt(faceps1_inv)
2354 C Following variable is eps1*deps1/dom12
2355       eps1_om12=faceps1_inv*chiom12
2356 c diagnostics only
2357 c      faceps1_inv=om12
2358 c      eps1=om12
2359 c      eps1_om12=1.0d0
2360 c      write (iout,*) "om12",om12," eps1",eps1
2361 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2362 C and om12.
2363       om1om2=om1*om2
2364       chiom1=chi1*om1
2365       chiom2=chi2*om2
2366       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2367       sigsq=1.0D0-facsig*faceps1_inv
2368       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2369       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2370       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2371 c diagnostics only
2372 c      sigsq=1.0d0
2373 c      sigsq_om1=0.0d0
2374 c      sigsq_om2=0.0d0
2375 c      sigsq_om12=0.0d0
2376 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2377 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2378 c     &    " eps1",eps1
2379 C Calculate eps2 and its derivatives in om1, om2, and om12.
2380       chipom1=chip1*om1
2381       chipom2=chip2*om2
2382       chipom12=chip12*om12
2383       facp=1.0D0-om12*chipom12
2384       facp_inv=1.0D0/facp
2385       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2386 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2387 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2388 C Following variable is the square root of eps2
2389       eps2rt=1.0D0-facp1*facp_inv
2390 C Following three variables are the derivatives of the square root of eps
2391 C in om1, om2, and om12.
2392       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2393       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2394       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2395 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2396       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2397 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2398 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2399 c     &  " eps2rt_om12",eps2rt_om12
2400 C Calculate whole angle-dependent part of epsilon and contributions
2401 C to its derivatives
2402       return
2403       end
2404 C----------------------------------------------------------------------------
2405       subroutine sc_grad
2406       implicit real*8 (a-h,o-z)
2407       include 'DIMENSIONS'
2408       include 'COMMON.CHAIN'
2409       include 'COMMON.DERIV'
2410       include 'COMMON.CALC'
2411       include 'COMMON.IOUNITS'
2412       double precision dcosom1(3),dcosom2(3)
2413 cc      print *,'sss=',sss
2414       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2415       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2416       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2417      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2418 c diagnostics only
2419 c      eom1=0.0d0
2420 c      eom2=0.0d0
2421 c      eom12=evdwij*eps1_om12
2422 c end diagnostics
2423 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2424 c     &  " sigder",sigder
2425 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2426 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2427       do k=1,3
2428         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2429         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2430       enddo
2431       do k=1,3
2432         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2433       enddo
2434 c      write (iout,*) "gg",(gg(k),k=1,3)
2435       do k=1,3
2436         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2437      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2438      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2439         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2440      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2441      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2442 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2443 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2444 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2445 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2446       enddo
2447 C
2448 C Calculate the components of the gradient in DC and X
2449 C
2450 cgrad      do k=i,j-1
2451 cgrad        do l=1,3
2452 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2453 cgrad        enddo
2454 cgrad      enddo
2455       do l=1,3
2456         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2457         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2458       enddo
2459       return
2460       end
2461 C-----------------------------------------------------------------------
2462       subroutine e_softsphere(evdw)
2463 C
2464 C This subroutine calculates the interaction energy of nonbonded side chains
2465 C assuming the LJ potential of interaction.
2466 C
2467       implicit real*8 (a-h,o-z)
2468       include 'DIMENSIONS'
2469       parameter (accur=1.0d-10)
2470       include 'COMMON.GEO'
2471       include 'COMMON.VAR'
2472       include 'COMMON.LOCAL'
2473       include 'COMMON.CHAIN'
2474       include 'COMMON.DERIV'
2475       include 'COMMON.INTERACT'
2476       include 'COMMON.TORSION'
2477       include 'COMMON.SBRIDGE'
2478       include 'COMMON.NAMES'
2479       include 'COMMON.IOUNITS'
2480       include 'COMMON.CONTACTS'
2481       dimension gg(3)
2482 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2483       evdw=0.0D0
2484       do i=iatsc_s,iatsc_e
2485         itypi=iabs(itype(i))
2486         if (itypi.eq.ntyp1) cycle
2487         itypi1=iabs(itype(i+1))
2488         xi=c(1,nres+i)
2489         yi=c(2,nres+i)
2490         zi=c(3,nres+i)
2491 C
2492 C Calculate SC interaction energy.
2493 C
2494         do iint=1,nint_gr(i)
2495 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2496 cd   &                  'iend=',iend(i,iint)
2497           do j=istart(i,iint),iend(i,iint)
2498             itypj=iabs(itype(j))
2499             if (itypj.eq.ntyp1) cycle
2500             xj=c(1,nres+j)-xi
2501             yj=c(2,nres+j)-yi
2502             zj=c(3,nres+j)-zi
2503             rij=xj*xj+yj*yj+zj*zj
2504 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2505             r0ij=r0(itypi,itypj)
2506             r0ijsq=r0ij*r0ij
2507 c            print *,i,j,r0ij,dsqrt(rij)
2508             if (rij.lt.r0ijsq) then
2509               evdwij=0.25d0*(rij-r0ijsq)**2
2510               fac=rij-r0ijsq
2511             else
2512               evdwij=0.0d0
2513               fac=0.0d0
2514             endif
2515             evdw=evdw+evdwij
2516 C
2517 C Calculate the components of the gradient in DC and X
2518 C
2519             gg(1)=xj*fac
2520             gg(2)=yj*fac
2521             gg(3)=zj*fac
2522             do k=1,3
2523               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2524               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2525               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2526               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2527             enddo
2528 cgrad            do k=i,j-1
2529 cgrad              do l=1,3
2530 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2531 cgrad              enddo
2532 cgrad            enddo
2533           enddo ! j
2534         enddo ! iint
2535       enddo ! i
2536       return
2537       end
2538 C--------------------------------------------------------------------------
2539       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2540      &              eello_turn4)
2541 C
2542 C Soft-sphere potential of p-p interaction
2543 C
2544       implicit real*8 (a-h,o-z)
2545       include 'DIMENSIONS'
2546       include 'COMMON.CONTROL'
2547       include 'COMMON.IOUNITS'
2548       include 'COMMON.GEO'
2549       include 'COMMON.VAR'
2550       include 'COMMON.LOCAL'
2551       include 'COMMON.CHAIN'
2552       include 'COMMON.DERIV'
2553       include 'COMMON.INTERACT'
2554       include 'COMMON.CONTACTS'
2555       include 'COMMON.TORSION'
2556       include 'COMMON.VECTORS'
2557       include 'COMMON.FFIELD'
2558       dimension ggg(3)
2559       integer xshift,yshift,zshift
2560 C      write(iout,*) 'In EELEC_soft_sphere'
2561       ees=0.0D0
2562       evdw1=0.0D0
2563       eel_loc=0.0d0
2564       eello_turn3=0.0d0
2565       eello_turn4=0.0d0
2566       ind=0
2567       do i=iatel_s,iatel_e
2568         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2569         dxi=dc(1,i)
2570         dyi=dc(2,i)
2571         dzi=dc(3,i)
2572         xmedi=c(1,i)+0.5d0*dxi
2573         ymedi=c(2,i)+0.5d0*dyi
2574         zmedi=c(3,i)+0.5d0*dzi
2575           xmedi=mod(xmedi,boxxsize)
2576           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2577           ymedi=mod(ymedi,boxysize)
2578           if (ymedi.lt.0) ymedi=ymedi+boxysize
2579           zmedi=mod(zmedi,boxzsize)
2580           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2581         num_conti=0
2582 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2583         do j=ielstart(i),ielend(i)
2584           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2585           ind=ind+1
2586           iteli=itel(i)
2587           itelj=itel(j)
2588           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2589           r0ij=rpp(iteli,itelj)
2590           r0ijsq=r0ij*r0ij
2591           dxj=dc(1,j)
2592           dyj=dc(2,j)
2593           dzj=dc(3,j)
2594           xj=c(1,j)+0.5D0*dxj
2595           yj=c(2,j)+0.5D0*dyj
2596           zj=c(3,j)+0.5D0*dzj
2597           xj=mod(xj,boxxsize)
2598           if (xj.lt.0) xj=xj+boxxsize
2599           yj=mod(yj,boxysize)
2600           if (yj.lt.0) yj=yj+boxysize
2601           zj=mod(zj,boxzsize)
2602           if (zj.lt.0) zj=zj+boxzsize
2603       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2604       xj_safe=xj
2605       yj_safe=yj
2606       zj_safe=zj
2607       isubchap=0
2608       do xshift=-1,1
2609       do yshift=-1,1
2610       do zshift=-1,1
2611           xj=xj_safe+xshift*boxxsize
2612           yj=yj_safe+yshift*boxysize
2613           zj=zj_safe+zshift*boxzsize
2614           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2615           if(dist_temp.lt.dist_init) then
2616             dist_init=dist_temp
2617             xj_temp=xj
2618             yj_temp=yj
2619             zj_temp=zj
2620             isubchap=1
2621           endif
2622        enddo
2623        enddo
2624        enddo
2625        if (isubchap.eq.1) then
2626           xj=xj_temp-xmedi
2627           yj=yj_temp-ymedi
2628           zj=zj_temp-zmedi
2629        else
2630           xj=xj_safe-xmedi
2631           yj=yj_safe-ymedi
2632           zj=zj_safe-zmedi
2633        endif
2634           rij=xj*xj+yj*yj+zj*zj
2635             sss=sscale(sqrt(rij))
2636             sssgrad=sscagrad(sqrt(rij))
2637           if (rij.lt.r0ijsq) then
2638             evdw1ij=0.25d0*(rij-r0ijsq)**2
2639             fac=rij-r0ijsq
2640           else
2641             evdw1ij=0.0d0
2642             fac=0.0d0
2643           endif
2644           evdw1=evdw1+evdw1ij*sss
2645 C
2646 C Calculate contributions to the Cartesian gradient.
2647 C
2648           ggg(1)=fac*xj*sssgrad
2649           ggg(2)=fac*yj*sssgrad
2650           ggg(3)=fac*zj*sssgrad
2651           do k=1,3
2652             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2653             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2654           enddo
2655 *
2656 * Loop over residues i+1 thru j-1.
2657 *
2658 cgrad          do k=i+1,j-1
2659 cgrad            do l=1,3
2660 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2661 cgrad            enddo
2662 cgrad          enddo
2663         enddo ! j
2664       enddo   ! i
2665 cgrad      do i=nnt,nct-1
2666 cgrad        do k=1,3
2667 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2668 cgrad        enddo
2669 cgrad        do j=i+1,nct-1
2670 cgrad          do k=1,3
2671 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2672 cgrad          enddo
2673 cgrad        enddo
2674 cgrad      enddo
2675       return
2676       end
2677 c------------------------------------------------------------------------------
2678       subroutine vec_and_deriv
2679       implicit real*8 (a-h,o-z)
2680       include 'DIMENSIONS'
2681 #ifdef MPI
2682       include 'mpif.h'
2683 #endif
2684       include 'COMMON.IOUNITS'
2685       include 'COMMON.GEO'
2686       include 'COMMON.VAR'
2687       include 'COMMON.LOCAL'
2688       include 'COMMON.CHAIN'
2689       include 'COMMON.VECTORS'
2690       include 'COMMON.SETUP'
2691       include 'COMMON.TIME1'
2692       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2693 C Compute the local reference systems. For reference system (i), the
2694 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2695 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2696 #ifdef PARVEC
2697       do i=ivec_start,ivec_end
2698 #else
2699       do i=1,nres-1
2700 #endif
2701           if (i.eq.nres-1) then
2702 C Case of the last full residue
2703 C Compute the Z-axis
2704             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2705             costh=dcos(pi-theta(nres))
2706             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2707             do k=1,3
2708               uz(k,i)=fac*uz(k,i)
2709             enddo
2710 C Compute the derivatives of uz
2711             uzder(1,1,1)= 0.0d0
2712             uzder(2,1,1)=-dc_norm(3,i-1)
2713             uzder(3,1,1)= dc_norm(2,i-1)
2714             uzder(1,2,1)= dc_norm(3,i-1)
2715             uzder(2,2,1)= 0.0d0
2716             uzder(3,2,1)=-dc_norm(1,i-1)
2717             uzder(1,3,1)=-dc_norm(2,i-1)
2718             uzder(2,3,1)= dc_norm(1,i-1)
2719             uzder(3,3,1)= 0.0d0
2720             uzder(1,1,2)= 0.0d0
2721             uzder(2,1,2)= dc_norm(3,i)
2722             uzder(3,1,2)=-dc_norm(2,i)
2723             uzder(1,2,2)=-dc_norm(3,i)
2724             uzder(2,2,2)= 0.0d0
2725             uzder(3,2,2)= dc_norm(1,i)
2726             uzder(1,3,2)= dc_norm(2,i)
2727             uzder(2,3,2)=-dc_norm(1,i)
2728             uzder(3,3,2)= 0.0d0
2729 C Compute the Y-axis
2730             facy=fac
2731             do k=1,3
2732               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2733             enddo
2734 C Compute the derivatives of uy
2735             do j=1,3
2736               do k=1,3
2737                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2738      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2739                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2740               enddo
2741               uyder(j,j,1)=uyder(j,j,1)-costh
2742               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2743             enddo
2744             do j=1,2
2745               do k=1,3
2746                 do l=1,3
2747                   uygrad(l,k,j,i)=uyder(l,k,j)
2748                   uzgrad(l,k,j,i)=uzder(l,k,j)
2749                 enddo
2750               enddo
2751             enddo
2752             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2753             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2754             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2755             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2756           else
2757 C Other residues
2758 C Compute the Z-axis
2759             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2760             costh=dcos(pi-theta(i+2))
2761             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2762             do k=1,3
2763               uz(k,i)=fac*uz(k,i)
2764             enddo
2765 C Compute the derivatives of uz
2766             uzder(1,1,1)= 0.0d0
2767             uzder(2,1,1)=-dc_norm(3,i+1)
2768             uzder(3,1,1)= dc_norm(2,i+1)
2769             uzder(1,2,1)= dc_norm(3,i+1)
2770             uzder(2,2,1)= 0.0d0
2771             uzder(3,2,1)=-dc_norm(1,i+1)
2772             uzder(1,3,1)=-dc_norm(2,i+1)
2773             uzder(2,3,1)= dc_norm(1,i+1)
2774             uzder(3,3,1)= 0.0d0
2775             uzder(1,1,2)= 0.0d0
2776             uzder(2,1,2)= dc_norm(3,i)
2777             uzder(3,1,2)=-dc_norm(2,i)
2778             uzder(1,2,2)=-dc_norm(3,i)
2779             uzder(2,2,2)= 0.0d0
2780             uzder(3,2,2)= dc_norm(1,i)
2781             uzder(1,3,2)= dc_norm(2,i)
2782             uzder(2,3,2)=-dc_norm(1,i)
2783             uzder(3,3,2)= 0.0d0
2784 C Compute the Y-axis
2785             facy=fac
2786             do k=1,3
2787               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2788             enddo
2789 C Compute the derivatives of uy
2790             do j=1,3
2791               do k=1,3
2792                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2793      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2794                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2795               enddo
2796               uyder(j,j,1)=uyder(j,j,1)-costh
2797               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2798             enddo
2799             do j=1,2
2800               do k=1,3
2801                 do l=1,3
2802                   uygrad(l,k,j,i)=uyder(l,k,j)
2803                   uzgrad(l,k,j,i)=uzder(l,k,j)
2804                 enddo
2805               enddo
2806             enddo
2807             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2808             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2809             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2810             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2811           endif
2812       enddo
2813       do i=1,nres-1
2814         vbld_inv_temp(1)=vbld_inv(i+1)
2815         if (i.lt.nres-1) then
2816           vbld_inv_temp(2)=vbld_inv(i+2)
2817           else
2818           vbld_inv_temp(2)=vbld_inv(i)
2819           endif
2820         do j=1,2
2821           do k=1,3
2822             do l=1,3
2823               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2824               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2825             enddo
2826           enddo
2827         enddo
2828       enddo
2829 #if defined(PARVEC) && defined(MPI)
2830       if (nfgtasks1.gt.1) then
2831         time00=MPI_Wtime()
2832 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2833 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2834 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2835         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2836      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2837      &   FG_COMM1,IERR)
2838         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2839      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2840      &   FG_COMM1,IERR)
2841         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2842      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2843      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2844         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2845      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2846      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2847         time_gather=time_gather+MPI_Wtime()-time00
2848       endif
2849 #endif
2850 #ifdef DEBUG
2851       if (fg_rank.eq.0) then
2852         write (iout,*) "Arrays UY and UZ"
2853         do i=1,nres-1
2854           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2855      &     (uz(k,i),k=1,3)
2856         enddo
2857       endif
2858 #endif
2859       return
2860       end
2861 C-----------------------------------------------------------------------------
2862       subroutine check_vecgrad
2863       implicit real*8 (a-h,o-z)
2864       include 'DIMENSIONS'
2865       include 'COMMON.IOUNITS'
2866       include 'COMMON.GEO'
2867       include 'COMMON.VAR'
2868       include 'COMMON.LOCAL'
2869       include 'COMMON.CHAIN'
2870       include 'COMMON.VECTORS'
2871       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2872       dimension uyt(3,maxres),uzt(3,maxres)
2873       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2874       double precision delta /1.0d-7/
2875       call vec_and_deriv
2876 cd      do i=1,nres
2877 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2878 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2879 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2880 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2881 cd     &     (dc_norm(if90,i),if90=1,3)
2882 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2883 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2884 cd          write(iout,'(a)')
2885 cd      enddo
2886       do i=1,nres
2887         do j=1,2
2888           do k=1,3
2889             do l=1,3
2890               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2891               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2892             enddo
2893           enddo
2894         enddo
2895       enddo
2896       call vec_and_deriv
2897       do i=1,nres
2898         do j=1,3
2899           uyt(j,i)=uy(j,i)
2900           uzt(j,i)=uz(j,i)
2901         enddo
2902       enddo
2903       do i=1,nres
2904 cd        write (iout,*) 'i=',i
2905         do k=1,3
2906           erij(k)=dc_norm(k,i)
2907         enddo
2908         do j=1,3
2909           do k=1,3
2910             dc_norm(k,i)=erij(k)
2911           enddo
2912           dc_norm(j,i)=dc_norm(j,i)+delta
2913 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2914 c          do k=1,3
2915 c            dc_norm(k,i)=dc_norm(k,i)/fac
2916 c          enddo
2917 c          write (iout,*) (dc_norm(k,i),k=1,3)
2918 c          write (iout,*) (erij(k),k=1,3)
2919           call vec_and_deriv
2920           do k=1,3
2921             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2922             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2923             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2924             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2925           enddo
2926 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2927 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2928 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2929         enddo
2930         do k=1,3
2931           dc_norm(k,i)=erij(k)
2932         enddo
2933 cd        do k=1,3
2934 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2935 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2936 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2937 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2938 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2939 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2940 cd          write (iout,'(a)')
2941 cd        enddo
2942       enddo
2943       return
2944       end
2945 C--------------------------------------------------------------------------
2946       subroutine set_matrices
2947       implicit real*8 (a-h,o-z)
2948       include 'DIMENSIONS'
2949 #ifdef MPI
2950       include "mpif.h"
2951       include "COMMON.SETUP"
2952       integer IERR
2953       integer status(MPI_STATUS_SIZE)
2954 #endif
2955       include 'COMMON.IOUNITS'
2956       include 'COMMON.GEO'
2957       include 'COMMON.VAR'
2958       include 'COMMON.LOCAL'
2959       include 'COMMON.CHAIN'
2960       include 'COMMON.DERIV'
2961       include 'COMMON.INTERACT'
2962       include 'COMMON.CONTACTS'
2963       include 'COMMON.TORSION'
2964       include 'COMMON.VECTORS'
2965       include 'COMMON.FFIELD'
2966       double precision auxvec(2),auxmat(2,2)
2967 C
2968 C Compute the virtual-bond-torsional-angle dependent quantities needed
2969 C to calculate the el-loc multibody terms of various order.
2970 C
2971 c      write(iout,*) 'nphi=',nphi,nres
2972 c      write(iout,*) "itype2loc",itype2loc
2973 #ifdef PARMAT
2974       do i=ivec_start+2,ivec_end+2
2975 #else
2976       do i=3,nres+1
2977 #endif
2978         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2979           iti = itype2loc(itype(i-2))
2980         else
2981           iti=nloctyp
2982         endif
2983 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2984         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2985           iti1 = itype2loc(itype(i-1))
2986         else
2987           iti1=nloctyp
2988         endif
2989 c        write(iout,*),i
2990 #ifdef NEWCORR
2991         cost1=dcos(theta(i-1))
2992         sint1=dsin(theta(i-1))
2993         sint1sq=sint1*sint1
2994         sint1cub=sint1sq*sint1
2995         sint1cost1=2*sint1*cost1
2996 c        write (iout,*) "bnew1",i,iti
2997 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2998 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2999 c        write (iout,*) "bnew2",i,iti
3000 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3001 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3002         do k=1,2
3003           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3004           b1(k,i-2)=sint1*b1k
3005           gtb1(k,i-2)=cost1*b1k-sint1sq*
3006      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3007           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3008           b2(k,i-2)=sint1*b2k
3009           gtb2(k,i-2)=cost1*b2k-sint1sq*
3010      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3011         enddo
3012         do k=1,2
3013           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3014           cc(1,k,i-2)=sint1sq*aux
3015           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3016      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3017           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3018           dd(1,k,i-2)=sint1sq*aux
3019           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3020      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3021         enddo
3022         cc(2,1,i-2)=cc(1,2,i-2)
3023         cc(2,2,i-2)=-cc(1,1,i-2)
3024         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3025         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3026         dd(2,1,i-2)=dd(1,2,i-2)
3027         dd(2,2,i-2)=-dd(1,1,i-2)
3028         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3029         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3030         do k=1,2
3031           do l=1,2
3032             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3033             EE(l,k,i-2)=sint1sq*aux
3034             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3035           enddo
3036         enddo
3037         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3038         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3039         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3040         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3041         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3042         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3043         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3044 c        b1tilde(1,i-2)=b1(1,i-2)
3045 c        b1tilde(2,i-2)=-b1(2,i-2)
3046 c        b2tilde(1,i-2)=b2(1,i-2)
3047 c        b2tilde(2,i-2)=-b2(2,i-2)
3048 #ifdef DEBUG
3049         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3050         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3051         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3052         write (iout,*) 'theta=', theta(i-1)
3053 #endif
3054 #else
3055         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3056           iti = itype2loc(itype(i-2))
3057         else
3058           iti=nloctyp
3059         endif
3060 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3061 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3062         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3063           iti1 = itype2loc(itype(i-1))
3064         else
3065           iti1=nloctyp
3066         endif
3067         b1(1,i-2)=b(3,iti)
3068         b1(2,i-2)=b(5,iti)
3069         b2(1,i-2)=b(2,iti)
3070         b2(2,i-2)=b(4,iti)
3071         do k=1,2
3072           do l=1,2
3073            CC(k,l,i-2)=ccold(k,l,iti)
3074            DD(k,l,i-2)=ddold(k,l,iti)
3075            EE(k,l,i-2)=eeold(k,l,iti)
3076            gtEE(k,l,i-2)=0.0d0
3077           enddo
3078         enddo
3079 #endif
3080         b1tilde(1,i-2)= b1(1,i-2)
3081         b1tilde(2,i-2)=-b1(2,i-2)
3082         b2tilde(1,i-2)= b2(1,i-2)
3083         b2tilde(2,i-2)=-b2(2,i-2)
3084 c
3085         Ctilde(1,1,i-2)= CC(1,1,i-2)
3086         Ctilde(1,2,i-2)= CC(1,2,i-2)
3087         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3088         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3089 c
3090         Dtilde(1,1,i-2)= DD(1,1,i-2)
3091         Dtilde(1,2,i-2)= DD(1,2,i-2)
3092         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3093         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3094 #ifdef DEBUG
3095         write(iout,*) "i",i," iti",iti
3096         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3097         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3098 #endif
3099       enddo
3100 #ifdef PARMAT
3101       do i=ivec_start+2,ivec_end+2
3102 #else
3103       do i=3,nres+1
3104 #endif
3105         if (i .lt. nres+1) then
3106           sin1=dsin(phi(i))
3107           cos1=dcos(phi(i))
3108           sintab(i-2)=sin1
3109           costab(i-2)=cos1
3110           obrot(1,i-2)=cos1
3111           obrot(2,i-2)=sin1
3112           sin2=dsin(2*phi(i))
3113           cos2=dcos(2*phi(i))
3114           sintab2(i-2)=sin2
3115           costab2(i-2)=cos2
3116           obrot2(1,i-2)=cos2
3117           obrot2(2,i-2)=sin2
3118           Ug(1,1,i-2)=-cos1
3119           Ug(1,2,i-2)=-sin1
3120           Ug(2,1,i-2)=-sin1
3121           Ug(2,2,i-2)= cos1
3122           Ug2(1,1,i-2)=-cos2
3123           Ug2(1,2,i-2)=-sin2
3124           Ug2(2,1,i-2)=-sin2
3125           Ug2(2,2,i-2)= cos2
3126         else
3127           costab(i-2)=1.0d0
3128           sintab(i-2)=0.0d0
3129           obrot(1,i-2)=1.0d0
3130           obrot(2,i-2)=0.0d0
3131           obrot2(1,i-2)=0.0d0
3132           obrot2(2,i-2)=0.0d0
3133           Ug(1,1,i-2)=1.0d0
3134           Ug(1,2,i-2)=0.0d0
3135           Ug(2,1,i-2)=0.0d0
3136           Ug(2,2,i-2)=1.0d0
3137           Ug2(1,1,i-2)=0.0d0
3138           Ug2(1,2,i-2)=0.0d0
3139           Ug2(2,1,i-2)=0.0d0
3140           Ug2(2,2,i-2)=0.0d0
3141         endif
3142         if (i .gt. 3 .and. i .lt. nres+1) then
3143           obrot_der(1,i-2)=-sin1
3144           obrot_der(2,i-2)= cos1
3145           Ugder(1,1,i-2)= sin1
3146           Ugder(1,2,i-2)=-cos1
3147           Ugder(2,1,i-2)=-cos1
3148           Ugder(2,2,i-2)=-sin1
3149           dwacos2=cos2+cos2
3150           dwasin2=sin2+sin2
3151           obrot2_der(1,i-2)=-dwasin2
3152           obrot2_der(2,i-2)= dwacos2
3153           Ug2der(1,1,i-2)= dwasin2
3154           Ug2der(1,2,i-2)=-dwacos2
3155           Ug2der(2,1,i-2)=-dwacos2
3156           Ug2der(2,2,i-2)=-dwasin2
3157         else
3158           obrot_der(1,i-2)=0.0d0
3159           obrot_der(2,i-2)=0.0d0
3160           Ugder(1,1,i-2)=0.0d0
3161           Ugder(1,2,i-2)=0.0d0
3162           Ugder(2,1,i-2)=0.0d0
3163           Ugder(2,2,i-2)=0.0d0
3164           obrot2_der(1,i-2)=0.0d0
3165           obrot2_der(2,i-2)=0.0d0
3166           Ug2der(1,1,i-2)=0.0d0
3167           Ug2der(1,2,i-2)=0.0d0
3168           Ug2der(2,1,i-2)=0.0d0
3169           Ug2der(2,2,i-2)=0.0d0
3170         endif
3171 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3172         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3173           iti = itype2loc(itype(i-2))
3174         else
3175           iti=nloctyp
3176         endif
3177 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3178         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3179           iti1 = itype2loc(itype(i-1))
3180         else
3181           iti1=nloctyp
3182         endif
3183 cd        write (iout,*) '*******i',i,' iti1',iti
3184 cd        write (iout,*) 'b1',b1(:,iti)
3185 cd        write (iout,*) 'b2',b2(:,iti)
3186 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3187 c        if (i .gt. iatel_s+2) then
3188         if (i .gt. nnt+2) then
3189           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3190 #ifdef NEWCORR
3191           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3192 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3193 #endif
3194 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3195 c     &    EE(1,2,iti),EE(2,2,i)
3196           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3197           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3198 c          write(iout,*) "Macierz EUG",
3199 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3200 c     &    eug(2,2,i-2)
3201           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3202      &    then
3203           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3204           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3205           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3206           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3207           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3208           endif
3209         else
3210           do k=1,2
3211             Ub2(k,i-2)=0.0d0
3212             Ctobr(k,i-2)=0.0d0
3213             Dtobr2(k,i-2)=0.0d0
3214             do l=1,2
3215               EUg(l,k,i-2)=0.0d0
3216               CUg(l,k,i-2)=0.0d0
3217               DUg(l,k,i-2)=0.0d0
3218               DtUg2(l,k,i-2)=0.0d0
3219             enddo
3220           enddo
3221         endif
3222         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3223         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3224         do k=1,2
3225           muder(k,i-2)=Ub2der(k,i-2)
3226         enddo
3227 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3228         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3229           if (itype(i-1).le.ntyp) then
3230             iti1 = itype2loc(itype(i-1))
3231           else
3232             iti1=nloctyp
3233           endif
3234         else
3235           iti1=nloctyp
3236         endif
3237         do k=1,2
3238           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3239 c          mu(k,i-2)=b1(k,i-1)
3240 c          mu(k,i-2)=Ub2(k,i-2)
3241         enddo
3242 #ifdef MUOUT
3243         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3244      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3245      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3246      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3247      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3248      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3249 #endif
3250 cd        write (iout,*) 'mu1',mu1(:,i-2)
3251 cd        write (iout,*) 'mu2',mu2(:,i-2)
3252 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3253         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3254      &  then
3255         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3256         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3257         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3258         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3259         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3260 C Vectors and matrices dependent on a single virtual-bond dihedral.
3261         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3262         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3263         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3264         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3265         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3266         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3267         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3268         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3269         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3270         endif
3271       enddo
3272 C Matrices dependent on two consecutive virtual-bond dihedrals.
3273 C The order of matrices is from left to right.
3274       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3275      &then
3276 c      do i=max0(ivec_start,2),ivec_end
3277       do i=2,nres-1
3278         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3279         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3280         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3281         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3282         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3283         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3284         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3285         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3286       enddo
3287       endif
3288 #if defined(MPI) && defined(PARMAT)
3289 #ifdef DEBUG
3290 c      if (fg_rank.eq.0) then
3291         write (iout,*) "Arrays UG and UGDER before GATHER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     ((ug(l,k,i),l=1,2),k=1,2),
3295      &     ((ugder(l,k,i),l=1,2),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays UG2 and UG2DER"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300      &     ((ug2(l,k,i),l=1,2),k=1,2),
3301      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3302         enddo
3303         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3304         do i=1,nres-1
3305           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3306      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3307      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3308         enddo
3309         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3310         do i=1,nres-1
3311           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3312      &     costab(i),sintab(i),costab2(i),sintab2(i)
3313         enddo
3314         write (iout,*) "Array MUDER"
3315         do i=1,nres-1
3316           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3317         enddo
3318 c      endif
3319 #endif
3320       if (nfgtasks.gt.1) then
3321         time00=MPI_Wtime()
3322 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3323 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3324 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3325 #ifdef MATGATHER
3326         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3327      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3331      &   FG_COMM1,IERR)
3332         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3337      &   FG_COMM1,IERR)
3338         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3342      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3343      &   FG_COMM1,IERR)
3344         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3345      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3346      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3347         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3348      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3349      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3350         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3351      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3352      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3353         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3354      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3355      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3356         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3357      &  then
3358         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3359      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3360      &   FG_COMM1,IERR)
3361         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3362      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3363      &   FG_COMM1,IERR)
3364         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3365      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3366      &   FG_COMM1,IERR)
3367        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3368      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3369      &   FG_COMM1,IERR)
3370         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3371      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3372      &   FG_COMM1,IERR)
3373         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3374      &   ivec_count(fg_rank1),
3375      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3376      &   FG_COMM1,IERR)
3377         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3378      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3379      &   FG_COMM1,IERR)
3380         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3381      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3382      &   FG_COMM1,IERR)
3383         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3384      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3385      &   FG_COMM1,IERR)
3386         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3387      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3388      &   FG_COMM1,IERR)
3389         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3390      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3391      &   FG_COMM1,IERR)
3392         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3393      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3394      &   FG_COMM1,IERR)
3395         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3396      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3397      &   FG_COMM1,IERR)
3398         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3399      &   ivec_count(fg_rank1),
3400      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3401      &   FG_COMM1,IERR)
3402         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3403      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3404      &   FG_COMM1,IERR)
3405        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3406      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3407      &   FG_COMM1,IERR)
3408         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3409      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3410      &   FG_COMM1,IERR)
3411        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3412      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3413      &   FG_COMM1,IERR)
3414         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3415      &   ivec_count(fg_rank1),
3416      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3417      &   FG_COMM1,IERR)
3418         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3419      &   ivec_count(fg_rank1),
3420      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3421      &   FG_COMM1,IERR)
3422         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3423      &   ivec_count(fg_rank1),
3424      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3425      &   MPI_MAT2,FG_COMM1,IERR)
3426         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3427      &   ivec_count(fg_rank1),
3428      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3429      &   MPI_MAT2,FG_COMM1,IERR)
3430         endif
3431 #else
3432 c Passes matrix info through the ring
3433       isend=fg_rank1
3434       irecv=fg_rank1-1
3435       if (irecv.lt.0) irecv=nfgtasks1-1
3436       iprev=irecv
3437       inext=fg_rank1+1
3438       if (inext.ge.nfgtasks1) inext=0
3439       do i=1,nfgtasks1-1
3440 c        write (iout,*) "isend",isend," irecv",irecv
3441 c        call flush(iout)
3442         lensend=lentyp(isend)
3443         lenrecv=lentyp(irecv)
3444 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3445 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3446 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3447 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3448 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3449 c        write (iout,*) "Gather ROTAT1"
3450 c        call flush(iout)
3451 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3452 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3453 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3454 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3455 c        write (iout,*) "Gather ROTAT2"
3456 c        call flush(iout)
3457         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3458      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3459      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3460      &   iprev,4400+irecv,FG_COMM,status,IERR)
3461 c        write (iout,*) "Gather ROTAT_OLD"
3462 c        call flush(iout)
3463         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3464      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3465      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3466      &   iprev,5500+irecv,FG_COMM,status,IERR)
3467 c        write (iout,*) "Gather PRECOMP11"
3468 c        call flush(iout)
3469         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3470      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3471      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3472      &   iprev,6600+irecv,FG_COMM,status,IERR)
3473 c        write (iout,*) "Gather PRECOMP12"
3474 c        call flush(iout)
3475         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3476      &  then
3477         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3478      &   MPI_ROTAT2(lensend),inext,7700+isend,
3479      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3480      &   iprev,7700+irecv,FG_COMM,status,IERR)
3481 c        write (iout,*) "Gather PRECOMP21"
3482 c        call flush(iout)
3483         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3484      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3485      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3486      &   iprev,8800+irecv,FG_COMM,status,IERR)
3487 c        write (iout,*) "Gather PRECOMP22"
3488 c        call flush(iout)
3489         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3490      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3491      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3492      &   MPI_PRECOMP23(lenrecv),
3493      &   iprev,9900+irecv,FG_COMM,status,IERR)
3494 c        write (iout,*) "Gather PRECOMP23"
3495 c        call flush(iout)
3496         endif
3497         isend=irecv
3498         irecv=irecv-1
3499         if (irecv.lt.0) irecv=nfgtasks1-1
3500       enddo
3501 #endif
3502         time_gather=time_gather+MPI_Wtime()-time00
3503       endif
3504 #ifdef DEBUG
3505 c      if (fg_rank.eq.0) then
3506         write (iout,*) "Arrays UG and UGDER"
3507         do i=1,nres-1
3508           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3509      &     ((ug(l,k,i),l=1,2),k=1,2),
3510      &     ((ugder(l,k,i),l=1,2),k=1,2)
3511         enddo
3512         write (iout,*) "Arrays UG2 and UG2DER"
3513         do i=1,nres-1
3514           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3515      &     ((ug2(l,k,i),l=1,2),k=1,2),
3516      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3517         enddo
3518         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3519         do i=1,nres-1
3520           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3521      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3522      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3523         enddo
3524         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3525         do i=1,nres-1
3526           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3527      &     costab(i),sintab(i),costab2(i),sintab2(i)
3528         enddo
3529         write (iout,*) "Array MUDER"
3530         do i=1,nres-1
3531           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3532         enddo
3533 c      endif
3534 #endif
3535 #endif
3536 cd      do i=1,nres
3537 cd        iti = itype2loc(itype(i))
3538 cd        write (iout,*) i
3539 cd        do j=1,2
3540 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3541 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3542 cd        enddo
3543 cd      enddo
3544       return
3545       end
3546 C--------------------------------------------------------------------------
3547       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3548 C
3549 C This subroutine calculates the average interaction energy and its gradient
3550 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3551 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3552 C The potential depends both on the distance of peptide-group centers and on
3553 C the orientation of the CA-CA virtual bonds.
3554 C
3555       implicit real*8 (a-h,o-z)
3556 #ifdef MPI
3557       include 'mpif.h'
3558 #endif
3559       include 'DIMENSIONS'
3560       include 'COMMON.CONTROL'
3561       include 'COMMON.SETUP'
3562       include 'COMMON.IOUNITS'
3563       include 'COMMON.GEO'
3564       include 'COMMON.VAR'
3565       include 'COMMON.LOCAL'
3566       include 'COMMON.CHAIN'
3567       include 'COMMON.DERIV'
3568       include 'COMMON.INTERACT'
3569       include 'COMMON.CONTACTS'
3570       include 'COMMON.TORSION'
3571       include 'COMMON.VECTORS'
3572       include 'COMMON.FFIELD'
3573       include 'COMMON.TIME1'
3574       include 'COMMON.SPLITELE'
3575       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3576      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3577       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3578      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3579       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3580      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3581      &    num_conti,j1,j2
3582 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3583 #ifdef MOMENT
3584       double precision scal_el /1.0d0/
3585 #else
3586       double precision scal_el /0.5d0/
3587 #endif
3588 C 12/13/98
3589 C 13-go grudnia roku pamietnego...
3590       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3591      &                   0.0d0,1.0d0,0.0d0,
3592      &                   0.0d0,0.0d0,1.0d0/
3593 cd      write(iout,*) 'In EELEC'
3594 cd      do i=1,nloctyp
3595 cd        write(iout,*) 'Type',i
3596 cd        write(iout,*) 'B1',B1(:,i)
3597 cd        write(iout,*) 'B2',B2(:,i)
3598 cd        write(iout,*) 'CC',CC(:,:,i)
3599 cd        write(iout,*) 'DD',DD(:,:,i)
3600 cd        write(iout,*) 'EE',EE(:,:,i)
3601 cd      enddo
3602 cd      call check_vecgrad
3603 cd      stop
3604       if (icheckgrad.eq.1) then
3605         do i=1,nres-1
3606           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3607           do k=1,3
3608             dc_norm(k,i)=dc(k,i)*fac
3609           enddo
3610 c          write (iout,*) 'i',i,' fac',fac
3611         enddo
3612       endif
3613       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3614      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3615      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3616 c        call vec_and_deriv
3617 #ifdef TIMING
3618         time01=MPI_Wtime()
3619 #endif
3620         call set_matrices
3621 #ifdef TIMING
3622         time_mat=time_mat+MPI_Wtime()-time01
3623 #endif
3624       endif
3625 cd      do i=1,nres-1
3626 cd        write (iout,*) 'i=',i
3627 cd        do k=1,3
3628 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3629 cd        enddo
3630 cd        do k=1,3
3631 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3632 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3633 cd        enddo
3634 cd      enddo
3635       t_eelecij=0.0d0
3636       ees=0.0D0
3637       evdw1=0.0D0
3638       eel_loc=0.0d0
3639       eello_turn3=0.0d0
3640       eello_turn4=0.0d0
3641       ind=0
3642       do i=1,nres
3643         num_cont_hb(i)=0
3644       enddo
3645 cd      print '(a)','Enter EELEC'
3646 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3647       do i=1,nres
3648         gel_loc_loc(i)=0.0d0
3649         gcorr_loc(i)=0.0d0
3650       enddo
3651 c
3652 c
3653 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3654 C
3655 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3656 C
3657 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3658       do i=iturn3_start,iturn3_end
3659 c        if (i.le.1) cycle
3660 C        write(iout,*) "tu jest i",i
3661         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3662 C changes suggested by Ana to avoid out of bounds
3663 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3664 c     & .or.((i+4).gt.nres)
3665 c     & .or.((i-1).le.0)
3666 C end of changes by Ana
3667      &  .or. itype(i+2).eq.ntyp1
3668      &  .or. itype(i+3).eq.ntyp1) cycle
3669 C Adam: Instructions below will switch off existing interactions
3670 c        if(i.gt.1)then
3671 c          if(itype(i-1).eq.ntyp1)cycle
3672 c        end if
3673 c        if(i.LT.nres-3)then
3674 c          if (itype(i+4).eq.ntyp1) cycle
3675 c        end if
3676         dxi=dc(1,i)
3677         dyi=dc(2,i)
3678         dzi=dc(3,i)
3679         dx_normi=dc_norm(1,i)
3680         dy_normi=dc_norm(2,i)
3681         dz_normi=dc_norm(3,i)
3682         xmedi=c(1,i)+0.5d0*dxi
3683         ymedi=c(2,i)+0.5d0*dyi
3684         zmedi=c(3,i)+0.5d0*dzi
3685           xmedi=mod(xmedi,boxxsize)
3686           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3687           ymedi=mod(ymedi,boxysize)
3688           if (ymedi.lt.0) ymedi=ymedi+boxysize
3689           zmedi=mod(zmedi,boxzsize)
3690           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3691         num_conti=0
3692         call eelecij(i,i+2,ees,evdw1,eel_loc)
3693         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3694         num_cont_hb(i)=num_conti
3695       enddo
3696       do i=iturn4_start,iturn4_end
3697         if (i.lt.1) cycle
3698         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3699 C changes suggested by Ana to avoid out of bounds
3700 c     & .or.((i+5).gt.nres)
3701 c     & .or.((i-1).le.0)
3702 C end of changes suggested by Ana
3703      &    .or. itype(i+3).eq.ntyp1
3704      &    .or. itype(i+4).eq.ntyp1
3705 c     &    .or. itype(i+5).eq.ntyp1
3706 c     &    .or. itype(i).eq.ntyp1
3707 c     &    .or. itype(i-1).eq.ntyp1
3708      &                             ) cycle
3709         dxi=dc(1,i)
3710         dyi=dc(2,i)
3711         dzi=dc(3,i)
3712         dx_normi=dc_norm(1,i)
3713         dy_normi=dc_norm(2,i)
3714         dz_normi=dc_norm(3,i)
3715         xmedi=c(1,i)+0.5d0*dxi
3716         ymedi=c(2,i)+0.5d0*dyi
3717         zmedi=c(3,i)+0.5d0*dzi
3718 C Return atom into box, boxxsize is size of box in x dimension
3719 c  194   continue
3720 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3721 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3722 C Condition for being inside the proper box
3723 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3724 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3725 c        go to 194
3726 c        endif
3727 c  195   continue
3728 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3729 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3730 C Condition for being inside the proper box
3731 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3732 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3733 c        go to 195
3734 c        endif
3735 c  196   continue
3736 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3737 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3738 C Condition for being inside the proper box
3739 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3740 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3741 c        go to 196
3742 c        endif
3743           xmedi=mod(xmedi,boxxsize)
3744           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3745           ymedi=mod(ymedi,boxysize)
3746           if (ymedi.lt.0) ymedi=ymedi+boxysize
3747           zmedi=mod(zmedi,boxzsize)
3748           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3749
3750         num_conti=num_cont_hb(i)
3751 c        write(iout,*) "JESTEM W PETLI"
3752         call eelecij(i,i+3,ees,evdw1,eel_loc)
3753         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3754      &   call eturn4(i,eello_turn4)
3755         num_cont_hb(i)=num_conti
3756       enddo   ! i
3757 C Loop over all neighbouring boxes
3758 C      do xshift=-1,1
3759 C      do yshift=-1,1
3760 C      do zshift=-1,1
3761 c
3762 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3763 c
3764 CTU KURWA
3765       do i=iatel_s,iatel_e
3766 C        do i=75,75
3767 c        if (i.le.1) cycle
3768         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3769 C changes suggested by Ana to avoid out of bounds
3770 c     & .or.((i+2).gt.nres)
3771 c     & .or.((i-1).le.0)
3772 C end of changes by Ana
3773 c     &  .or. itype(i+2).eq.ntyp1
3774 c     &  .or. itype(i-1).eq.ntyp1
3775      &                ) cycle
3776         dxi=dc(1,i)
3777         dyi=dc(2,i)
3778         dzi=dc(3,i)
3779         dx_normi=dc_norm(1,i)
3780         dy_normi=dc_norm(2,i)
3781         dz_normi=dc_norm(3,i)
3782         xmedi=c(1,i)+0.5d0*dxi
3783         ymedi=c(2,i)+0.5d0*dyi
3784         zmedi=c(3,i)+0.5d0*dzi
3785           xmedi=mod(xmedi,boxxsize)
3786           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3787           ymedi=mod(ymedi,boxysize)
3788           if (ymedi.lt.0) ymedi=ymedi+boxysize
3789           zmedi=mod(zmedi,boxzsize)
3790           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3791 C          xmedi=xmedi+xshift*boxxsize
3792 C          ymedi=ymedi+yshift*boxysize
3793 C          zmedi=zmedi+zshift*boxzsize
3794
3795 C Return tom into box, boxxsize is size of box in x dimension
3796 c  164   continue
3797 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3798 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3799 C Condition for being inside the proper box
3800 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3801 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3802 c        go to 164
3803 c        endif
3804 c  165   continue
3805 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3806 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3807 C Condition for being inside the proper box
3808 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3809 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3810 c        go to 165
3811 c        endif
3812 c  166   continue
3813 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3814 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3815 cC Condition for being inside the proper box
3816 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3817 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3818 c        go to 166
3819 c        endif
3820
3821 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3822         num_conti=num_cont_hb(i)
3823 C I TU KURWA
3824         do j=ielstart(i),ielend(i)
3825 C          do j=16,17
3826 C          write (iout,*) i,j
3827 C         if (j.le.1) cycle
3828           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3829 C changes suggested by Ana to avoid out of bounds
3830 c     & .or.((j+2).gt.nres)
3831 c     & .or.((j-1).le.0)
3832 C end of changes by Ana
3833 c     & .or.itype(j+2).eq.ntyp1
3834 c     & .or.itype(j-1).eq.ntyp1
3835      &) cycle
3836           call eelecij(i,j,ees,evdw1,eel_loc)
3837         enddo ! j
3838         num_cont_hb(i)=num_conti
3839       enddo   ! i
3840 C     enddo   ! zshift
3841 C      enddo   ! yshift
3842 C      enddo   ! xshift
3843
3844 c      write (iout,*) "Number of loop steps in EELEC:",ind
3845 cd      do i=1,nres
3846 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3847 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3848 cd      enddo
3849 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3850 ccc      eel_loc=eel_loc+eello_turn3
3851 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3852       return
3853       end
3854 C-------------------------------------------------------------------------------
3855       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3856       implicit real*8 (a-h,o-z)
3857       include 'DIMENSIONS'
3858 #ifdef MPI
3859       include "mpif.h"
3860 #endif
3861       include 'COMMON.CONTROL'
3862       include 'COMMON.IOUNITS'
3863       include 'COMMON.GEO'
3864       include 'COMMON.VAR'
3865       include 'COMMON.LOCAL'
3866       include 'COMMON.CHAIN'
3867       include 'COMMON.DERIV'
3868       include 'COMMON.INTERACT'
3869       include 'COMMON.CONTACTS'
3870       include 'COMMON.TORSION'
3871       include 'COMMON.VECTORS'
3872       include 'COMMON.FFIELD'
3873       include 'COMMON.TIME1'
3874       include 'COMMON.SPLITELE'
3875       include 'COMMON.SHIELD'
3876       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3877      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3878       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3879      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3880      &    gmuij2(4),gmuji2(4)
3881       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3882      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3883      &    num_conti,j1,j2
3884 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3885 #ifdef MOMENT
3886       double precision scal_el /1.0d0/
3887 #else
3888       double precision scal_el /0.5d0/
3889 #endif
3890 C 12/13/98
3891 C 13-go grudnia roku pamietnego...
3892       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3893      &                   0.0d0,1.0d0,0.0d0,
3894      &                   0.0d0,0.0d0,1.0d0/
3895        integer xshift,yshift,zshift
3896 c          time00=MPI_Wtime()
3897 cd      write (iout,*) "eelecij",i,j
3898 c          ind=ind+1
3899           iteli=itel(i)
3900           itelj=itel(j)
3901           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3902           aaa=app(iteli,itelj)
3903           bbb=bpp(iteli,itelj)
3904           ael6i=ael6(iteli,itelj)
3905           ael3i=ael3(iteli,itelj)
3906           dxj=dc(1,j)
3907           dyj=dc(2,j)
3908           dzj=dc(3,j)
3909           dx_normj=dc_norm(1,j)
3910           dy_normj=dc_norm(2,j)
3911           dz_normj=dc_norm(3,j)
3912 C          xj=c(1,j)+0.5D0*dxj-xmedi
3913 C          yj=c(2,j)+0.5D0*dyj-ymedi
3914 C          zj=c(3,j)+0.5D0*dzj-zmedi
3915           xj=c(1,j)+0.5D0*dxj
3916           yj=c(2,j)+0.5D0*dyj
3917           zj=c(3,j)+0.5D0*dzj
3918           xj=mod(xj,boxxsize)
3919           if (xj.lt.0) xj=xj+boxxsize
3920           yj=mod(yj,boxysize)
3921           if (yj.lt.0) yj=yj+boxysize
3922           zj=mod(zj,boxzsize)
3923           if (zj.lt.0) zj=zj+boxzsize
3924           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3925       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3926       xj_safe=xj
3927       yj_safe=yj
3928       zj_safe=zj
3929       isubchap=0
3930       do xshift=-1,1
3931       do yshift=-1,1
3932       do zshift=-1,1
3933           xj=xj_safe+xshift*boxxsize
3934           yj=yj_safe+yshift*boxysize
3935           zj=zj_safe+zshift*boxzsize
3936           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3937           if(dist_temp.lt.dist_init) then
3938             dist_init=dist_temp
3939             xj_temp=xj
3940             yj_temp=yj
3941             zj_temp=zj
3942             isubchap=1
3943           endif
3944        enddo
3945        enddo
3946        enddo
3947        if (isubchap.eq.1) then
3948           xj=xj_temp-xmedi
3949           yj=yj_temp-ymedi
3950           zj=zj_temp-zmedi
3951        else
3952           xj=xj_safe-xmedi
3953           yj=yj_safe-ymedi
3954           zj=zj_safe-zmedi
3955        endif
3956 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3957 c  174   continue
3958 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3959 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3960 C Condition for being inside the proper box
3961 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3962 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3963 c        go to 174
3964 c        endif
3965 c  175   continue
3966 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3967 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3968 C Condition for being inside the proper box
3969 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3970 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3971 c        go to 175
3972 c        endif
3973 c  176   continue
3974 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3975 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3976 C Condition for being inside the proper box
3977 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3978 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3979 c        go to 176
3980 c        endif
3981 C        endif !endPBC condintion
3982 C        xj=xj-xmedi
3983 C        yj=yj-ymedi
3984 C        zj=zj-zmedi
3985           rij=xj*xj+yj*yj+zj*zj
3986
3987             sss=sscale(sqrt(rij))
3988             sssgrad=sscagrad(sqrt(rij))
3989 c            if (sss.gt.0.0d0) then
3990           rrmij=1.0D0/rij
3991           rij=dsqrt(rij)
3992           rmij=1.0D0/rij
3993           r3ij=rrmij*rmij
3994           r6ij=r3ij*r3ij
3995           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3996           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3997           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3998           fac=cosa-3.0D0*cosb*cosg
3999           ev1=aaa*r6ij*r6ij
4000 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4001           if (j.eq.i+2) ev1=scal_el*ev1
4002           ev2=bbb*r6ij
4003           fac3=ael6i*r6ij
4004           fac4=ael3i*r3ij
4005           evdwij=(ev1+ev2)
4006           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4007           el2=fac4*fac
4008 C MARYSIA
4009 C          eesij=(el1+el2)
4010 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4011           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4012           if (shield_mode.gt.0) then
4013 C          fac_shield(i)=0.4
4014 C          fac_shield(j)=0.6
4015           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4016           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4017           eesij=(el1+el2)
4018           ees=ees+eesij
4019           else
4020           fac_shield(i)=1.0
4021           fac_shield(j)=1.0
4022           eesij=(el1+el2)
4023           ees=ees+eesij
4024           endif
4025           evdw1=evdw1+evdwij*sss
4026 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4027 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4028 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4029 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4030
4031           if (energy_dec) then
4032               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4033      &'evdw1',i,j,evdwij
4034      &,iteli,itelj,aaa,evdw1,sss
4035               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4036      &fac_shield(i),fac_shield(j)
4037           endif
4038
4039 C
4040 C Calculate contributions to the Cartesian gradient.
4041 C
4042 #ifdef SPLITELE
4043           facvdw=-6*rrmij*(ev1+evdwij)*sss
4044           facel=-3*rrmij*(el1+eesij)
4045           fac1=fac
4046           erij(1)=xj*rmij
4047           erij(2)=yj*rmij
4048           erij(3)=zj*rmij
4049
4050 *
4051 * Radial derivatives. First process both termini of the fragment (i,j)
4052 *
4053           ggg(1)=facel*xj
4054           ggg(2)=facel*yj
4055           ggg(3)=facel*zj
4056           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4057      &  (shield_mode.gt.0)) then
4058 C          print *,i,j
4059           do ilist=1,ishield_list(i)
4060            iresshield=shield_list(ilist,i)
4061            do k=1,3
4062            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4063      &      *2.0
4064            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4065      &              rlocshield
4066      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4067             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4068 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4069 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4070 C             if (iresshield.gt.i) then
4071 C               do ishi=i+1,iresshield-1
4072 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4073 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4074 C
4075 C              enddo
4076 C             else
4077 C               do ishi=iresshield,i
4078 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4079 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4080 C
4081 C               enddo
4082 C              endif
4083            enddo
4084           enddo
4085           do ilist=1,ishield_list(j)
4086            iresshield=shield_list(ilist,j)
4087            do k=1,3
4088            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4089      &     *2.0
4090            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4091      &              rlocshield
4092      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4093            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4094
4095 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4096 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4097 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4098 C             if (iresshield.gt.j) then
4099 C               do ishi=j+1,iresshield-1
4100 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4101 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4102 C
4103 C               enddo
4104 C            else
4105 C               do ishi=iresshield,j
4106 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4107 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4108 C               enddo
4109 C              endif
4110            enddo
4111           enddo
4112
4113           do k=1,3
4114             gshieldc(k,i)=gshieldc(k,i)+
4115      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4116             gshieldc(k,j)=gshieldc(k,j)+
4117      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4118             gshieldc(k,i-1)=gshieldc(k,i-1)+
4119      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4120             gshieldc(k,j-1)=gshieldc(k,j-1)+
4121      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4122
4123            enddo
4124            endif
4125 c          do k=1,3
4126 c            ghalf=0.5D0*ggg(k)
4127 c            gelc(k,i)=gelc(k,i)+ghalf
4128 c            gelc(k,j)=gelc(k,j)+ghalf
4129 c          enddo
4130 c 9/28/08 AL Gradient compotents will be summed only at the end
4131 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4132           do k=1,3
4133             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4134 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4135             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4136 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4137 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4138 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4139 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4140 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4141           enddo
4142 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4143
4144 *
4145 * Loop over residues i+1 thru j-1.
4146 *
4147 cgrad          do k=i+1,j-1
4148 cgrad            do l=1,3
4149 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4150 cgrad            enddo
4151 cgrad          enddo
4152           if (sss.gt.0.0) then
4153           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4154           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4155           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4156           else
4157           ggg(1)=0.0
4158           ggg(2)=0.0
4159           ggg(3)=0.0
4160           endif
4161 c          do k=1,3
4162 c            ghalf=0.5D0*ggg(k)
4163 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4164 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4165 c          enddo
4166 c 9/28/08 AL Gradient compotents will be summed only at the end
4167           do k=1,3
4168             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4169             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4170           enddo
4171 *
4172 * Loop over residues i+1 thru j-1.
4173 *
4174 cgrad          do k=i+1,j-1
4175 cgrad            do l=1,3
4176 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4177 cgrad            enddo
4178 cgrad          enddo
4179 #else
4180 C MARYSIA
4181           facvdw=(ev1+evdwij)*sss
4182           facel=(el1+eesij)
4183           fac1=fac
4184           fac=-3*rrmij*(facvdw+facvdw+facel)
4185           erij(1)=xj*rmij
4186           erij(2)=yj*rmij
4187           erij(3)=zj*rmij
4188 *
4189 * Radial derivatives. First process both termini of the fragment (i,j)
4190 *
4191           ggg(1)=fac*xj
4192 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4193           ggg(2)=fac*yj
4194 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4195           ggg(3)=fac*zj
4196 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4197 c          do k=1,3
4198 c            ghalf=0.5D0*ggg(k)
4199 c            gelc(k,i)=gelc(k,i)+ghalf
4200 c            gelc(k,j)=gelc(k,j)+ghalf
4201 c          enddo
4202 c 9/28/08 AL Gradient compotents will be summed only at the end
4203           do k=1,3
4204             gelc_long(k,j)=gelc(k,j)+ggg(k)
4205             gelc_long(k,i)=gelc(k,i)-ggg(k)
4206           enddo
4207 *
4208 * Loop over residues i+1 thru j-1.
4209 *
4210 cgrad          do k=i+1,j-1
4211 cgrad            do l=1,3
4212 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4213 cgrad            enddo
4214 cgrad          enddo
4215 c 9/28/08 AL Gradient compotents will be summed only at the end
4216           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4217           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4218           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4219           do k=1,3
4220             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4221             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4222           enddo
4223 #endif
4224 *
4225 * Angular part
4226 *
4227           ecosa=2.0D0*fac3*fac1+fac4
4228           fac4=-3.0D0*fac4
4229           fac3=-6.0D0*fac3
4230           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4231           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4232           do k=1,3
4233             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4234             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4235           enddo
4236 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4237 cd   &          (dcosg(k),k=1,3)
4238           do k=1,3
4239             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4240      &      fac_shield(i)**2*fac_shield(j)**2
4241           enddo
4242 c          do k=1,3
4243 c            ghalf=0.5D0*ggg(k)
4244 c            gelc(k,i)=gelc(k,i)+ghalf
4245 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4246 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4247 c            gelc(k,j)=gelc(k,j)+ghalf
4248 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4249 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4250 c          enddo
4251 cgrad          do k=i+1,j-1
4252 cgrad            do l=1,3
4253 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4254 cgrad            enddo
4255 cgrad          enddo
4256 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4257           do k=1,3
4258             gelc(k,i)=gelc(k,i)
4259      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4260      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4261      &           *fac_shield(i)**2*fac_shield(j)**2
4262             gelc(k,j)=gelc(k,j)
4263      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4264      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4265      &           *fac_shield(i)**2*fac_shield(j)**2
4266             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4267             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4268           enddo
4269 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4270
4271 C MARYSIA
4272 c          endif !sscale
4273           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4274      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4275      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4276 C
4277 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4278 C   energy of a peptide unit is assumed in the form of a second-order
4279 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4280 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4281 C   are computed for EVERY pair of non-contiguous peptide groups.
4282 C
4283
4284           if (j.lt.nres-1) then
4285             j1=j+1
4286             j2=j-1
4287           else
4288             j1=j-1
4289             j2=j-2
4290           endif
4291           kkk=0
4292           lll=0
4293           do k=1,2
4294             do l=1,2
4295               kkk=kkk+1
4296               muij(kkk)=mu(k,i)*mu(l,j)
4297 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4298 #ifdef NEWCORR
4299              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4300 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4301              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4302              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4303 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4304              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4305 #endif
4306             enddo
4307           enddo
4308 #ifdef DEBUG
4309           write (iout,*) 'EELEC: i',i,' j',j
4310           write (iout,*) 'j',j,' j1',j1,' j2',j2
4311           write(iout,*) 'muij',muij
4312 #endif
4313           ury=scalar(uy(1,i),erij)
4314           urz=scalar(uz(1,i),erij)
4315           vry=scalar(uy(1,j),erij)
4316           vrz=scalar(uz(1,j),erij)
4317           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4318           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4319           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4320           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4321           fac=dsqrt(-ael6i)*r3ij
4322 #ifdef DEBUG
4323           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4324           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4325      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4326      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4327      &      "uzvz",scalar(uz(1,i),uz(1,j))
4328           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329           write (iout,*) "fac",fac
4330 #endif
4331           a22=a22*fac
4332           a23=a23*fac
4333           a32=a32*fac
4334           a33=a33*fac
4335 #ifdef DEBUG
4336           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4337 #endif
4338 #undef DEBUG
4339 cd          write (iout,'(4i5,4f10.5)')
4340 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4341 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4342 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4343 cd     &      uy(:,j),uz(:,j)
4344 cd          write (iout,'(4f10.5)')
4345 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4346 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4347 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4348 cd           write (iout,'(9f10.5/)')
4349 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4350 C Derivatives of the elements of A in virtual-bond vectors
4351           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4352           do k=1,3
4353             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4354             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4355             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4356             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4357             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4358             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4359             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4360             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4361             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4362             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4363             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4364             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4365           enddo
4366 C Compute radial contributions to the gradient
4367           facr=-3.0d0*rrmij
4368           a22der=a22*facr
4369           a23der=a23*facr
4370           a32der=a32*facr
4371           a33der=a33*facr
4372           agg(1,1)=a22der*xj
4373           agg(2,1)=a22der*yj
4374           agg(3,1)=a22der*zj
4375           agg(1,2)=a23der*xj
4376           agg(2,2)=a23der*yj
4377           agg(3,2)=a23der*zj
4378           agg(1,3)=a32der*xj
4379           agg(2,3)=a32der*yj
4380           agg(3,3)=a32der*zj
4381           agg(1,4)=a33der*xj
4382           agg(2,4)=a33der*yj
4383           agg(3,4)=a33der*zj
4384 C Add the contributions coming from er
4385           fac3=-3.0d0*fac
4386           do k=1,3
4387             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4388             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4389             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4390             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4391           enddo
4392           do k=1,3
4393 C Derivatives in DC(i)
4394 cgrad            ghalf1=0.5d0*agg(k,1)
4395 cgrad            ghalf2=0.5d0*agg(k,2)
4396 cgrad            ghalf3=0.5d0*agg(k,3)
4397 cgrad            ghalf4=0.5d0*agg(k,4)
4398             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4399      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4400             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4401      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4402             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4403      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4404             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4405      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4406 C Derivatives in DC(i+1)
4407             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4408      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4409             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4410      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4411             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4412      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4413             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4414      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4415 C Derivatives in DC(j)
4416             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4417      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4418             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4419      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4420             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4421      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4422             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4423      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4424 C Derivatives in DC(j+1) or DC(nres-1)
4425             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4426      &      -3.0d0*vryg(k,3)*ury)
4427             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4428      &      -3.0d0*vrzg(k,3)*ury)
4429             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4430      &      -3.0d0*vryg(k,3)*urz)
4431             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4432      &      -3.0d0*vrzg(k,3)*urz)
4433 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4434 cgrad              do l=1,4
4435 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4436 cgrad              enddo
4437 cgrad            endif
4438           enddo
4439           acipa(1,1)=a22
4440           acipa(1,2)=a23
4441           acipa(2,1)=a32
4442           acipa(2,2)=a33
4443           a22=-a22
4444           a23=-a23
4445           do l=1,2
4446             do k=1,3
4447               agg(k,l)=-agg(k,l)
4448               aggi(k,l)=-aggi(k,l)
4449               aggi1(k,l)=-aggi1(k,l)
4450               aggj(k,l)=-aggj(k,l)
4451               aggj1(k,l)=-aggj1(k,l)
4452             enddo
4453           enddo
4454           if (j.lt.nres-1) then
4455             a22=-a22
4456             a32=-a32
4457             do l=1,3,2
4458               do k=1,3
4459                 agg(k,l)=-agg(k,l)
4460                 aggi(k,l)=-aggi(k,l)
4461                 aggi1(k,l)=-aggi1(k,l)
4462                 aggj(k,l)=-aggj(k,l)
4463                 aggj1(k,l)=-aggj1(k,l)
4464               enddo
4465             enddo
4466           else
4467             a22=-a22
4468             a23=-a23
4469             a32=-a32
4470             a33=-a33
4471             do l=1,4
4472               do k=1,3
4473                 agg(k,l)=-agg(k,l)
4474                 aggi(k,l)=-aggi(k,l)
4475                 aggi1(k,l)=-aggi1(k,l)
4476                 aggj(k,l)=-aggj(k,l)
4477                 aggj1(k,l)=-aggj1(k,l)
4478               enddo
4479             enddo
4480           endif
4481           ENDIF ! WCORR
4482           IF (wel_loc.gt.0.0d0) THEN
4483 C Contribution to the local-electrostatic energy coming from the i-j pair
4484           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4485      &     +a33*muij(4)
4486 #ifdef DEBUG
4487           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4488      &     " a33",a33
4489           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4490      &     " wel_loc",wel_loc
4491 #endif
4492           if (shield_mode.eq.0) then
4493            fac_shield(i)=1.0
4494            fac_shield(j)=1.0
4495 C          else
4496 C           fac_shield(i)=0.4
4497 C           fac_shield(j)=0.6
4498           endif
4499           eel_loc_ij=eel_loc_ij
4500      &    *fac_shield(i)*fac_shield(j)
4501 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4502 c     &            'eelloc',i,j,eel_loc_ij
4503 C Now derivative over eel_loc
4504           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4505      &  (shield_mode.gt.0)) then
4506 C          print *,i,j
4507
4508           do ilist=1,ishield_list(i)
4509            iresshield=shield_list(ilist,i)
4510            do k=1,3
4511            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4512      &                                          /fac_shield(i)
4513 C     &      *2.0
4514            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4515      &              rlocshield
4516      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4517             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4518      &      +rlocshield
4519            enddo
4520           enddo
4521           do ilist=1,ishield_list(j)
4522            iresshield=shield_list(ilist,j)
4523            do k=1,3
4524            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4525      &                                       /fac_shield(j)
4526 C     &     *2.0
4527            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4528      &              rlocshield
4529      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4530            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4531      &             +rlocshield
4532
4533            enddo
4534           enddo
4535
4536           do k=1,3
4537             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4538      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4539             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4540      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4541             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4542      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4543             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4544      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4545            enddo
4546            endif
4547
4548
4549 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4550 c     &                     ' eel_loc_ij',eel_loc_ij
4551 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4552 C Calculate patrial derivative for theta angle
4553 #ifdef NEWCORR
4554          geel_loc_ij=(a22*gmuij1(1)
4555      &     +a23*gmuij1(2)
4556      &     +a32*gmuij1(3)
4557      &     +a33*gmuij1(4))
4558      &    *fac_shield(i)*fac_shield(j)
4559 c         write(iout,*) "derivative over thatai"
4560 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4561 c     &   a33*gmuij1(4)
4562          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4563      &      geel_loc_ij*wel_loc
4564 c         write(iout,*) "derivative over thatai-1"
4565 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4566 c     &   a33*gmuij2(4)
4567          geel_loc_ij=
4568      &     a22*gmuij2(1)
4569      &     +a23*gmuij2(2)
4570      &     +a32*gmuij2(3)
4571      &     +a33*gmuij2(4)
4572          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4573      &      geel_loc_ij*wel_loc
4574      &    *fac_shield(i)*fac_shield(j)
4575
4576 c  Derivative over j residue
4577          geel_loc_ji=a22*gmuji1(1)
4578      &     +a23*gmuji1(2)
4579      &     +a32*gmuji1(3)
4580      &     +a33*gmuji1(4)
4581 c         write(iout,*) "derivative over thataj"
4582 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4583 c     &   a33*gmuji1(4)
4584
4585         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4586      &      geel_loc_ji*wel_loc
4587      &    *fac_shield(i)*fac_shield(j)
4588
4589          geel_loc_ji=
4590      &     +a22*gmuji2(1)
4591      &     +a23*gmuji2(2)
4592      &     +a32*gmuji2(3)
4593      &     +a33*gmuji2(4)
4594 c         write(iout,*) "derivative over thataj-1"
4595 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4596 c     &   a33*gmuji2(4)
4597          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4598      &      geel_loc_ji*wel_loc
4599      &    *fac_shield(i)*fac_shield(j)
4600 #endif
4601 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4602
4603           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4604      &            'eelloc',i,j,eel_loc_ij
4605 c           if (eel_loc_ij.ne.0)
4606 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4607 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4608
4609           eel_loc=eel_loc+eel_loc_ij
4610 C Partial derivatives in virtual-bond dihedral angles gamma
4611           if (i.gt.1)
4612      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4613      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4614      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4615      &    *fac_shield(i)*fac_shield(j)
4616
4617           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4618      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4619      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4620      &    *fac_shield(i)*fac_shield(j)
4621 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4622           do l=1,3
4623             ggg(l)=(agg(l,1)*muij(1)+
4624      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4625      &    *fac_shield(i)*fac_shield(j)
4626             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4627             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4628 cgrad            ghalf=0.5d0*ggg(l)
4629 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4630 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4631           enddo
4632 cgrad          do k=i+1,j2
4633 cgrad            do l=1,3
4634 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4635 cgrad            enddo
4636 cgrad          enddo
4637 C Remaining derivatives of eello
4638           do l=1,3
4639             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4640      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4641      &    *fac_shield(i)*fac_shield(j)
4642
4643             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4644      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4645      &    *fac_shield(i)*fac_shield(j)
4646
4647             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4648      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4649      &    *fac_shield(i)*fac_shield(j)
4650
4651             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4652      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4653      &    *fac_shield(i)*fac_shield(j)
4654
4655           enddo
4656           ENDIF
4657 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4658 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4659           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4660      &       .and. num_conti.le.maxconts) then
4661 c            write (iout,*) i,j," entered corr"
4662 C
4663 C Calculate the contact function. The ith column of the array JCONT will
4664 C contain the numbers of atoms that make contacts with the atom I (of numbers
4665 C greater than I). The arrays FACONT and GACONT will contain the values of
4666 C the contact function and its derivative.
4667 c           r0ij=1.02D0*rpp(iteli,itelj)
4668 c           r0ij=1.11D0*rpp(iteli,itelj)
4669             r0ij=2.20D0*rpp(iteli,itelj)
4670 c           r0ij=1.55D0*rpp(iteli,itelj)
4671             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4672             if (fcont.gt.0.0D0) then
4673               num_conti=num_conti+1
4674               if (num_conti.gt.maxconts) then
4675                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4676      &                         ' will skip next contacts for this conf.'
4677               else
4678                 jcont_hb(num_conti,i)=j
4679 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4680 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4681                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4682      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4683 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4684 C  terms.
4685                 d_cont(num_conti,i)=rij
4686 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4687 C     --- Electrostatic-interaction matrix ---
4688                 a_chuj(1,1,num_conti,i)=a22
4689                 a_chuj(1,2,num_conti,i)=a23
4690                 a_chuj(2,1,num_conti,i)=a32
4691                 a_chuj(2,2,num_conti,i)=a33
4692 C     --- Gradient of rij
4693                 do kkk=1,3
4694                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4695                 enddo
4696                 kkll=0
4697                 do k=1,2
4698                   do l=1,2
4699                     kkll=kkll+1
4700                     do m=1,3
4701                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4702                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4703                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4704                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4705                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4706                     enddo
4707                   enddo
4708                 enddo
4709                 ENDIF
4710                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4711 C Calculate contact energies
4712                 cosa4=4.0D0*cosa
4713                 wij=cosa-3.0D0*cosb*cosg
4714                 cosbg1=cosb+cosg
4715                 cosbg2=cosb-cosg
4716 c               fac3=dsqrt(-ael6i)/r0ij**3
4717                 fac3=dsqrt(-ael6i)*r3ij
4718 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4719                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4720                 if (ees0tmp.gt.0) then
4721                   ees0pij=dsqrt(ees0tmp)
4722                 else
4723                   ees0pij=0
4724                 endif
4725 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4726                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4727                 if (ees0tmp.gt.0) then
4728                   ees0mij=dsqrt(ees0tmp)
4729                 else
4730                   ees0mij=0
4731                 endif
4732 c               ees0mij=0.0D0
4733                 if (shield_mode.eq.0) then
4734                 fac_shield(i)=1.0d0
4735                 fac_shield(j)=1.0d0
4736                 else
4737                 ees0plist(num_conti,i)=j
4738 C                fac_shield(i)=0.4d0
4739 C                fac_shield(j)=0.6d0
4740                 endif
4741                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4742      &          *fac_shield(i)*fac_shield(j)
4743                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4744      &          *fac_shield(i)*fac_shield(j)
4745 C Diagnostics. Comment out or remove after debugging!
4746 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4747 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4748 c               ees0m(num_conti,i)=0.0D0
4749 C End diagnostics.
4750 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4751 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4752 C Angular derivatives of the contact function
4753                 ees0pij1=fac3/ees0pij
4754                 ees0mij1=fac3/ees0mij
4755                 fac3p=-3.0D0*fac3*rrmij
4756                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4757                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4758 c               ees0mij1=0.0D0
4759                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4760                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4761                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4762                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4763                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4764                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4765                 ecosap=ecosa1+ecosa2
4766                 ecosbp=ecosb1+ecosb2
4767                 ecosgp=ecosg1+ecosg2
4768                 ecosam=ecosa1-ecosa2
4769                 ecosbm=ecosb1-ecosb2
4770                 ecosgm=ecosg1-ecosg2
4771 C Diagnostics
4772 c               ecosap=ecosa1
4773 c               ecosbp=ecosb1
4774 c               ecosgp=ecosg1
4775 c               ecosam=0.0D0
4776 c               ecosbm=0.0D0
4777 c               ecosgm=0.0D0
4778 C End diagnostics
4779                 facont_hb(num_conti,i)=fcont
4780                 fprimcont=fprimcont/rij
4781 cd              facont_hb(num_conti,i)=1.0D0
4782 C Following line is for diagnostics.
4783 cd              fprimcont=0.0D0
4784                 do k=1,3
4785                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4786                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4787                 enddo
4788                 do k=1,3
4789                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4790                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4791                 enddo
4792                 gggp(1)=gggp(1)+ees0pijp*xj
4793                 gggp(2)=gggp(2)+ees0pijp*yj
4794                 gggp(3)=gggp(3)+ees0pijp*zj
4795                 gggm(1)=gggm(1)+ees0mijp*xj
4796                 gggm(2)=gggm(2)+ees0mijp*yj
4797                 gggm(3)=gggm(3)+ees0mijp*zj
4798 C Derivatives due to the contact function
4799                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4800                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4801                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4802                 do k=1,3
4803 c
4804 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4805 c          following the change of gradient-summation algorithm.
4806 c
4807 cgrad                  ghalfp=0.5D0*gggp(k)
4808 cgrad                  ghalfm=0.5D0*gggm(k)
4809                   gacontp_hb1(k,num_conti,i)=!ghalfp
4810      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4811      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4812      &          *fac_shield(i)*fac_shield(j)
4813
4814                   gacontp_hb2(k,num_conti,i)=!ghalfp
4815      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4816      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4817      &          *fac_shield(i)*fac_shield(j)
4818
4819                   gacontp_hb3(k,num_conti,i)=gggp(k)
4820      &          *fac_shield(i)*fac_shield(j)
4821
4822                   gacontm_hb1(k,num_conti,i)=!ghalfm
4823      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4824      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4825      &          *fac_shield(i)*fac_shield(j)
4826
4827                   gacontm_hb2(k,num_conti,i)=!ghalfm
4828      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4829      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4830      &          *fac_shield(i)*fac_shield(j)
4831
4832                   gacontm_hb3(k,num_conti,i)=gggm(k)
4833      &          *fac_shield(i)*fac_shield(j)
4834
4835                 enddo
4836 C Diagnostics. Comment out or remove after debugging!
4837 cdiag           do k=1,3
4838 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4839 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4840 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4841 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4842 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4843 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4844 cdiag           enddo
4845               ENDIF ! wcorr
4846               endif  ! num_conti.le.maxconts
4847             endif  ! fcont.gt.0
4848           endif    ! j.gt.i+1
4849           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4850             do k=1,4
4851               do l=1,3
4852                 ghalf=0.5d0*agg(l,k)
4853                 aggi(l,k)=aggi(l,k)+ghalf
4854                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4855                 aggj(l,k)=aggj(l,k)+ghalf
4856               enddo
4857             enddo
4858             if (j.eq.nres-1 .and. i.lt.j-2) then
4859               do k=1,4
4860                 do l=1,3
4861                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4862                 enddo
4863               enddo
4864             endif
4865           endif
4866 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4867       return
4868       end
4869 C-----------------------------------------------------------------------------
4870       subroutine eturn3(i,eello_turn3)
4871 C Third- and fourth-order contributions from turns
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       include 'COMMON.IOUNITS'
4875       include 'COMMON.GEO'
4876       include 'COMMON.VAR'
4877       include 'COMMON.LOCAL'
4878       include 'COMMON.CHAIN'
4879       include 'COMMON.DERIV'
4880       include 'COMMON.INTERACT'
4881       include 'COMMON.CONTACTS'
4882       include 'COMMON.TORSION'
4883       include 'COMMON.VECTORS'
4884       include 'COMMON.FFIELD'
4885       include 'COMMON.CONTROL'
4886       include 'COMMON.SHIELD'
4887       dimension ggg(3)
4888       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4889      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4890      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4891      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4892      &  auxgmat2(2,2),auxgmatt2(2,2)
4893       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4894      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4895       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4896      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4897      &    num_conti,j1,j2
4898       j=i+2
4899 c      write (iout,*) "eturn3",i,j,j1,j2
4900       a_temp(1,1)=a22
4901       a_temp(1,2)=a23
4902       a_temp(2,1)=a32
4903       a_temp(2,2)=a33
4904 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4905 C
4906 C               Third-order contributions
4907 C
4908 C                 (i+2)o----(i+3)
4909 C                      | |
4910 C                      | |
4911 C                 (i+1)o----i
4912 C
4913 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4914 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4915         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4916 c auxalary matices for theta gradient
4917 c auxalary matrix for i+1 and constant i+2
4918         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4919 c auxalary matrix for i+2 and constant i+1
4920         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4921         call transpose2(auxmat(1,1),auxmat1(1,1))
4922         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4923         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4924         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4925         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4926         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4927         if (shield_mode.eq.0) then
4928         fac_shield(i)=1.0
4929         fac_shield(j)=1.0
4930 C        else
4931 C        fac_shield(i)=0.4
4932 C        fac_shield(j)=0.6
4933         endif
4934         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4935      &  *fac_shield(i)*fac_shield(j)
4936         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4937      &  *fac_shield(i)*fac_shield(j)
4938         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4939      &    eello_t3
4940 C#ifdef NEWCORR
4941 C Derivatives in theta
4942         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4943      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4944      &   *fac_shield(i)*fac_shield(j)
4945         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4946      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4947      &   *fac_shield(i)*fac_shield(j)
4948 C#endif
4949
4950 C Derivatives in shield mode
4951           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4952      &  (shield_mode.gt.0)) then
4953 C          print *,i,j
4954
4955           do ilist=1,ishield_list(i)
4956            iresshield=shield_list(ilist,i)
4957            do k=1,3
4958            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4959 C     &      *2.0
4960            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4961      &              rlocshield
4962      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4963             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4964      &      +rlocshield
4965            enddo
4966           enddo
4967           do ilist=1,ishield_list(j)
4968            iresshield=shield_list(ilist,j)
4969            do k=1,3
4970            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4971 C     &     *2.0
4972            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4973      &              rlocshield
4974      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4975            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4976      &             +rlocshield
4977
4978            enddo
4979           enddo
4980
4981           do k=1,3
4982             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4983      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4984             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4985      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4986             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4987      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4988             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4989      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4990            enddo
4991            endif
4992
4993 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4994 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4995 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4996 cd     &    ' eello_turn3_num',4*eello_turn3_num
4997 C Derivatives in gamma(i)
4998         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4999         call transpose2(auxmat2(1,1),auxmat3(1,1))
5000         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5001         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5002      &   *fac_shield(i)*fac_shield(j)
5003 C Derivatives in gamma(i+1)
5004         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5005         call transpose2(auxmat2(1,1),auxmat3(1,1))
5006         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5007         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5008      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5009      &   *fac_shield(i)*fac_shield(j)
5010 C Cartesian derivatives
5011         do l=1,3
5012 c            ghalf1=0.5d0*agg(l,1)
5013 c            ghalf2=0.5d0*agg(l,2)
5014 c            ghalf3=0.5d0*agg(l,3)
5015 c            ghalf4=0.5d0*agg(l,4)
5016           a_temp(1,1)=aggi(l,1)!+ghalf1
5017           a_temp(1,2)=aggi(l,2)!+ghalf2
5018           a_temp(2,1)=aggi(l,3)!+ghalf3
5019           a_temp(2,2)=aggi(l,4)!+ghalf4
5020           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5021           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5022      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5023      &   *fac_shield(i)*fac_shield(j)
5024
5025           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5026           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5027           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5028           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5029           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5030           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5031      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5032      &   *fac_shield(i)*fac_shield(j)
5033           a_temp(1,1)=aggj(l,1)!+ghalf1
5034           a_temp(1,2)=aggj(l,2)!+ghalf2
5035           a_temp(2,1)=aggj(l,3)!+ghalf3
5036           a_temp(2,2)=aggj(l,4)!+ghalf4
5037           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5038           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5039      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5040      &   *fac_shield(i)*fac_shield(j)
5041           a_temp(1,1)=aggj1(l,1)
5042           a_temp(1,2)=aggj1(l,2)
5043           a_temp(2,1)=aggj1(l,3)
5044           a_temp(2,2)=aggj1(l,4)
5045           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5046           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5047      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5048      &   *fac_shield(i)*fac_shield(j)
5049         enddo
5050       return
5051       end
5052 C-------------------------------------------------------------------------------
5053       subroutine eturn4(i,eello_turn4)
5054 C Third- and fourth-order contributions from turns
5055       implicit real*8 (a-h,o-z)
5056       include 'DIMENSIONS'
5057       include 'COMMON.IOUNITS'
5058       include 'COMMON.GEO'
5059       include 'COMMON.VAR'
5060       include 'COMMON.LOCAL'
5061       include 'COMMON.CHAIN'
5062       include 'COMMON.DERIV'
5063       include 'COMMON.INTERACT'
5064       include 'COMMON.CONTACTS'
5065       include 'COMMON.TORSION'
5066       include 'COMMON.VECTORS'
5067       include 'COMMON.FFIELD'
5068       include 'COMMON.CONTROL'
5069       include 'COMMON.SHIELD'
5070       dimension ggg(3)
5071       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5072      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5073      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5074      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5075      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5076      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5077      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5078       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5079      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5080       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5081      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5082      &    num_conti,j1,j2
5083       j=i+3
5084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5085 C
5086 C               Fourth-order contributions
5087 C
5088 C                 (i+3)o----(i+4)
5089 C                     /  |
5090 C               (i+2)o   |
5091 C                     \  |
5092 C                 (i+1)o----i
5093 C
5094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5095 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5096 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5097 c        write(iout,*)"WCHODZE W PROGRAM"
5098         a_temp(1,1)=a22
5099         a_temp(1,2)=a23
5100         a_temp(2,1)=a32
5101         a_temp(2,2)=a33
5102         iti1=itype2loc(itype(i+1))
5103         iti2=itype2loc(itype(i+2))
5104         iti3=itype2loc(itype(i+3))
5105 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5106         call transpose2(EUg(1,1,i+1),e1t(1,1))
5107         call transpose2(Eug(1,1,i+2),e2t(1,1))
5108         call transpose2(Eug(1,1,i+3),e3t(1,1))
5109 C Ematrix derivative in theta
5110         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5111         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5112         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5113         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5114 c       eta1 in derivative theta
5115         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5116         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5117 c       auxgvec is derivative of Ub2 so i+3 theta
5118         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5119 c       auxalary matrix of E i+1
5120         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5121 c        s1=0.0
5122 c        gs1=0.0
5123         s1=scalar2(b1(1,i+2),auxvec(1))
5124 c derivative of theta i+2 with constant i+3
5125         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5126 c derivative of theta i+2 with constant i+2
5127         gs32=scalar2(b1(1,i+2),auxgvec(1))
5128 c derivative of E matix in theta of i+1
5129         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5130
5131         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5132 c       ea31 in derivative theta
5133         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5134         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5135 c auxilary matrix auxgvec of Ub2 with constant E matirx
5136         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5137 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5138         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5139
5140 c        s2=0.0
5141 c        gs2=0.0
5142         s2=scalar2(b1(1,i+1),auxvec(1))
5143 c derivative of theta i+1 with constant i+3
5144         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5145 c derivative of theta i+2 with constant i+1
5146         gs21=scalar2(b1(1,i+1),auxgvec(1))
5147 c derivative of theta i+3 with constant i+1
5148         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5149 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5150 c     &  gtb1(1,i+1)
5151         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5152 c two derivatives over diffetent matrices
5153 c gtae3e2 is derivative over i+3
5154         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5155 c ae3gte2 is derivative over i+2
5156         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5157         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5158 c three possible derivative over theta E matices
5159 c i+1
5160         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5161 c i+2
5162         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5163 c i+3
5164         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5165         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5166
5167         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5168         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5169         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5170         if (shield_mode.eq.0) then
5171         fac_shield(i)=1.0
5172         fac_shield(j)=1.0
5173 C        else
5174 C        fac_shield(i)=0.6
5175 C        fac_shield(j)=0.4
5176         endif
5177         eello_turn4=eello_turn4-(s1+s2+s3)
5178      &  *fac_shield(i)*fac_shield(j)
5179         eello_t4=-(s1+s2+s3)
5180      &  *fac_shield(i)*fac_shield(j)
5181 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5182         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5183      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5184 C Now derivative over shield:
5185           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5186      &  (shield_mode.gt.0)) then
5187 C          print *,i,j
5188
5189           do ilist=1,ishield_list(i)
5190            iresshield=shield_list(ilist,i)
5191            do k=1,3
5192            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5193 C     &      *2.0
5194            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5195      &              rlocshield
5196      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5197             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5198      &      +rlocshield
5199            enddo
5200           enddo
5201           do ilist=1,ishield_list(j)
5202            iresshield=shield_list(ilist,j)
5203            do k=1,3
5204            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5205 C     &     *2.0
5206            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5207      &              rlocshield
5208      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5209            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5210      &             +rlocshield
5211
5212            enddo
5213           enddo
5214
5215           do k=1,3
5216             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5217      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5218             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5219      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5220             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5221      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5222             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5223      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5224            enddo
5225            endif
5226
5227
5228
5229
5230
5231
5232 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5233 cd     &    ' eello_turn4_num',8*eello_turn4_num
5234 #ifdef NEWCORR
5235         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5236      &                  -(gs13+gsE13+gsEE1)*wturn4
5237      &  *fac_shield(i)*fac_shield(j)
5238         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5239      &                    -(gs23+gs21+gsEE2)*wturn4
5240      &  *fac_shield(i)*fac_shield(j)
5241
5242         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5243      &                    -(gs32+gsE31+gsEE3)*wturn4
5244      &  *fac_shield(i)*fac_shield(j)
5245
5246 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5247 c     &   gs2
5248 #endif
5249         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5250      &      'eturn4',i,j,-(s1+s2+s3)
5251 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5252 c     &    ' eello_turn4_num',8*eello_turn4_num
5253 C Derivatives in gamma(i)
5254         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5255         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5256         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5257         s1=scalar2(b1(1,i+2),auxvec(1))
5258         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5259         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5260         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5261      &  *fac_shield(i)*fac_shield(j)
5262 C Derivatives in gamma(i+1)
5263         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5264         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5265         s2=scalar2(b1(1,i+1),auxvec(1))
5266         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5267         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5268         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5270      &  *fac_shield(i)*fac_shield(j)
5271 C Derivatives in gamma(i+2)
5272         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5273         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5274         s1=scalar2(b1(1,i+2),auxvec(1))
5275         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5276         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5277         s2=scalar2(b1(1,i+1),auxvec(1))
5278         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5279         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5280         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5281         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5282      &  *fac_shield(i)*fac_shield(j)
5283 C Cartesian derivatives
5284 C Derivatives of this turn contributions in DC(i+2)
5285         if (j.lt.nres-1) then
5286           do l=1,3
5287             a_temp(1,1)=agg(l,1)
5288             a_temp(1,2)=agg(l,2)
5289             a_temp(2,1)=agg(l,3)
5290             a_temp(2,2)=agg(l,4)
5291             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5292             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5293             s1=scalar2(b1(1,i+2),auxvec(1))
5294             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5295             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5296             s2=scalar2(b1(1,i+1),auxvec(1))
5297             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5298             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5299             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5300             ggg(l)=-(s1+s2+s3)
5301             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5302      &  *fac_shield(i)*fac_shield(j)
5303           enddo
5304         endif
5305 C Remaining derivatives of this turn contribution
5306         do l=1,3
5307           a_temp(1,1)=aggi(l,1)
5308           a_temp(1,2)=aggi(l,2)
5309           a_temp(2,1)=aggi(l,3)
5310           a_temp(2,2)=aggi(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,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5321      &  *fac_shield(i)*fac_shield(j)
5322           a_temp(1,1)=aggi1(l,1)
5323           a_temp(1,2)=aggi1(l,2)
5324           a_temp(2,1)=aggi1(l,3)
5325           a_temp(2,2)=aggi1(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           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5336      &  *fac_shield(i)*fac_shield(j)
5337           a_temp(1,1)=aggj(l,1)
5338           a_temp(1,2)=aggj(l,2)
5339           a_temp(2,1)=aggj(l,3)
5340           a_temp(2,2)=aggj(l,4)
5341           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5342           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5343           s1=scalar2(b1(1,i+2),auxvec(1))
5344           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5345           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5346           s2=scalar2(b1(1,i+1),auxvec(1))
5347           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5348           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5349           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5350           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5351      &  *fac_shield(i)*fac_shield(j)
5352           a_temp(1,1)=aggj1(l,1)
5353           a_temp(1,2)=aggj1(l,2)
5354           a_temp(2,1)=aggj1(l,3)
5355           a_temp(2,2)=aggj1(l,4)
5356           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5357           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5358           s1=scalar2(b1(1,i+2),auxvec(1))
5359           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5360           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5361           s2=scalar2(b1(1,i+1),auxvec(1))
5362           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5363           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5364           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5365 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5366           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5367      &  *fac_shield(i)*fac_shield(j)
5368         enddo
5369       return
5370       end
5371 C-----------------------------------------------------------------------------
5372       subroutine vecpr(u,v,w)
5373       implicit real*8(a-h,o-z)
5374       dimension u(3),v(3),w(3)
5375       w(1)=u(2)*v(3)-u(3)*v(2)
5376       w(2)=-u(1)*v(3)+u(3)*v(1)
5377       w(3)=u(1)*v(2)-u(2)*v(1)
5378       return
5379       end
5380 C-----------------------------------------------------------------------------
5381       subroutine unormderiv(u,ugrad,unorm,ungrad)
5382 C This subroutine computes the derivatives of a normalized vector u, given
5383 C the derivatives computed without normalization conditions, ugrad. Returns
5384 C ungrad.
5385       implicit none
5386       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5387       double precision vec(3)
5388       double precision scalar
5389       integer i,j
5390 c      write (2,*) 'ugrad',ugrad
5391 c      write (2,*) 'u',u
5392       do i=1,3
5393         vec(i)=scalar(ugrad(1,i),u(1))
5394       enddo
5395 c      write (2,*) 'vec',vec
5396       do i=1,3
5397         do j=1,3
5398           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5399         enddo
5400       enddo
5401 c      write (2,*) 'ungrad',ungrad
5402       return
5403       end
5404 C-----------------------------------------------------------------------------
5405       subroutine escp_soft_sphere(evdw2,evdw2_14)
5406 C
5407 C This subroutine calculates the excluded-volume interaction energy between
5408 C peptide-group centers and side chains and its gradient in virtual-bond and
5409 C side-chain vectors.
5410 C
5411       implicit real*8 (a-h,o-z)
5412       include 'DIMENSIONS'
5413       include 'COMMON.GEO'
5414       include 'COMMON.VAR'
5415       include 'COMMON.LOCAL'
5416       include 'COMMON.CHAIN'
5417       include 'COMMON.DERIV'
5418       include 'COMMON.INTERACT'
5419       include 'COMMON.FFIELD'
5420       include 'COMMON.IOUNITS'
5421       include 'COMMON.CONTROL'
5422       dimension ggg(3)
5423       integer xshift,yshift,zshift
5424       evdw2=0.0D0
5425       evdw2_14=0.0d0
5426       r0_scp=4.5d0
5427 cd    print '(a)','Enter ESCP'
5428 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5429 C      do xshift=-1,1
5430 C      do yshift=-1,1
5431 C      do zshift=-1,1
5432       do i=iatscp_s,iatscp_e
5433         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5434         iteli=itel(i)
5435         xi=0.5D0*(c(1,i)+c(1,i+1))
5436         yi=0.5D0*(c(2,i)+c(2,i+1))
5437         zi=0.5D0*(c(3,i)+c(3,i+1))
5438 C Return atom into box, boxxsize is size of box in x dimension
5439 c  134   continue
5440 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5441 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5442 C Condition for being inside the proper box
5443 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5444 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5445 c        go to 134
5446 c        endif
5447 c  135   continue
5448 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5449 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5450 C Condition for being inside the proper box
5451 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5452 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5453 c        go to 135
5454 c c       endif
5455 c  136   continue
5456 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5457 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5458 cC Condition for being inside the proper box
5459 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5460 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5461 c        go to 136
5462 c        endif
5463           xi=mod(xi,boxxsize)
5464           if (xi.lt.0) xi=xi+boxxsize
5465           yi=mod(yi,boxysize)
5466           if (yi.lt.0) yi=yi+boxysize
5467           zi=mod(zi,boxzsize)
5468           if (zi.lt.0) zi=zi+boxzsize
5469 C          xi=xi+xshift*boxxsize
5470 C          yi=yi+yshift*boxysize
5471 C          zi=zi+zshift*boxzsize
5472         do iint=1,nscp_gr(i)
5473
5474         do j=iscpstart(i,iint),iscpend(i,iint)
5475           if (itype(j).eq.ntyp1) cycle
5476           itypj=iabs(itype(j))
5477 C Uncomment following three lines for SC-p interactions
5478 c         xj=c(1,nres+j)-xi
5479 c         yj=c(2,nres+j)-yi
5480 c         zj=c(3,nres+j)-zi
5481 C Uncomment following three lines for Ca-p interactions
5482           xj=c(1,j)
5483           yj=c(2,j)
5484           zj=c(3,j)
5485 c  174   continue
5486 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5487 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5488 C Condition for being inside the proper box
5489 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5490 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5491 c        go to 174
5492 c        endif
5493 c  175   continue
5494 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5495 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5496 cC Condition for being inside the proper box
5497 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5498 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5499 c        go to 175
5500 c        endif
5501 c  176   continue
5502 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5503 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5504 C Condition for being inside the proper box
5505 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5506 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5507 c        go to 176
5508           xj=mod(xj,boxxsize)
5509           if (xj.lt.0) xj=xj+boxxsize
5510           yj=mod(yj,boxysize)
5511           if (yj.lt.0) yj=yj+boxysize
5512           zj=mod(zj,boxzsize)
5513           if (zj.lt.0) zj=zj+boxzsize
5514       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5515       xj_safe=xj
5516       yj_safe=yj
5517       zj_safe=zj
5518       subchap=0
5519       do xshift=-1,1
5520       do yshift=-1,1
5521       do zshift=-1,1
5522           xj=xj_safe+xshift*boxxsize
5523           yj=yj_safe+yshift*boxysize
5524           zj=zj_safe+zshift*boxzsize
5525           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5526           if(dist_temp.lt.dist_init) then
5527             dist_init=dist_temp
5528             xj_temp=xj
5529             yj_temp=yj
5530             zj_temp=zj
5531             subchap=1
5532           endif
5533        enddo
5534        enddo
5535        enddo
5536        if (subchap.eq.1) then
5537           xj=xj_temp-xi
5538           yj=yj_temp-yi
5539           zj=zj_temp-zi
5540        else
5541           xj=xj_safe-xi
5542           yj=yj_safe-yi
5543           zj=zj_safe-zi
5544        endif
5545 c c       endif
5546 C          xj=xj-xi
5547 C          yj=yj-yi
5548 C          zj=zj-zi
5549           rij=xj*xj+yj*yj+zj*zj
5550
5551           r0ij=r0_scp
5552           r0ijsq=r0ij*r0ij
5553           if (rij.lt.r0ijsq) then
5554             evdwij=0.25d0*(rij-r0ijsq)**2
5555             fac=rij-r0ijsq
5556           else
5557             evdwij=0.0d0
5558             fac=0.0d0
5559           endif
5560           evdw2=evdw2+evdwij
5561 C
5562 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5563 C
5564           ggg(1)=xj*fac
5565           ggg(2)=yj*fac
5566           ggg(3)=zj*fac
5567 cgrad          if (j.lt.i) then
5568 cd          write (iout,*) 'j<i'
5569 C Uncomment following three lines for SC-p interactions
5570 c           do k=1,3
5571 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5572 c           enddo
5573 cgrad          else
5574 cd          write (iout,*) 'j>i'
5575 cgrad            do k=1,3
5576 cgrad              ggg(k)=-ggg(k)
5577 C Uncomment following line for SC-p interactions
5578 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5579 cgrad            enddo
5580 cgrad          endif
5581 cgrad          do k=1,3
5582 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5583 cgrad          enddo
5584 cgrad          kstart=min0(i+1,j)
5585 cgrad          kend=max0(i-1,j-1)
5586 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5587 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5588 cgrad          do k=kstart,kend
5589 cgrad            do l=1,3
5590 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5591 cgrad            enddo
5592 cgrad          enddo
5593           do k=1,3
5594             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5595             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5596           enddo
5597         enddo
5598
5599         enddo ! iint
5600       enddo ! i
5601 C      enddo !zshift
5602 C      enddo !yshift
5603 C      enddo !xshift
5604       return
5605       end
5606 C-----------------------------------------------------------------------------
5607       subroutine escp(evdw2,evdw2_14)
5608 C
5609 C This subroutine calculates the excluded-volume interaction energy between
5610 C peptide-group centers and side chains and its gradient in virtual-bond and
5611 C side-chain vectors.
5612 C
5613       implicit real*8 (a-h,o-z)
5614       include 'DIMENSIONS'
5615       include 'COMMON.GEO'
5616       include 'COMMON.VAR'
5617       include 'COMMON.LOCAL'
5618       include 'COMMON.CHAIN'
5619       include 'COMMON.DERIV'
5620       include 'COMMON.INTERACT'
5621       include 'COMMON.FFIELD'
5622       include 'COMMON.IOUNITS'
5623       include 'COMMON.CONTROL'
5624       include 'COMMON.SPLITELE'
5625       integer xshift,yshift,zshift
5626       dimension ggg(3)
5627       evdw2=0.0D0
5628       evdw2_14=0.0d0
5629 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5630 cd    print '(a)','Enter ESCP'
5631 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5632 C      do xshift=-1,1
5633 C      do yshift=-1,1
5634 C      do zshift=-1,1
5635       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5636       do i=iatscp_s,iatscp_e
5637         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5638         iteli=itel(i)
5639         xi=0.5D0*(c(1,i)+c(1,i+1))
5640         yi=0.5D0*(c(2,i)+c(2,i+1))
5641         zi=0.5D0*(c(3,i)+c(3,i+1))
5642           xi=mod(xi,boxxsize)
5643           if (xi.lt.0) xi=xi+boxxsize
5644           yi=mod(yi,boxysize)
5645           if (yi.lt.0) yi=yi+boxysize
5646           zi=mod(zi,boxzsize)
5647           if (zi.lt.0) zi=zi+boxzsize
5648 c          xi=xi+xshift*boxxsize
5649 c          yi=yi+yshift*boxysize
5650 c          zi=zi+zshift*boxzsize
5651 c        print *,xi,yi,zi,'polozenie i'
5652 C Return atom into box, boxxsize is size of box in x dimension
5653 c  134   continue
5654 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5655 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5656 C Condition for being inside the proper box
5657 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5658 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5659 c        go to 134
5660 c        endif
5661 c  135   continue
5662 c          print *,xi,boxxsize,"pierwszy"
5663
5664 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5665 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5666 C Condition for being inside the proper box
5667 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5668 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5669 c        go to 135
5670 c        endif
5671 c  136   continue
5672 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5673 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5674 C Condition for being inside the proper box
5675 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5676 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5677 c        go to 136
5678 c        endif
5679         do iint=1,nscp_gr(i)
5680
5681         do j=iscpstart(i,iint),iscpend(i,iint)
5682           itypj=iabs(itype(j))
5683           if (itypj.eq.ntyp1) cycle
5684 C Uncomment following three lines for SC-p interactions
5685 c         xj=c(1,nres+j)-xi
5686 c         yj=c(2,nres+j)-yi
5687 c         zj=c(3,nres+j)-zi
5688 C Uncomment following three lines for Ca-p interactions
5689           xj=c(1,j)
5690           yj=c(2,j)
5691           zj=c(3,j)
5692           xj=mod(xj,boxxsize)
5693           if (xj.lt.0) xj=xj+boxxsize
5694           yj=mod(yj,boxysize)
5695           if (yj.lt.0) yj=yj+boxysize
5696           zj=mod(zj,boxzsize)
5697           if (zj.lt.0) zj=zj+boxzsize
5698 c  174   continue
5699 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5700 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5701 C Condition for being inside the proper box
5702 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5703 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5704 c        go to 174
5705 c        endif
5706 c  175   continue
5707 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5708 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5709 cC Condition for being inside the proper box
5710 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5711 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5712 c        go to 175
5713 c        endif
5714 c  176   continue
5715 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5716 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5717 C Condition for being inside the proper box
5718 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5719 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5720 c        go to 176
5721 c        endif
5722 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5723       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5724       xj_safe=xj
5725       yj_safe=yj
5726       zj_safe=zj
5727       subchap=0
5728       do xshift=-1,1
5729       do yshift=-1,1
5730       do zshift=-1,1
5731           xj=xj_safe+xshift*boxxsize
5732           yj=yj_safe+yshift*boxysize
5733           zj=zj_safe+zshift*boxzsize
5734           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5735           if(dist_temp.lt.dist_init) then
5736             dist_init=dist_temp
5737             xj_temp=xj
5738             yj_temp=yj
5739             zj_temp=zj
5740             subchap=1
5741           endif
5742        enddo
5743        enddo
5744        enddo
5745        if (subchap.eq.1) then
5746           xj=xj_temp-xi
5747           yj=yj_temp-yi
5748           zj=zj_temp-zi
5749        else
5750           xj=xj_safe-xi
5751           yj=yj_safe-yi
5752           zj=zj_safe-zi
5753        endif
5754 c          print *,xj,yj,zj,'polozenie j'
5755           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5756 c          print *,rrij
5757           sss=sscale(1.0d0/(dsqrt(rrij)))
5758 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5759 c          if (sss.eq.0) print *,'czasem jest OK'
5760           if (sss.le.0.0d0) cycle
5761           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5762           fac=rrij**expon2
5763           e1=fac*fac*aad(itypj,iteli)
5764           e2=fac*bad(itypj,iteli)
5765           if (iabs(j-i) .le. 2) then
5766             e1=scal14*e1
5767             e2=scal14*e2
5768             evdw2_14=evdw2_14+(e1+e2)*sss
5769           endif
5770           evdwij=e1+e2
5771           evdw2=evdw2+evdwij*sss
5772           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5773      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5774      &       bad(itypj,iteli)
5775 C
5776 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5777 C
5778           fac=-(evdwij+e1)*rrij*sss
5779           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5780           ggg(1)=xj*fac
5781           ggg(2)=yj*fac
5782           ggg(3)=zj*fac
5783 cgrad          if (j.lt.i) then
5784 cd          write (iout,*) 'j<i'
5785 C Uncomment following three lines for SC-p interactions
5786 c           do k=1,3
5787 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5788 c           enddo
5789 cgrad          else
5790 cd          write (iout,*) 'j>i'
5791 cgrad            do k=1,3
5792 cgrad              ggg(k)=-ggg(k)
5793 C Uncomment following line for SC-p interactions
5794 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5795 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5796 cgrad            enddo
5797 cgrad          endif
5798 cgrad          do k=1,3
5799 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5800 cgrad          enddo
5801 cgrad          kstart=min0(i+1,j)
5802 cgrad          kend=max0(i-1,j-1)
5803 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5804 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5805 cgrad          do k=kstart,kend
5806 cgrad            do l=1,3
5807 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5808 cgrad            enddo
5809 cgrad          enddo
5810           do k=1,3
5811             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5812             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5813           enddo
5814 c        endif !endif for sscale cutoff
5815         enddo ! j
5816
5817         enddo ! iint
5818       enddo ! i
5819 c      enddo !zshift
5820 c      enddo !yshift
5821 c      enddo !xshift
5822       do i=1,nct
5823         do j=1,3
5824           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5825           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5826           gradx_scp(j,i)=expon*gradx_scp(j,i)
5827         enddo
5828       enddo
5829 C******************************************************************************
5830 C
5831 C                              N O T E !!!
5832 C
5833 C To save time the factor EXPON has been extracted from ALL components
5834 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5835 C use!
5836 C
5837 C******************************************************************************
5838       return
5839       end
5840 C--------------------------------------------------------------------------
5841       subroutine edis(ehpb)
5842 C
5843 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5844 C
5845       implicit real*8 (a-h,o-z)
5846       include 'DIMENSIONS'
5847       include 'COMMON.SBRIDGE'
5848       include 'COMMON.CHAIN'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.VAR'
5851       include 'COMMON.INTERACT'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.CONTROL'
5854       dimension ggg(3),ggg_peak(3,1000)
5855       ehpb=0.0D0
5856       do i=1,3
5857        ggg(i)=0.0d0
5858       enddo
5859 c 8/21/18 AL: added explicit restraints on reference coords
5860 c      write (iout,*) "restr_on_coord",restr_on_coord
5861       if (restr_on_coord) then
5862
5863       do i=nnt,nct
5864         ecoor=0.0d0
5865         if (itype(i).eq.ntyp1) cycle
5866         do j=1,3
5867           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5868           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5869         enddo
5870         if (itype(i).ne.10) then
5871           do j=1,3
5872             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5873             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5874           enddo
5875         endif
5876         if (energy_dec) write (iout,*)
5877      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5878         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5879       enddo
5880
5881       endif
5882 C      write (iout,*) ,"link_end",link_end,constr_dist
5883 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5884 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5885 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5886 c     &  " link_end_peak",link_end_peak
5887       if (link_end.eq.0.and.link_end_peak.eq.0) return
5888       do i=link_start_peak,link_end_peak
5889         ehpb_peak=0.0d0
5890 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5891 c     &   ipeak(1,i),ipeak(2,i)
5892         do ip=ipeak(1,i),ipeak(2,i)
5893           ii=ihpb_peak(ip)
5894           jj=jhpb_peak(ip)
5895           dd=dist(ii,jj)
5896           iip=ip-ipeak(1,i)+1
5897 C iii and jjj point to the residues for which the distance is assigned.
5898 c          if (ii.gt.nres) then
5899 c            iii=ii-nres
5900 c            jjj=jj-nres
5901 c          else
5902 c            iii=ii
5903 c            jjj=jj
5904 c          endif
5905           if (ii.gt.nres) then
5906             iii=ii-nres
5907           else
5908             iii=ii
5909           endif
5910           if (jj.gt.nres) then
5911             jjj=jj-nres
5912           else
5913             jjj=jj
5914           endif
5915           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5916           aux=dexp(-scal_peak*aux)
5917           ehpb_peak=ehpb_peak+aux
5918           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5919      &      forcon_peak(ip))*aux/dd
5920           do j=1,3
5921             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5922           enddo
5923           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5924      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5925      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5926         enddo
5927 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5928         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5929         do ip=ipeak(1,i),ipeak(2,i)
5930           iip=ip-ipeak(1,i)+1
5931           do j=1,3
5932             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5933           enddo
5934           ii=ihpb_peak(ip)
5935           jj=jhpb_peak(ip)
5936 C iii and jjj point to the residues for which the distance is assigned.
5937 c          if (ii.gt.nres) then
5938 c            iii=ii-nres
5939 c            jjj=jj-nres
5940 c          else
5941 c            iii=ii
5942 c            jjj=jj
5943 c          endif
5944           if (ii.gt.nres) then
5945             iii=ii-nres
5946           else
5947             iii=ii
5948           endif
5949           if (jj.gt.nres) then
5950             jjj=jj-nres
5951           else
5952             jjj=jj
5953           endif
5954           if (iii.lt.ii) then
5955             do j=1,3
5956               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5957             enddo
5958           endif
5959           if (jjj.lt.jj) then
5960             do j=1,3
5961               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5962             enddo
5963           endif
5964           do k=1,3
5965             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5966             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5967           enddo
5968         enddo
5969       enddo
5970       do i=link_start,link_end
5971 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5972 C CA-CA distance used in regularization of structure.
5973         ii=ihpb(i)
5974         jj=jhpb(i)
5975 C iii and jjj point to the residues for which the distance is assigned.
5976         if (ii.gt.nres) then
5977           iii=ii-nres
5978         else
5979           iii=ii
5980         endif
5981         if (jj.gt.nres) then
5982           jjj=jj-nres
5983         else
5984           jjj=jj
5985         endif
5986 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5987 c     &    dhpb(i),dhpb1(i),forcon(i)
5988 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5989 C    distance and angle dependent SS bond potential.
5990 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5991 C     & iabs(itype(jjj)).eq.1) then
5992 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5993 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5994         if (.not.dyn_ss .and. i.le.nss) then
5995 C 15/02/13 CC dynamic SSbond - additional check
5996           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5997      &        iabs(itype(jjj)).eq.1) then
5998            call ssbond_ene(iii,jjj,eij)
5999            ehpb=ehpb+2*eij
6000          endif
6001 cd          write (iout,*) "eij",eij
6002 cd   &   ' waga=',waga,' fac=',fac
6003 !        else if (ii.gt.nres .and. jj.gt.nres) then
6004         else
6005 C Calculate the distance between the two points and its difference from the
6006 C target distance.
6007           dd=dist(ii,jj)
6008           if (irestr_type(i).eq.11) then
6009             ehpb=ehpb+fordepth(i)!**4.0d0
6010      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6011             fac=fordepth(i)!**4.0d0
6012      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6013             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6014      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6015      &        ehpb,irestr_type(i)
6016           else if (irestr_type(i).eq.10) then
6017 c AL 6//19/2018 cross-link restraints
6018             xdis = 0.5d0*(dd/forcon(i))**2
6019             expdis = dexp(-xdis)
6020 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6021             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6022 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6023 c     &          " wboltzd",wboltzd
6024             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6025 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6026             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6027      &           *expdis/(aux*forcon(i)**2)
6028             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6029      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6030      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6031           else if (irestr_type(i).eq.2) then
6032 c Quartic restraints
6033             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6034             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6035      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6036      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6037             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6038           else
6039 c Quadratic restraints
6040             rdis=dd-dhpb(i)
6041 C Get the force constant corresponding to this distance.
6042             waga=forcon(i)
6043 C Calculate the contribution to energy.
6044             ehpb=ehpb+0.5d0*waga*rdis*rdis
6045             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6046      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6047      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6048 C
6049 C Evaluate gradient.
6050 C
6051             fac=waga*rdis/dd
6052           endif
6053 c Calculate Cartesian gradient
6054           do j=1,3
6055             ggg(j)=fac*(c(j,jj)-c(j,ii))
6056           enddo
6057 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6058 C If this is a SC-SC distance, we need to calculate the contributions to the
6059 C Cartesian gradient in the SC vectors (ghpbx).
6060           if (iii.lt.ii) then
6061             do j=1,3
6062               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6063             enddo
6064           endif
6065           if (jjj.lt.jj) then
6066             do j=1,3
6067               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6068             enddo
6069           endif
6070           do k=1,3
6071             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6072             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6073           enddo
6074         endif
6075       enddo
6076       return
6077       end
6078 C--------------------------------------------------------------------------
6079       subroutine ssbond_ene(i,j,eij)
6080 C
6081 C Calculate the distance and angle dependent SS-bond potential energy
6082 C using a free-energy function derived based on RHF/6-31G** ab initio
6083 C calculations of diethyl disulfide.
6084 C
6085 C A. Liwo and U. Kozlowska, 11/24/03
6086 C
6087       implicit real*8 (a-h,o-z)
6088       include 'DIMENSIONS'
6089       include 'COMMON.SBRIDGE'
6090       include 'COMMON.CHAIN'
6091       include 'COMMON.DERIV'
6092       include 'COMMON.LOCAL'
6093       include 'COMMON.INTERACT'
6094       include 'COMMON.VAR'
6095       include 'COMMON.IOUNITS'
6096       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6097       itypi=iabs(itype(i))
6098       xi=c(1,nres+i)
6099       yi=c(2,nres+i)
6100       zi=c(3,nres+i)
6101       dxi=dc_norm(1,nres+i)
6102       dyi=dc_norm(2,nres+i)
6103       dzi=dc_norm(3,nres+i)
6104 c      dsci_inv=dsc_inv(itypi)
6105       dsci_inv=vbld_inv(nres+i)
6106       itypj=iabs(itype(j))
6107 c      dscj_inv=dsc_inv(itypj)
6108       dscj_inv=vbld_inv(nres+j)
6109       xj=c(1,nres+j)-xi
6110       yj=c(2,nres+j)-yi
6111       zj=c(3,nres+j)-zi
6112       dxj=dc_norm(1,nres+j)
6113       dyj=dc_norm(2,nres+j)
6114       dzj=dc_norm(3,nres+j)
6115       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6116       rij=dsqrt(rrij)
6117       erij(1)=xj*rij
6118       erij(2)=yj*rij
6119       erij(3)=zj*rij
6120       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6121       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6122       om12=dxi*dxj+dyi*dyj+dzi*dzj
6123       do k=1,3
6124         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6125         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6126       enddo
6127       rij=1.0d0/rij
6128       deltad=rij-d0cm
6129       deltat1=1.0d0-om1
6130       deltat2=1.0d0+om2
6131       deltat12=om2-om1+2.0d0
6132       cosphi=om12-om1*om2
6133       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6134      &  +akct*deltad*deltat12
6135      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6136 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6137 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6138 c     &  " deltat12",deltat12," eij",eij
6139       ed=2*akcm*deltad+akct*deltat12
6140       pom1=akct*deltad
6141       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6142       eom1=-2*akth*deltat1-pom1-om2*pom2
6143       eom2= 2*akth*deltat2+pom1-om1*pom2
6144       eom12=pom2
6145       do k=1,3
6146         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6147         ghpbx(k,i)=ghpbx(k,i)-ggk
6148      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6149      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6150         ghpbx(k,j)=ghpbx(k,j)+ggk
6151      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6152      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6153         ghpbc(k,i)=ghpbc(k,i)-ggk
6154         ghpbc(k,j)=ghpbc(k,j)+ggk
6155       enddo
6156 C
6157 C Calculate the components of the gradient in DC and X
6158 C
6159 cgrad      do k=i,j-1
6160 cgrad        do l=1,3
6161 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6162 cgrad        enddo
6163 cgrad      enddo
6164       return
6165       end
6166 C--------------------------------------------------------------------------
6167       subroutine ebond(estr)
6168 c
6169 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6170 c
6171       implicit real*8 (a-h,o-z)
6172       include 'DIMENSIONS'
6173       include 'COMMON.LOCAL'
6174       include 'COMMON.GEO'
6175       include 'COMMON.INTERACT'
6176       include 'COMMON.DERIV'
6177       include 'COMMON.VAR'
6178       include 'COMMON.CHAIN'
6179       include 'COMMON.IOUNITS'
6180       include 'COMMON.NAMES'
6181       include 'COMMON.FFIELD'
6182       include 'COMMON.CONTROL'
6183       include 'COMMON.SETUP'
6184       double precision u(3),ud(3)
6185       estr=0.0d0
6186       estr1=0.0d0
6187       do i=ibondp_start,ibondp_end
6188         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6189 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6190 c          do j=1,3
6191 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6192 c     &      *dc(j,i-1)/vbld(i)
6193 c          enddo
6194 c          if (energy_dec) write(iout,*)
6195 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6196 c        else
6197 C       Checking if it involves dummy (NH3+ or COO-) group
6198          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6199 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6200         diff = vbld(i)-vbldpDUM
6201         if (energy_dec) write(iout,*) "dum_bond",i,diff
6202          else
6203 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6204         diff = vbld(i)-vbldp0
6205          endif
6206         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6207      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6208         estr=estr+diff*diff
6209         do j=1,3
6210           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6211         enddo
6212 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6213 c        endif
6214       enddo
6215
6216       estr=0.5d0*AKP*estr+estr1
6217 c
6218 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6219 c
6220       do i=ibond_start,ibond_end
6221         iti=iabs(itype(i))
6222         if (iti.ne.10 .and. iti.ne.ntyp1) then
6223           nbi=nbondterm(iti)
6224           if (nbi.eq.1) then
6225             diff=vbld(i+nres)-vbldsc0(1,iti)
6226             if (energy_dec)  write (iout,*)
6227      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6228      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6229             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6230             do j=1,3
6231               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6232             enddo
6233           else
6234             do j=1,nbi
6235               diff=vbld(i+nres)-vbldsc0(j,iti)
6236               ud(j)=aksc(j,iti)*diff
6237               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6238             enddo
6239             uprod=u(1)
6240             do j=2,nbi
6241               uprod=uprod*u(j)
6242             enddo
6243             usum=0.0d0
6244             usumsqder=0.0d0
6245             do j=1,nbi
6246               uprod1=1.0d0
6247               uprod2=1.0d0
6248               do k=1,nbi
6249                 if (k.ne.j) then
6250                   uprod1=uprod1*u(k)
6251                   uprod2=uprod2*u(k)*u(k)
6252                 endif
6253               enddo
6254               usum=usum+uprod1
6255               usumsqder=usumsqder+ud(j)*uprod2
6256             enddo
6257             estr=estr+uprod/usum
6258             do j=1,3
6259              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6260             enddo
6261           endif
6262         endif
6263       enddo
6264       return
6265       end
6266 #ifdef CRYST_THETA
6267 C--------------------------------------------------------------------------
6268       subroutine ebend(etheta)
6269 C
6270 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6271 C angles gamma and its derivatives in consecutive thetas and gammas.
6272 C
6273       implicit real*8 (a-h,o-z)
6274       include 'DIMENSIONS'
6275       include 'COMMON.LOCAL'
6276       include 'COMMON.GEO'
6277       include 'COMMON.INTERACT'
6278       include 'COMMON.DERIV'
6279       include 'COMMON.VAR'
6280       include 'COMMON.CHAIN'
6281       include 'COMMON.IOUNITS'
6282       include 'COMMON.NAMES'
6283       include 'COMMON.FFIELD'
6284       include 'COMMON.CONTROL'
6285       include 'COMMON.TORCNSTR'
6286       common /calcthet/ term1,term2,termm,diffak,ratak,
6287      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6288      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6289       double precision y(2),z(2)
6290       delta=0.02d0*pi
6291 c      time11=dexp(-2*time)
6292 c      time12=1.0d0
6293       etheta=0.0D0
6294 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6295       do i=ithet_start,ithet_end
6296         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6297      &  .or.itype(i).eq.ntyp1) cycle
6298 C Zero the energy function and its derivative at 0 or pi.
6299         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6300         it=itype(i-1)
6301         ichir1=isign(1,itype(i-2))
6302         ichir2=isign(1,itype(i))
6303          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6304          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6305          if (itype(i-1).eq.10) then
6306           itype1=isign(10,itype(i-2))
6307           ichir11=isign(1,itype(i-2))
6308           ichir12=isign(1,itype(i-2))
6309           itype2=isign(10,itype(i))
6310           ichir21=isign(1,itype(i))
6311           ichir22=isign(1,itype(i))
6312          endif
6313
6314         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6315 #ifdef OSF
6316           phii=phi(i)
6317           if (phii.ne.phii) phii=150.0
6318 #else
6319           phii=phi(i)
6320 #endif
6321           y(1)=dcos(phii)
6322           y(2)=dsin(phii)
6323         else
6324           y(1)=0.0D0
6325           y(2)=0.0D0
6326         endif
6327         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6328 #ifdef OSF
6329           phii1=phi(i+1)
6330           if (phii1.ne.phii1) phii1=150.0
6331           phii1=pinorm(phii1)
6332           z(1)=cos(phii1)
6333 #else
6334           phii1=phi(i+1)
6335 #endif
6336           z(1)=dcos(phii1)
6337           z(2)=dsin(phii1)
6338         else
6339           z(1)=0.0D0
6340           z(2)=0.0D0
6341         endif
6342 C Calculate the "mean" value of theta from the part of the distribution
6343 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6344 C In following comments this theta will be referred to as t_c.
6345         thet_pred_mean=0.0d0
6346         do k=1,2
6347             athetk=athet(k,it,ichir1,ichir2)
6348             bthetk=bthet(k,it,ichir1,ichir2)
6349           if (it.eq.10) then
6350              athetk=athet(k,itype1,ichir11,ichir12)
6351              bthetk=bthet(k,itype2,ichir21,ichir22)
6352           endif
6353          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6354 c         write(iout,*) 'chuj tu', y(k),z(k)
6355         enddo
6356         dthett=thet_pred_mean*ssd
6357         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6358 C Derivatives of the "mean" values in gamma1 and gamma2.
6359         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6360      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6361          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6362      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6363          if (it.eq.10) then
6364       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6365      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6366         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6367      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6368          endif
6369         if (theta(i).gt.pi-delta) then
6370           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6371      &         E_tc0)
6372           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6373           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6374           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6375      &        E_theta)
6376           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6377      &        E_tc)
6378         else if (theta(i).lt.delta) then
6379           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6380           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6381           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6382      &        E_theta)
6383           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6384           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6385      &        E_tc)
6386         else
6387           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6388      &        E_theta,E_tc)
6389         endif
6390         etheta=etheta+ethetai
6391         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6392      &      'ebend',i,ethetai,theta(i),itype(i)
6393         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6394         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6395         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6396       enddo
6397
6398 C Ufff.... We've done all this!!!
6399       return
6400       end
6401 C---------------------------------------------------------------------------
6402       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6403      &     E_tc)
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'COMMON.LOCAL'
6407       include 'COMMON.IOUNITS'
6408       common /calcthet/ term1,term2,termm,diffak,ratak,
6409      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6410      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6411 C Calculate the contributions to both Gaussian lobes.
6412 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6413 C The "polynomial part" of the "standard deviation" of this part of
6414 C the distributioni.
6415 ccc        write (iout,*) thetai,thet_pred_mean
6416         sig=polthet(3,it)
6417         do j=2,0,-1
6418           sig=sig*thet_pred_mean+polthet(j,it)
6419         enddo
6420 C Derivative of the "interior part" of the "standard deviation of the"
6421 C gamma-dependent Gaussian lobe in t_c.
6422         sigtc=3*polthet(3,it)
6423         do j=2,1,-1
6424           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6425         enddo
6426         sigtc=sig*sigtc
6427 C Set the parameters of both Gaussian lobes of the distribution.
6428 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6429         fac=sig*sig+sigc0(it)
6430         sigcsq=fac+fac
6431         sigc=1.0D0/sigcsq
6432 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6433         sigsqtc=-4.0D0*sigcsq*sigtc
6434 c       print *,i,sig,sigtc,sigsqtc
6435 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6436         sigtc=-sigtc/(fac*fac)
6437 C Following variable is sigma(t_c)**(-2)
6438         sigcsq=sigcsq*sigcsq
6439         sig0i=sig0(it)
6440         sig0inv=1.0D0/sig0i**2
6441         delthec=thetai-thet_pred_mean
6442         delthe0=thetai-theta0i
6443         term1=-0.5D0*sigcsq*delthec*delthec
6444         term2=-0.5D0*sig0inv*delthe0*delthe0
6445 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6446 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6447 C NaNs in taking the logarithm. We extract the largest exponent which is added
6448 C to the energy (this being the log of the distribution) at the end of energy
6449 C term evaluation for this virtual-bond angle.
6450         if (term1.gt.term2) then
6451           termm=term1
6452           term2=dexp(term2-termm)
6453           term1=1.0d0
6454         else
6455           termm=term2
6456           term1=dexp(term1-termm)
6457           term2=1.0d0
6458         endif
6459 C The ratio between the gamma-independent and gamma-dependent lobes of
6460 C the distribution is a Gaussian function of thet_pred_mean too.
6461         diffak=gthet(2,it)-thet_pred_mean
6462         ratak=diffak/gthet(3,it)**2
6463         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6464 C Let's differentiate it in thet_pred_mean NOW.
6465         aktc=ak*ratak
6466 C Now put together the distribution terms to make complete distribution.
6467         termexp=term1+ak*term2
6468         termpre=sigc+ak*sig0i
6469 C Contribution of the bending energy from this theta is just the -log of
6470 C the sum of the contributions from the two lobes and the pre-exponential
6471 C factor. Simple enough, isn't it?
6472         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6473 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6474 C NOW the derivatives!!!
6475 C 6/6/97 Take into account the deformation.
6476         E_theta=(delthec*sigcsq*term1
6477      &       +ak*delthe0*sig0inv*term2)/termexp
6478         E_tc=((sigtc+aktc*sig0i)/termpre
6479      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6480      &       aktc*term2)/termexp)
6481       return
6482       end
6483 c-----------------------------------------------------------------------------
6484       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6485       implicit real*8 (a-h,o-z)
6486       include 'DIMENSIONS'
6487       include 'COMMON.LOCAL'
6488       include 'COMMON.IOUNITS'
6489       common /calcthet/ term1,term2,termm,diffak,ratak,
6490      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6491      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6492       delthec=thetai-thet_pred_mean
6493       delthe0=thetai-theta0i
6494 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6495       t3 = thetai-thet_pred_mean
6496       t6 = t3**2
6497       t9 = term1
6498       t12 = t3*sigcsq
6499       t14 = t12+t6*sigsqtc
6500       t16 = 1.0d0
6501       t21 = thetai-theta0i
6502       t23 = t21**2
6503       t26 = term2
6504       t27 = t21*t26
6505       t32 = termexp
6506       t40 = t32**2
6507       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6508      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6509      & *(-t12*t9-ak*sig0inv*t27)
6510       return
6511       end
6512 #else
6513 C--------------------------------------------------------------------------
6514       subroutine ebend(etheta)
6515 C
6516 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6517 C angles gamma and its derivatives in consecutive thetas and gammas.
6518 C ab initio-derived potentials from
6519 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6520 C
6521       implicit real*8 (a-h,o-z)
6522       include 'DIMENSIONS'
6523       include 'COMMON.LOCAL'
6524       include 'COMMON.GEO'
6525       include 'COMMON.INTERACT'
6526       include 'COMMON.DERIV'
6527       include 'COMMON.VAR'
6528       include 'COMMON.CHAIN'
6529       include 'COMMON.IOUNITS'
6530       include 'COMMON.NAMES'
6531       include 'COMMON.FFIELD'
6532       include 'COMMON.CONTROL'
6533       include 'COMMON.TORCNSTR'
6534       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6535      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6536      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6537      & sinph1ph2(maxdouble,maxdouble)
6538       logical lprn /.false./, lprn1 /.false./
6539       etheta=0.0D0
6540       do i=ithet_start,ithet_end
6541 c        print *,i,itype(i-1),itype(i),itype(i-2)
6542         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6543      &  .or.itype(i).eq.ntyp1) cycle
6544 C        print *,i,theta(i)
6545         if (iabs(itype(i+1)).eq.20) iblock=2
6546         if (iabs(itype(i+1)).ne.20) iblock=1
6547         dethetai=0.0d0
6548         dephii=0.0d0
6549         dephii1=0.0d0
6550         theti2=0.5d0*theta(i)
6551         ityp2=ithetyp((itype(i-1)))
6552         do k=1,nntheterm
6553           coskt(k)=dcos(k*theti2)
6554           sinkt(k)=dsin(k*theti2)
6555         enddo
6556 C        print *,ethetai
6557         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6558 #ifdef OSF
6559           phii=phi(i)
6560           if (phii.ne.phii) phii=150.0
6561 #else
6562           phii=phi(i)
6563 #endif
6564           ityp1=ithetyp((itype(i-2)))
6565 C propagation of chirality for glycine type
6566           do k=1,nsingle
6567             cosph1(k)=dcos(k*phii)
6568             sinph1(k)=dsin(k*phii)
6569           enddo
6570         else
6571           phii=0.0d0
6572           do k=1,nsingle
6573           ityp1=ithetyp((itype(i-2)))
6574             cosph1(k)=0.0d0
6575             sinph1(k)=0.0d0
6576           enddo
6577         endif
6578         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6579 #ifdef OSF
6580           phii1=phi(i+1)
6581           if (phii1.ne.phii1) phii1=150.0
6582           phii1=pinorm(phii1)
6583 #else
6584           phii1=phi(i+1)
6585 #endif
6586           ityp3=ithetyp((itype(i)))
6587           do k=1,nsingle
6588             cosph2(k)=dcos(k*phii1)
6589             sinph2(k)=dsin(k*phii1)
6590           enddo
6591         else
6592           phii1=0.0d0
6593           ityp3=ithetyp((itype(i)))
6594           do k=1,nsingle
6595             cosph2(k)=0.0d0
6596             sinph2(k)=0.0d0
6597           enddo
6598         endif
6599         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6600         do k=1,ndouble
6601           do l=1,k-1
6602             ccl=cosph1(l)*cosph2(k-l)
6603             ssl=sinph1(l)*sinph2(k-l)
6604             scl=sinph1(l)*cosph2(k-l)
6605             csl=cosph1(l)*sinph2(k-l)
6606             cosph1ph2(l,k)=ccl-ssl
6607             cosph1ph2(k,l)=ccl+ssl
6608             sinph1ph2(l,k)=scl+csl
6609             sinph1ph2(k,l)=scl-csl
6610           enddo
6611         enddo
6612         if (lprn) then
6613         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6614      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6615         write (iout,*) "coskt and sinkt"
6616         do k=1,nntheterm
6617           write (iout,*) k,coskt(k),sinkt(k)
6618         enddo
6619         endif
6620         do k=1,ntheterm
6621           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6622           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6623      &      *coskt(k)
6624           if (lprn)
6625      &    write (iout,*) "k",k,"
6626      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6627      &     " ethetai",ethetai
6628         enddo
6629         if (lprn) then
6630         write (iout,*) "cosph and sinph"
6631         do k=1,nsingle
6632           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6633         enddo
6634         write (iout,*) "cosph1ph2 and sinph2ph2"
6635         do k=2,ndouble
6636           do l=1,k-1
6637             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6638      &         sinph1ph2(l,k),sinph1ph2(k,l)
6639           enddo
6640         enddo
6641         write(iout,*) "ethetai",ethetai
6642         endif
6643 C       print *,ethetai
6644         do m=1,ntheterm2
6645           do k=1,nsingle
6646             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6647      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6648      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6649      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6650             ethetai=ethetai+sinkt(m)*aux
6651             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6652             dephii=dephii+k*sinkt(m)*(
6653      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6654      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6655             dephii1=dephii1+k*sinkt(m)*(
6656      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6657      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6658             if (lprn)
6659      &      write (iout,*) "m",m," k",k," bbthet",
6660      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6661      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6662      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6663      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6664 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6665           enddo
6666         enddo
6667 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6668 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6669 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6670 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6671         if (lprn)
6672      &  write(iout,*) "ethetai",ethetai
6673 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6674         do m=1,ntheterm3
6675           do k=2,ndouble
6676             do l=1,k-1
6677               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6678      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6679      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6680      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6681               ethetai=ethetai+sinkt(m)*aux
6682               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6683               dephii=dephii+l*sinkt(m)*(
6684      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6685      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6686      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6687      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6688               dephii1=dephii1+(k-l)*sinkt(m)*(
6689      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6690      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6691      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6692      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6693               if (lprn) then
6694               write (iout,*) "m",m," k",k," l",l," ffthet",
6695      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6696      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6697      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6698      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6699      &            " ethetai",ethetai
6700               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6701      &            cosph1ph2(k,l)*sinkt(m),
6702      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6703               endif
6704             enddo
6705           enddo
6706         enddo
6707 10      continue
6708 c        lprn1=.true.
6709 C        print *,ethetai
6710         if (lprn1)
6711      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6712      &   i,theta(i)*rad2deg,phii*rad2deg,
6713      &   phii1*rad2deg,ethetai
6714 c        lprn1=.false.
6715         etheta=etheta+ethetai
6716         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6717         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6718         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6719       enddo
6720
6721       return
6722       end
6723 #endif
6724 #ifdef CRYST_SC
6725 c-----------------------------------------------------------------------------
6726       subroutine esc(escloc)
6727 C Calculate the local energy of a side chain and its derivatives in the
6728 C corresponding virtual-bond valence angles THETA and the spherical angles
6729 C ALPHA and OMEGA.
6730       implicit real*8 (a-h,o-z)
6731       include 'DIMENSIONS'
6732       include 'COMMON.GEO'
6733       include 'COMMON.LOCAL'
6734       include 'COMMON.VAR'
6735       include 'COMMON.INTERACT'
6736       include 'COMMON.DERIV'
6737       include 'COMMON.CHAIN'
6738       include 'COMMON.IOUNITS'
6739       include 'COMMON.NAMES'
6740       include 'COMMON.FFIELD'
6741       include 'COMMON.CONTROL'
6742       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6743      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6744       common /sccalc/ time11,time12,time112,theti,it,nlobit
6745       delta=0.02d0*pi
6746       escloc=0.0D0
6747 c     write (iout,'(a)') 'ESC'
6748       do i=loc_start,loc_end
6749         it=itype(i)
6750         if (it.eq.ntyp1) cycle
6751         if (it.eq.10) goto 1
6752         nlobit=nlob(iabs(it))
6753 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6754 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6755         theti=theta(i+1)-pipol
6756         x(1)=dtan(theti)
6757         x(2)=alph(i)
6758         x(3)=omeg(i)
6759
6760         if (x(2).gt.pi-delta) then
6761           xtemp(1)=x(1)
6762           xtemp(2)=pi-delta
6763           xtemp(3)=x(3)
6764           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6765           xtemp(2)=pi
6766           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6767           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6768      &        escloci,dersc(2))
6769           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6770      &        ddersc0(1),dersc(1))
6771           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6772      &        ddersc0(3),dersc(3))
6773           xtemp(2)=pi-delta
6774           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6775           xtemp(2)=pi
6776           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6777           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6778      &            dersc0(2),esclocbi,dersc02)
6779           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6780      &            dersc12,dersc01)
6781           call splinthet(x(2),0.5d0*delta,ss,ssd)
6782           dersc0(1)=dersc01
6783           dersc0(2)=dersc02
6784           dersc0(3)=0.0d0
6785           do k=1,3
6786             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6787           enddo
6788           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6789 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6790 c    &             esclocbi,ss,ssd
6791           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6792 c         escloci=esclocbi
6793 c         write (iout,*) escloci
6794         else if (x(2).lt.delta) then
6795           xtemp(1)=x(1)
6796           xtemp(2)=delta
6797           xtemp(3)=x(3)
6798           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6799           xtemp(2)=0.0d0
6800           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6801           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6802      &        escloci,dersc(2))
6803           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6804      &        ddersc0(1),dersc(1))
6805           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6806      &        ddersc0(3),dersc(3))
6807           xtemp(2)=delta
6808           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6809           xtemp(2)=0.0d0
6810           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6811           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6812      &            dersc0(2),esclocbi,dersc02)
6813           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6814      &            dersc12,dersc01)
6815           dersc0(1)=dersc01
6816           dersc0(2)=dersc02
6817           dersc0(3)=0.0d0
6818           call splinthet(x(2),0.5d0*delta,ss,ssd)
6819           do k=1,3
6820             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6821           enddo
6822           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6823 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6824 c    &             esclocbi,ss,ssd
6825           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6826 c         write (iout,*) escloci
6827         else
6828           call enesc(x,escloci,dersc,ddummy,.false.)
6829         endif
6830
6831         escloc=escloc+escloci
6832         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6833      &     'escloc',i,escloci
6834 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6835
6836         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6837      &   wscloc*dersc(1)
6838         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6839         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6840     1   continue
6841       enddo
6842       return
6843       end
6844 C---------------------------------------------------------------------------
6845       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6846       implicit real*8 (a-h,o-z)
6847       include 'DIMENSIONS'
6848       include 'COMMON.GEO'
6849       include 'COMMON.LOCAL'
6850       include 'COMMON.IOUNITS'
6851       common /sccalc/ time11,time12,time112,theti,it,nlobit
6852       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6853       double precision contr(maxlob,-1:1)
6854       logical mixed
6855 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6856         escloc_i=0.0D0
6857         do j=1,3
6858           dersc(j)=0.0D0
6859           if (mixed) ddersc(j)=0.0d0
6860         enddo
6861         x3=x(3)
6862
6863 C Because of periodicity of the dependence of the SC energy in omega we have
6864 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6865 C To avoid underflows, first compute & store the exponents.
6866
6867         do iii=-1,1
6868
6869           x(3)=x3+iii*dwapi
6870
6871           do j=1,nlobit
6872             do k=1,3
6873               z(k)=x(k)-censc(k,j,it)
6874             enddo
6875             do k=1,3
6876               Axk=0.0D0
6877               do l=1,3
6878                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6879               enddo
6880               Ax(k,j,iii)=Axk
6881             enddo
6882             expfac=0.0D0
6883             do k=1,3
6884               expfac=expfac+Ax(k,j,iii)*z(k)
6885             enddo
6886             contr(j,iii)=expfac
6887           enddo ! j
6888
6889         enddo ! iii
6890
6891         x(3)=x3
6892 C As in the case of ebend, we want to avoid underflows in exponentiation and
6893 C subsequent NaNs and INFs in energy calculation.
6894 C Find the largest exponent
6895         emin=contr(1,-1)
6896         do iii=-1,1
6897           do j=1,nlobit
6898             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6899           enddo
6900         enddo
6901         emin=0.5D0*emin
6902 cd      print *,'it=',it,' emin=',emin
6903
6904 C Compute the contribution to SC energy and derivatives
6905         do iii=-1,1
6906
6907           do j=1,nlobit
6908 #ifdef OSF
6909             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6910             if(adexp.ne.adexp) adexp=1.0
6911             expfac=dexp(adexp)
6912 #else
6913             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6914 #endif
6915 cd          print *,'j=',j,' expfac=',expfac
6916             escloc_i=escloc_i+expfac
6917             do k=1,3
6918               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6919             enddo
6920             if (mixed) then
6921               do k=1,3,2
6922                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6923      &            +gaussc(k,2,j,it))*expfac
6924               enddo
6925             endif
6926           enddo
6927
6928         enddo ! iii
6929
6930         dersc(1)=dersc(1)/cos(theti)**2
6931         ddersc(1)=ddersc(1)/cos(theti)**2
6932         ddersc(3)=ddersc(3)
6933
6934         escloci=-(dlog(escloc_i)-emin)
6935         do j=1,3
6936           dersc(j)=dersc(j)/escloc_i
6937         enddo
6938         if (mixed) then
6939           do j=1,3,2
6940             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6941           enddo
6942         endif
6943       return
6944       end
6945 C------------------------------------------------------------------------------
6946       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6947       implicit real*8 (a-h,o-z)
6948       include 'DIMENSIONS'
6949       include 'COMMON.GEO'
6950       include 'COMMON.LOCAL'
6951       include 'COMMON.IOUNITS'
6952       common /sccalc/ time11,time12,time112,theti,it,nlobit
6953       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6954       double precision contr(maxlob)
6955       logical mixed
6956
6957       escloc_i=0.0D0
6958
6959       do j=1,3
6960         dersc(j)=0.0D0
6961       enddo
6962
6963       do j=1,nlobit
6964         do k=1,2
6965           z(k)=x(k)-censc(k,j,it)
6966         enddo
6967         z(3)=dwapi
6968         do k=1,3
6969           Axk=0.0D0
6970           do l=1,3
6971             Axk=Axk+gaussc(l,k,j,it)*z(l)
6972           enddo
6973           Ax(k,j)=Axk
6974         enddo
6975         expfac=0.0D0
6976         do k=1,3
6977           expfac=expfac+Ax(k,j)*z(k)
6978         enddo
6979         contr(j)=expfac
6980       enddo ! j
6981
6982 C As in the case of ebend, we want to avoid underflows in exponentiation and
6983 C subsequent NaNs and INFs in energy calculation.
6984 C Find the largest exponent
6985       emin=contr(1)
6986       do j=1,nlobit
6987         if (emin.gt.contr(j)) emin=contr(j)
6988       enddo
6989       emin=0.5D0*emin
6990
6991 C Compute the contribution to SC energy and derivatives
6992
6993       dersc12=0.0d0
6994       do j=1,nlobit
6995         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6996         escloc_i=escloc_i+expfac
6997         do k=1,2
6998           dersc(k)=dersc(k)+Ax(k,j)*expfac
6999         enddo
7000         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7001      &            +gaussc(1,2,j,it))*expfac
7002         dersc(3)=0.0d0
7003       enddo
7004
7005       dersc(1)=dersc(1)/cos(theti)**2
7006       dersc12=dersc12/cos(theti)**2
7007       escloci=-(dlog(escloc_i)-emin)
7008       do j=1,2
7009         dersc(j)=dersc(j)/escloc_i
7010       enddo
7011       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7012       return
7013       end
7014 #else
7015 c----------------------------------------------------------------------------------
7016       subroutine esc(escloc)
7017 C Calculate the local energy of a side chain and its derivatives in the
7018 C corresponding virtual-bond valence angles THETA and the spherical angles
7019 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7020 C added by Urszula Kozlowska. 07/11/2007
7021 C
7022       implicit real*8 (a-h,o-z)
7023       include 'DIMENSIONS'
7024       include 'COMMON.GEO'
7025       include 'COMMON.LOCAL'
7026       include 'COMMON.VAR'
7027       include 'COMMON.SCROT'
7028       include 'COMMON.INTERACT'
7029       include 'COMMON.DERIV'
7030       include 'COMMON.CHAIN'
7031       include 'COMMON.IOUNITS'
7032       include 'COMMON.NAMES'
7033       include 'COMMON.FFIELD'
7034       include 'COMMON.CONTROL'
7035       include 'COMMON.VECTORS'
7036       double precision x_prime(3),y_prime(3),z_prime(3)
7037      &    , sumene,dsc_i,dp2_i,x(65),
7038      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7039      &    de_dxx,de_dyy,de_dzz,de_dt
7040       double precision s1_t,s1_6_t,s2_t,s2_6_t
7041       double precision
7042      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7043      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7044      & dt_dCi(3),dt_dCi1(3)
7045       common /sccalc/ time11,time12,time112,theti,it,nlobit
7046       delta=0.02d0*pi
7047       escloc=0.0D0
7048       do i=loc_start,loc_end
7049         if (itype(i).eq.ntyp1) cycle
7050         costtab(i+1) =dcos(theta(i+1))
7051         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7052         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7053         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7054         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7055         cosfac=dsqrt(cosfac2)
7056         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7057         sinfac=dsqrt(sinfac2)
7058         it=iabs(itype(i))
7059         if (it.eq.10) goto 1
7060 c
7061 C  Compute the axes of tghe local cartesian coordinates system; store in
7062 c   x_prime, y_prime and z_prime
7063 c
7064         do j=1,3
7065           x_prime(j) = 0.00
7066           y_prime(j) = 0.00
7067           z_prime(j) = 0.00
7068         enddo
7069 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7070 C     &   dc_norm(3,i+nres)
7071         do j = 1,3
7072           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7073           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7074         enddo
7075         do j = 1,3
7076           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7077         enddo
7078 c       write (2,*) "i",i
7079 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7080 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7081 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7082 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7083 c      & " xy",scalar(x_prime(1),y_prime(1)),
7084 c      & " xz",scalar(x_prime(1),z_prime(1)),
7085 c      & " yy",scalar(y_prime(1),y_prime(1)),
7086 c      & " yz",scalar(y_prime(1),z_prime(1)),
7087 c      & " zz",scalar(z_prime(1),z_prime(1))
7088 c
7089 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7090 C to local coordinate system. Store in xx, yy, zz.
7091 c
7092         xx=0.0d0
7093         yy=0.0d0
7094         zz=0.0d0
7095         do j = 1,3
7096           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7097           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7098           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7099         enddo
7100
7101         xxtab(i)=xx
7102         yytab(i)=yy
7103         zztab(i)=zz
7104 C
7105 C Compute the energy of the ith side cbain
7106 C
7107 c        write (2,*) "xx",xx," yy",yy," zz",zz
7108         it=iabs(itype(i))
7109         do j = 1,65
7110           x(j) = sc_parmin(j,it)
7111         enddo
7112 #ifdef CHECK_COORD
7113 Cc diagnostics - remove later
7114         xx1 = dcos(alph(2))
7115         yy1 = dsin(alph(2))*dcos(omeg(2))
7116         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7117         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7118      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7119      &    xx1,yy1,zz1
7120 C,"  --- ", xx_w,yy_w,zz_w
7121 c end diagnostics
7122 #endif
7123         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7124      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7125      &   + x(10)*yy*zz
7126         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7127      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7128      & + x(20)*yy*zz
7129         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7130      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7131      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7132      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7133      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7134      &  +x(40)*xx*yy*zz
7135         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7136      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7137      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7138      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7139      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7140      &  +x(60)*xx*yy*zz
7141         dsc_i   = 0.743d0+x(61)
7142         dp2_i   = 1.9d0+x(62)
7143         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7144      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7145         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7146      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7147         s1=(1+x(63))/(0.1d0 + dscp1)
7148         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7149         s2=(1+x(65))/(0.1d0 + dscp2)
7150         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7151         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7152      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7153 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7154 c     &   sumene4,
7155 c     &   dscp1,dscp2,sumene
7156 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7157         escloc = escloc + sumene
7158 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7159 c     & ,zz,xx,yy
7160 c#define DEBUG
7161 #ifdef DEBUG
7162 C
7163 C This section to check the numerical derivatives of the energy of ith side
7164 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7165 C #define DEBUG in the code to turn it on.
7166 C
7167         write (2,*) "sumene               =",sumene
7168         aincr=1.0d-7
7169         xxsave=xx
7170         xx=xx+aincr
7171         write (2,*) xx,yy,zz
7172         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7173         de_dxx_num=(sumenep-sumene)/aincr
7174         xx=xxsave
7175         write (2,*) "xx+ sumene from enesc=",sumenep
7176         yysave=yy
7177         yy=yy+aincr
7178         write (2,*) xx,yy,zz
7179         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7180         de_dyy_num=(sumenep-sumene)/aincr
7181         yy=yysave
7182         write (2,*) "yy+ sumene from enesc=",sumenep
7183         zzsave=zz
7184         zz=zz+aincr
7185         write (2,*) xx,yy,zz
7186         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7187         de_dzz_num=(sumenep-sumene)/aincr
7188         zz=zzsave
7189         write (2,*) "zz+ sumene from enesc=",sumenep
7190         costsave=cost2tab(i+1)
7191         sintsave=sint2tab(i+1)
7192         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7193         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7194         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7195         de_dt_num=(sumenep-sumene)/aincr
7196         write (2,*) " t+ sumene from enesc=",sumenep
7197         cost2tab(i+1)=costsave
7198         sint2tab(i+1)=sintsave
7199 C End of diagnostics section.
7200 #endif
7201 C
7202 C Compute the gradient of esc
7203 C
7204 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7205         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7206         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7207         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7208         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7209         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7210         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7211         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7212         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7213         pom1=(sumene3*sint2tab(i+1)+sumene1)
7214      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7215         pom2=(sumene4*cost2tab(i+1)+sumene2)
7216      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7217         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7218         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7219      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7220      &  +x(40)*yy*zz
7221         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7222         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7223      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7224      &  +x(60)*yy*zz
7225         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7226      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7227      &        +(pom1+pom2)*pom_dx
7228 #ifdef DEBUG
7229         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7230 #endif
7231 C
7232         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7233         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7234      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7235      &  +x(40)*xx*zz
7236         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7237         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7238      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7239      &  +x(59)*zz**2 +x(60)*xx*zz
7240         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7241      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7242      &        +(pom1-pom2)*pom_dy
7243 #ifdef DEBUG
7244         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7245 #endif
7246 C
7247         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7248      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7249      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7250      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7251      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7252      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7253      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7254      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7255 #ifdef DEBUG
7256         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7257 #endif
7258 C
7259         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7260      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7261      &  +pom1*pom_dt1+pom2*pom_dt2
7262 #ifdef DEBUG
7263         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7264 #endif
7265 c#undef DEBUG
7266 c
7267 C
7268        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7269        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7270        cosfac2xx=cosfac2*xx
7271        sinfac2yy=sinfac2*yy
7272        do k = 1,3
7273          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7274      &      vbld_inv(i+1)
7275          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7276      &      vbld_inv(i)
7277          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7278          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7279 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7280 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7281 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7282 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7283          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7284          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7285          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7286          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7287          dZZ_Ci1(k)=0.0d0
7288          dZZ_Ci(k)=0.0d0
7289          do j=1,3
7290            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7291      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7292            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7293      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7294          enddo
7295
7296          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7297          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7298          dZZ_XYZ(k)=vbld_inv(i+nres)*
7299      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7300 c
7301          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7302          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7303        enddo
7304
7305        do k=1,3
7306          dXX_Ctab(k,i)=dXX_Ci(k)
7307          dXX_C1tab(k,i)=dXX_Ci1(k)
7308          dYY_Ctab(k,i)=dYY_Ci(k)
7309          dYY_C1tab(k,i)=dYY_Ci1(k)
7310          dZZ_Ctab(k,i)=dZZ_Ci(k)
7311          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7312          dXX_XYZtab(k,i)=dXX_XYZ(k)
7313          dYY_XYZtab(k,i)=dYY_XYZ(k)
7314          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7315        enddo
7316
7317        do k = 1,3
7318 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7319 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7320 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7321 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7322 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7323 c     &    dt_dci(k)
7324 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7325 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7326          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7327      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7328          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7329      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7330          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7331      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7332        enddo
7333 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7334 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7335
7336 C to check gradient call subroutine check_grad
7337
7338     1 continue
7339       enddo
7340       return
7341       end
7342 c------------------------------------------------------------------------------
7343       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7344       implicit none
7345       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7346      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7347       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7348      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7349      &   + x(10)*yy*zz
7350       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7351      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7352      & + x(20)*yy*zz
7353       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7354      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7355      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7356      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7357      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7358      &  +x(40)*xx*yy*zz
7359       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7360      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7361      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7362      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7363      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7364      &  +x(60)*xx*yy*zz
7365       dsc_i   = 0.743d0+x(61)
7366       dp2_i   = 1.9d0+x(62)
7367       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7368      &          *(xx*cost2+yy*sint2))
7369       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7370      &          *(xx*cost2-yy*sint2))
7371       s1=(1+x(63))/(0.1d0 + dscp1)
7372       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7373       s2=(1+x(65))/(0.1d0 + dscp2)
7374       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7375       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7376      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7377       enesc=sumene
7378       return
7379       end
7380 #endif
7381 c------------------------------------------------------------------------------
7382       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7383 C
7384 C This procedure calculates two-body contact function g(rij) and its derivative:
7385 C
7386 C           eps0ij                                     !       x < -1
7387 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7388 C            0                                         !       x > 1
7389 C
7390 C where x=(rij-r0ij)/delta
7391 C
7392 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7393 C
7394       implicit none
7395       double precision rij,r0ij,eps0ij,fcont,fprimcont
7396       double precision x,x2,x4,delta
7397 c     delta=0.02D0*r0ij
7398 c      delta=0.2D0*r0ij
7399       x=(rij-r0ij)/delta
7400       if (x.lt.-1.0D0) then
7401         fcont=eps0ij
7402         fprimcont=0.0D0
7403       else if (x.le.1.0D0) then
7404         x2=x*x
7405         x4=x2*x2
7406         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7407         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7408       else
7409         fcont=0.0D0
7410         fprimcont=0.0D0
7411       endif
7412       return
7413       end
7414 c------------------------------------------------------------------------------
7415       subroutine splinthet(theti,delta,ss,ssder)
7416       implicit real*8 (a-h,o-z)
7417       include 'DIMENSIONS'
7418       include 'COMMON.VAR'
7419       include 'COMMON.GEO'
7420       thetup=pi-delta
7421       thetlow=delta
7422       if (theti.gt.pipol) then
7423         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7424       else
7425         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7426         ssder=-ssder
7427       endif
7428       return
7429       end
7430 c------------------------------------------------------------------------------
7431       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7432       implicit none
7433       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7434       double precision ksi,ksi2,ksi3,a1,a2,a3
7435       a1=fprim0*delta/(f1-f0)
7436       a2=3.0d0-2.0d0*a1
7437       a3=a1-2.0d0
7438       ksi=(x-x0)/delta
7439       ksi2=ksi*ksi
7440       ksi3=ksi2*ksi
7441       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7442       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7443       return
7444       end
7445 c------------------------------------------------------------------------------
7446       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7447       implicit none
7448       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7449       double precision ksi,ksi2,ksi3,a1,a2,a3
7450       ksi=(x-x0)/delta
7451       ksi2=ksi*ksi
7452       ksi3=ksi2*ksi
7453       a1=fprim0x*delta
7454       a2=3*(f1x-f0x)-2*fprim0x*delta
7455       a3=fprim0x*delta-2*(f1x-f0x)
7456       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7457       return
7458       end
7459 C-----------------------------------------------------------------------------
7460 #ifdef CRYST_TOR
7461 C-----------------------------------------------------------------------------
7462       subroutine etor(etors)
7463       implicit real*8 (a-h,o-z)
7464       include 'DIMENSIONS'
7465       include 'COMMON.VAR'
7466       include 'COMMON.GEO'
7467       include 'COMMON.LOCAL'
7468       include 'COMMON.TORSION'
7469       include 'COMMON.INTERACT'
7470       include 'COMMON.DERIV'
7471       include 'COMMON.CHAIN'
7472       include 'COMMON.NAMES'
7473       include 'COMMON.IOUNITS'
7474       include 'COMMON.FFIELD'
7475       include 'COMMON.TORCNSTR'
7476       include 'COMMON.CONTROL'
7477       logical lprn
7478 C Set lprn=.true. for debugging
7479       lprn=.false.
7480 c      lprn=.true.
7481       etors=0.0D0
7482       do i=iphi_start,iphi_end
7483       etors_ii=0.0D0
7484         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7485      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7486         itori=itortyp(itype(i-2))
7487         itori1=itortyp(itype(i-1))
7488         phii=phi(i)
7489         gloci=0.0D0
7490 C Proline-Proline pair is a special case...
7491         if (itori.eq.3 .and. itori1.eq.3) then
7492           if (phii.gt.-dwapi3) then
7493             cosphi=dcos(3*phii)
7494             fac=1.0D0/(1.0D0-cosphi)
7495             etorsi=v1(1,3,3)*fac
7496             etorsi=etorsi+etorsi
7497             etors=etors+etorsi-v1(1,3,3)
7498             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7499             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7500           endif
7501           do j=1,3
7502             v1ij=v1(j+1,itori,itori1)
7503             v2ij=v2(j+1,itori,itori1)
7504             cosphi=dcos(j*phii)
7505             sinphi=dsin(j*phii)
7506             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7507             if (energy_dec) etors_ii=etors_ii+
7508      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7509             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7510           enddo
7511         else
7512           do j=1,nterm_old
7513             v1ij=v1(j,itori,itori1)
7514             v2ij=v2(j,itori,itori1)
7515             cosphi=dcos(j*phii)
7516             sinphi=dsin(j*phii)
7517             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7518             if (energy_dec) etors_ii=etors_ii+
7519      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7520             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7521           enddo
7522         endif
7523         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7524              'etor',i,etors_ii
7525         if (lprn)
7526      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7527      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7528      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7529         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7530 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7531       enddo
7532       return
7533       end
7534 c------------------------------------------------------------------------------
7535       subroutine etor_d(etors_d)
7536       etors_d=0.0d0
7537       return
7538       end
7539 c----------------------------------------------------------------------------
7540 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7541       subroutine e_modeller(ehomology_constr)
7542       ehomology_constr=0.0d0
7543       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7544       return
7545       end
7546 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7547
7548 c------------------------------------------------------------------------------
7549       subroutine etor_d(etors_d)
7550       etors_d=0.0d0
7551       return
7552       end
7553 c----------------------------------------------------------------------------
7554 #else
7555       subroutine etor(etors)
7556       implicit real*8 (a-h,o-z)
7557       include 'DIMENSIONS'
7558       include 'COMMON.VAR'
7559       include 'COMMON.GEO'
7560       include 'COMMON.LOCAL'
7561       include 'COMMON.TORSION'
7562       include 'COMMON.INTERACT'
7563       include 'COMMON.DERIV'
7564       include 'COMMON.CHAIN'
7565       include 'COMMON.NAMES'
7566       include 'COMMON.IOUNITS'
7567       include 'COMMON.FFIELD'
7568       include 'COMMON.TORCNSTR'
7569       include 'COMMON.CONTROL'
7570       logical lprn
7571 C Set lprn=.true. for debugging
7572       lprn=.false.
7573 c     lprn=.true.
7574       etors=0.0D0
7575       do i=iphi_start,iphi_end
7576 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7577 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7578 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7579 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7580         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7581      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7582 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7583 C For introducing the NH3+ and COO- group please check the etor_d for reference
7584 C and guidance
7585         etors_ii=0.0D0
7586          if (iabs(itype(i)).eq.20) then
7587          iblock=2
7588          else
7589          iblock=1
7590          endif
7591         itori=itortyp(itype(i-2))
7592         itori1=itortyp(itype(i-1))
7593         phii=phi(i)
7594         gloci=0.0D0
7595 C Regular cosine and sine terms
7596         do j=1,nterm(itori,itori1,iblock)
7597           v1ij=v1(j,itori,itori1,iblock)
7598           v2ij=v2(j,itori,itori1,iblock)
7599           cosphi=dcos(j*phii)
7600           sinphi=dsin(j*phii)
7601           etors=etors+v1ij*cosphi+v2ij*sinphi
7602           if (energy_dec) etors_ii=etors_ii+
7603      &                v1ij*cosphi+v2ij*sinphi
7604           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7605         enddo
7606 C Lorentz terms
7607 C                         v1
7608 C  E = SUM ----------------------------------- - v1
7609 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7610 C
7611         cosphi=dcos(0.5d0*phii)
7612         sinphi=dsin(0.5d0*phii)
7613         do j=1,nlor(itori,itori1,iblock)
7614           vl1ij=vlor1(j,itori,itori1)
7615           vl2ij=vlor2(j,itori,itori1)
7616           vl3ij=vlor3(j,itori,itori1)
7617           pom=vl2ij*cosphi+vl3ij*sinphi
7618           pom1=1.0d0/(pom*pom+1.0d0)
7619           etors=etors+vl1ij*pom1
7620           if (energy_dec) etors_ii=etors_ii+
7621      &                vl1ij*pom1
7622           pom=-pom*pom1*pom1
7623           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7624         enddo
7625 C Subtract the constant term
7626         etors=etors-v0(itori,itori1,iblock)
7627           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7628      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7629         if (lprn)
7630      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7631      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7632      &  (v1(j,itori,itori1,iblock),j=1,6),
7633      &  (v2(j,itori,itori1,iblock),j=1,6)
7634         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7635 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7636       enddo
7637       return
7638       end
7639 c----------------------------------------------------------------------------
7640       subroutine etor_d(etors_d)
7641 C 6/23/01 Compute double torsional energy
7642       implicit real*8 (a-h,o-z)
7643       include 'DIMENSIONS'
7644       include 'COMMON.VAR'
7645       include 'COMMON.GEO'
7646       include 'COMMON.LOCAL'
7647       include 'COMMON.TORSION'
7648       include 'COMMON.INTERACT'
7649       include 'COMMON.DERIV'
7650       include 'COMMON.CHAIN'
7651       include 'COMMON.NAMES'
7652       include 'COMMON.IOUNITS'
7653       include 'COMMON.FFIELD'
7654       include 'COMMON.TORCNSTR'
7655       logical lprn
7656 C Set lprn=.true. for debugging
7657       lprn=.false.
7658 c     lprn=.true.
7659       etors_d=0.0D0
7660 c      write(iout,*) "a tu??"
7661       do i=iphid_start,iphid_end
7662 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7663 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7664 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7665 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7666 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7667          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7668      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7669      &  (itype(i+1).eq.ntyp1)) cycle
7670 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7671         itori=itortyp(itype(i-2))
7672         itori1=itortyp(itype(i-1))
7673         itori2=itortyp(itype(i))
7674         phii=phi(i)
7675         phii1=phi(i+1)
7676         gloci1=0.0D0
7677         gloci2=0.0D0
7678         iblock=1
7679         if (iabs(itype(i+1)).eq.20) iblock=2
7680 C Iblock=2 Proline type
7681 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7682 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7683 C        if (itype(i+1).eq.ntyp1) iblock=3
7684 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7685 C IS or IS NOT need for this
7686 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7687 C        is (itype(i-3).eq.ntyp1) ntblock=2
7688 C        ntblock is N-terminal blocking group
7689
7690 C Regular cosine and sine terms
7691         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7692 C Example of changes for NH3+ blocking group
7693 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7694 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7695           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7696           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7697           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7698           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7699           cosphi1=dcos(j*phii)
7700           sinphi1=dsin(j*phii)
7701           cosphi2=dcos(j*phii1)
7702           sinphi2=dsin(j*phii1)
7703           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7704      &     v2cij*cosphi2+v2sij*sinphi2
7705           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7706           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7707         enddo
7708         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7709           do l=1,k-1
7710             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7711             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7712             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7713             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7714             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7715             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7716             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7717             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7718             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7719      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7720             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7721      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7722             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7723      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7724           enddo
7725         enddo
7726         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7727         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7728       enddo
7729       return
7730       end
7731 #endif
7732 C----------------------------------------------------------------------------------
7733 C The rigorous attempt to derive energy function
7734       subroutine etor_kcc(etors)
7735       implicit real*8 (a-h,o-z)
7736       include 'DIMENSIONS'
7737       include 'COMMON.VAR'
7738       include 'COMMON.GEO'
7739       include 'COMMON.LOCAL'
7740       include 'COMMON.TORSION'
7741       include 'COMMON.INTERACT'
7742       include 'COMMON.DERIV'
7743       include 'COMMON.CHAIN'
7744       include 'COMMON.NAMES'
7745       include 'COMMON.IOUNITS'
7746       include 'COMMON.FFIELD'
7747       include 'COMMON.TORCNSTR'
7748       include 'COMMON.CONTROL'
7749       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7750       logical lprn
7751 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7752 C Set lprn=.true. for debugging
7753       lprn=energy_dec
7754 c     lprn=.true.
7755 C      print *,"wchodze kcc"
7756       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7757       etors=0.0D0
7758       do i=iphi_start,iphi_end
7759 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7760 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7761 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7762 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7763         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7764      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7765         itori=itortyp(itype(i-2))
7766         itori1=itortyp(itype(i-1))
7767         phii=phi(i)
7768         glocig=0.0D0
7769         glocit1=0.0d0
7770         glocit2=0.0d0
7771 C to avoid multiple devision by 2
7772 c        theti22=0.5d0*theta(i)
7773 C theta 12 is the theta_1 /2
7774 C theta 22 is theta_2 /2
7775 c        theti12=0.5d0*theta(i-1)
7776 C and appropriate sinus function
7777         sinthet1=dsin(theta(i-1))
7778         sinthet2=dsin(theta(i))
7779         costhet1=dcos(theta(i-1))
7780         costhet2=dcos(theta(i))
7781 C to speed up lets store its mutliplication
7782         sint1t2=sinthet2*sinthet1
7783         sint1t2n=1.0d0
7784 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7785 C +d_n*sin(n*gamma)) *
7786 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7787 C we have two sum 1) Non-Chebyshev which is with n and gamma
7788         nval=nterm_kcc_Tb(itori,itori1)
7789         c1(0)=0.0d0
7790         c2(0)=0.0d0
7791         c1(1)=1.0d0
7792         c2(1)=1.0d0
7793         do j=2,nval
7794           c1(j)=c1(j-1)*costhet1
7795           c2(j)=c2(j-1)*costhet2
7796         enddo
7797         etori=0.0d0
7798         do j=1,nterm_kcc(itori,itori1)
7799           cosphi=dcos(j*phii)
7800           sinphi=dsin(j*phii)
7801           sint1t2n1=sint1t2n
7802           sint1t2n=sint1t2n*sint1t2
7803           sumvalc=0.0d0
7804           gradvalct1=0.0d0
7805           gradvalct2=0.0d0
7806           do k=1,nval
7807             do l=1,nval
7808               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7809               gradvalct1=gradvalct1+
7810      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7811               gradvalct2=gradvalct2+
7812      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7813             enddo
7814           enddo
7815           gradvalct1=-gradvalct1*sinthet1
7816           gradvalct2=-gradvalct2*sinthet2
7817           sumvals=0.0d0
7818           gradvalst1=0.0d0
7819           gradvalst2=0.0d0
7820           do k=1,nval
7821             do l=1,nval
7822               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7823               gradvalst1=gradvalst1+
7824      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7825               gradvalst2=gradvalst2+
7826      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7827             enddo
7828           enddo
7829           gradvalst1=-gradvalst1*sinthet1
7830           gradvalst2=-gradvalst2*sinthet2
7831           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7832           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7833 C glocig is the gradient local i site in gamma
7834           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7835 C now gradient over theta_1
7836           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7837      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7838           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7839      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7840         enddo ! j
7841         etors=etors+etori
7842 C derivative over gamma
7843         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7844 C derivative over theta1
7845         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7846 C now derivative over theta2
7847         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7848         if (lprn) then
7849           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7850      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7851           write (iout,*) "c1",(c1(k),k=0,nval),
7852      &    " c2",(c2(k),k=0,nval)
7853         endif
7854       enddo
7855       return
7856       end
7857 c---------------------------------------------------------------------------------------------
7858       subroutine etor_constr(edihcnstr)
7859       implicit real*8 (a-h,o-z)
7860       include 'DIMENSIONS'
7861       include 'COMMON.VAR'
7862       include 'COMMON.GEO'
7863       include 'COMMON.LOCAL'
7864       include 'COMMON.TORSION'
7865       include 'COMMON.INTERACT'
7866       include 'COMMON.DERIV'
7867       include 'COMMON.CHAIN'
7868       include 'COMMON.NAMES'
7869       include 'COMMON.IOUNITS'
7870       include 'COMMON.FFIELD'
7871       include 'COMMON.TORCNSTR'
7872       include 'COMMON.BOUNDS'
7873       include 'COMMON.CONTROL'
7874 ! 6/20/98 - dihedral angle constraints
7875       edihcnstr=0.0d0
7876 c      do i=1,ndih_constr
7877       if (raw_psipred) then
7878         do i=idihconstr_start,idihconstr_end
7879           itori=idih_constr(i)
7880           phii=phi(itori)
7881           gaudih_i=vpsipred(1,i)
7882           gauder_i=0.0d0
7883           do j=1,2
7884             s = sdihed(j,i)
7885             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7886             dexpcos_i=dexp(-cos_i*cos_i)
7887             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7888             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7889      &            *cos_i*dexpcos_i/s**2
7890           enddo
7891           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7892           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7893           if (energy_dec)
7894      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7895      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7896      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7897      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7898      &     -wdihc*dlog(gaudih_i)
7899         enddo
7900       else
7901
7902       do i=idihconstr_start,idihconstr_end
7903         itori=idih_constr(i)
7904         phii=phi(itori)
7905         difi=pinorm(phii-phi0(i))
7906         if (difi.gt.drange(i)) then
7907           difi=difi-drange(i)
7908           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7909           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7910         else if (difi.lt.-drange(i)) then
7911           difi=difi+drange(i)
7912           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7913           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7914         else
7915           difi=0.0
7916         endif
7917       enddo
7918
7919       endif
7920
7921       return
7922       end
7923 c----------------------------------------------------------------------------
7924 c MODELLER restraint function
7925       subroutine e_modeller(ehomology_constr)
7926       implicit real*8 (a-h,o-z)
7927       include 'DIMENSIONS'
7928
7929       integer nnn, i, j, k, ki, irec, l
7930       integer katy, odleglosci, test7
7931       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7932       real*8 Eval,Erot
7933       real*8 distance(max_template),distancek(max_template),
7934      &    min_odl,godl(max_template),dih_diff(max_template)
7935
7936 c
7937 c     FP - 30/10/2014 Temporary specifications for homology restraints
7938 c
7939       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7940      &                 sgtheta
7941       double precision, dimension (maxres) :: guscdiff,usc_diff
7942       double precision, dimension (max_template) ::
7943      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7944      &           theta_diff
7945 c
7946
7947       include 'COMMON.SBRIDGE'
7948       include 'COMMON.CHAIN'
7949       include 'COMMON.GEO'
7950       include 'COMMON.DERIV'
7951       include 'COMMON.LOCAL'
7952       include 'COMMON.INTERACT'
7953       include 'COMMON.VAR'
7954       include 'COMMON.IOUNITS'
7955       include 'COMMON.MD'
7956       include 'COMMON.CONTROL'
7957 c
7958 c     From subroutine Econstr_back
7959 c
7960       include 'COMMON.NAMES'
7961       include 'COMMON.TIME1'
7962 c
7963
7964
7965       do i=1,max_template
7966         distancek(i)=9999999.9
7967       enddo
7968
7969
7970       odleg=0.0d0
7971
7972 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7973 c function)
7974 C AL 5/2/14 - Introduce list of restraints
7975 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7976 #ifdef DEBUG
7977       write(iout,*) "------- dist restrs start -------"
7978 #endif
7979       do ii = link_start_homo,link_end_homo
7980          i = ires_homo(ii)
7981          j = jres_homo(ii)
7982          dij=dist(i,j)
7983 c        write (iout,*) "dij(",i,j,") =",dij
7984          nexl=0
7985          do k=1,constr_homology
7986 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7987            if(.not.l_homo(k,ii)) then
7988              nexl=nexl+1
7989              cycle
7990            endif
7991            distance(k)=odl(k,ii)-dij
7992 c          write (iout,*) "distance(",k,") =",distance(k)
7993 c
7994 c          For Gaussian-type Urestr
7995 c
7996            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7997 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7998 c          write (iout,*) "distancek(",k,") =",distancek(k)
7999 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8000 c
8001 c          For Lorentzian-type Urestr
8002 c
8003            if (waga_dist.lt.0.0d0) then
8004               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8005               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8006      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8007            endif
8008          enddo
8009
8010 c         min_odl=minval(distancek)
8011          do kk=1,constr_homology
8012           if(l_homo(kk,ii)) then
8013             min_odl=distancek(kk)
8014             exit
8015           endif
8016          enddo
8017          do kk=1,constr_homology
8018           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8019      &              min_odl=distancek(kk)
8020          enddo
8021
8022 c        write (iout,* )"min_odl",min_odl
8023 #ifdef DEBUG
8024          write (iout,*) "ij dij",i,j,dij
8025          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8026          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8027          write (iout,* )"min_odl",min_odl
8028 #endif
8029 #ifdef OLDRESTR
8030          odleg2=0.0d0
8031 #else
8032          if (waga_dist.ge.0.0d0) then
8033            odleg2=nexl
8034          else
8035            odleg2=0.0d0
8036          endif
8037 #endif
8038          do k=1,constr_homology
8039 c Nie wiem po co to liczycie jeszcze raz!
8040 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8041 c     &              (2*(sigma_odl(i,j,k))**2))
8042            if(.not.l_homo(k,ii)) cycle
8043            if (waga_dist.ge.0.0d0) then
8044 c
8045 c          For Gaussian-type Urestr
8046 c
8047             godl(k)=dexp(-distancek(k)+min_odl)
8048             odleg2=odleg2+godl(k)
8049 c
8050 c          For Lorentzian-type Urestr
8051 c
8052            else
8053             odleg2=odleg2+distancek(k)
8054            endif
8055
8056 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8057 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8058 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8059 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8060
8061          enddo
8062 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8063 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8064 #ifdef DEBUG
8065          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8066          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8067 #endif
8068            if (waga_dist.ge.0.0d0) then
8069 c
8070 c          For Gaussian-type Urestr
8071 c
8072               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8073 c
8074 c          For Lorentzian-type Urestr
8075 c
8076            else
8077               odleg=odleg+odleg2/constr_homology
8078            endif
8079 c
8080 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8081 c Gradient
8082 c
8083 c          For Gaussian-type Urestr
8084 c
8085          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8086          sum_sgodl=0.0d0
8087          do k=1,constr_homology
8088 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8089 c     &           *waga_dist)+min_odl
8090 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8091 c
8092          if(.not.l_homo(k,ii)) cycle
8093          if (waga_dist.ge.0.0d0) then
8094 c          For Gaussian-type Urestr
8095 c
8096            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8097 c
8098 c          For Lorentzian-type Urestr
8099 c
8100          else
8101            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8102      &           sigma_odlir(k,ii)**2)**2)
8103          endif
8104            sum_sgodl=sum_sgodl+sgodl
8105
8106 c            sgodl2=sgodl2+sgodl
8107 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8108 c      write(iout,*) "constr_homology=",constr_homology
8109 c      write(iout,*) i, j, k, "TEST K"
8110          enddo
8111          if (waga_dist.ge.0.0d0) then
8112 c
8113 c          For Gaussian-type Urestr
8114 c
8115             grad_odl3=waga_homology(iset)*waga_dist
8116      &                *sum_sgodl/(sum_godl*dij)
8117 c
8118 c          For Lorentzian-type Urestr
8119 c
8120          else
8121 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8122 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8123             grad_odl3=-waga_homology(iset)*waga_dist*
8124      &                sum_sgodl/(constr_homology*dij)
8125          endif
8126 c
8127 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8128
8129
8130 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8131 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8132 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8133
8134 ccc      write(iout,*) godl, sgodl, grad_odl3
8135
8136 c          grad_odl=grad_odl+grad_odl3
8137
8138          do jik=1,3
8139             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8140 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8141 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8142 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8143             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8144             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8145 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8146 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8147 c         if (i.eq.25.and.j.eq.27) then
8148 c         write(iout,*) "jik",jik,"i",i,"j",j
8149 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8150 c         write(iout,*) "grad_odl3",grad_odl3
8151 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8152 c         write(iout,*) "ggodl",ggodl
8153 c         write(iout,*) "ghpbc(",jik,i,")",
8154 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8155 c     &                 ghpbc(jik,j)
8156 c         endif
8157          enddo
8158 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8159 ccc     & dLOG(odleg2),"-odleg=", -odleg
8160
8161       enddo ! ii-loop for dist
8162 #ifdef DEBUG
8163       write(iout,*) "------- dist restrs end -------"
8164 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8165 c    &     waga_d.eq.1.0d0) call sum_gradient
8166 #endif
8167 c Pseudo-energy and gradient from dihedral-angle restraints from
8168 c homology templates
8169 c      write (iout,*) "End of distance loop"
8170 c      call flush(iout)
8171       kat=0.0d0
8172 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8173 #ifdef DEBUG
8174       write(iout,*) "------- dih restrs start -------"
8175       do i=idihconstr_start_homo,idihconstr_end_homo
8176         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8177       enddo
8178 #endif
8179       do i=idihconstr_start_homo,idihconstr_end_homo
8180         kat2=0.0d0
8181 c        betai=beta(i,i+1,i+2,i+3)
8182         betai = phi(i)
8183 c       write (iout,*) "betai =",betai
8184         do k=1,constr_homology
8185           dih_diff(k)=pinorm(dih(k,i)-betai)
8186 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8187 cd     &                  ,sigma_dih(k,i)
8188 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8189 c     &                                   -(6.28318-dih_diff(i,k))
8190 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8191 c     &                                   6.28318+dih_diff(i,k)
8192 #ifdef OLD_DIHED
8193           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8194 #else
8195           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8196 #endif
8197 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8198           gdih(k)=dexp(kat3)
8199           kat2=kat2+gdih(k)
8200 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8201 c          write(*,*)""
8202         enddo
8203 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8204 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8205 #ifdef DEBUG
8206         write (iout,*) "i",i," betai",betai," kat2",kat2
8207         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8208 #endif
8209         if (kat2.le.1.0d-14) cycle
8210         kat=kat-dLOG(kat2/constr_homology)
8211 c       write (iout,*) "kat",kat ! sum of -ln-s
8212
8213 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8214 ccc     & dLOG(kat2), "-kat=", -kat
8215
8216 c ----------------------------------------------------------------------
8217 c Gradient
8218 c ----------------------------------------------------------------------
8219
8220         sum_gdih=kat2
8221         sum_sgdih=0.0d0
8222         do k=1,constr_homology
8223 #ifdef OLD_DIHED
8224           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8225 #else
8226           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8227 #endif
8228 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8229           sum_sgdih=sum_sgdih+sgdih
8230         enddo
8231 c       grad_dih3=sum_sgdih/sum_gdih
8232         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8233
8234 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8235 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8236 ccc     & gloc(nphi+i-3,icg)
8237         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8238 c        if (i.eq.25) then
8239 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8240 c        endif
8241 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8242 ccc     & gloc(nphi+i-3,icg)
8243
8244       enddo ! i-loop for dih
8245 #ifdef DEBUG
8246       write(iout,*) "------- dih restrs end -------"
8247 #endif
8248
8249 c Pseudo-energy and gradient for theta angle restraints from
8250 c homology templates
8251 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8252 c adapted
8253
8254 c
8255 c     For constr_homology reference structures (FP)
8256 c
8257 c     Uconst_back_tot=0.0d0
8258       Eval=0.0d0
8259       Erot=0.0d0
8260 c     Econstr_back legacy
8261       do i=1,nres
8262 c     do i=ithet_start,ithet_end
8263        dutheta(i)=0.0d0
8264 c     enddo
8265 c     do i=loc_start,loc_end
8266         do j=1,3
8267           duscdiff(j,i)=0.0d0
8268           duscdiffx(j,i)=0.0d0
8269         enddo
8270       enddo
8271 c
8272 c     do iref=1,nref
8273 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8274 c     write (iout,*) "waga_theta",waga_theta
8275       if (waga_theta.gt.0.0d0) then
8276 #ifdef DEBUG
8277       write (iout,*) "usampl",usampl
8278       write(iout,*) "------- theta restrs start -------"
8279 c     do i=ithet_start,ithet_end
8280 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8281 c     enddo
8282 #endif
8283 c     write (iout,*) "maxres",maxres,"nres",nres
8284
8285       do i=ithet_start,ithet_end
8286 c
8287 c     do i=1,nfrag_back
8288 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8289 c
8290 c Deviation of theta angles wrt constr_homology ref structures
8291 c
8292         utheta_i=0.0d0 ! argument of Gaussian for single k
8293         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8294 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8295 c       over residues in a fragment
8296 c       write (iout,*) "theta(",i,")=",theta(i)
8297         do k=1,constr_homology
8298 c
8299 c         dtheta_i=theta(j)-thetaref(j,iref)
8300 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8301           theta_diff(k)=thetatpl(k,i)-theta(i)
8302 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8303 cd     &                  ,sigma_theta(k,i)
8304
8305 c
8306           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8307 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8308           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8309           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8310 c         Gradient for single Gaussian restraint in subr Econstr_back
8311 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8312 c
8313         enddo
8314 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8315 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8316
8317 c
8318 c         Gradient for multiple Gaussian restraint
8319         sum_gtheta=gutheta_i
8320         sum_sgtheta=0.0d0
8321         do k=1,constr_homology
8322 c        New generalized expr for multiple Gaussian from Econstr_back
8323          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8324 c
8325 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8326           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8327         enddo
8328 c       Final value of gradient using same var as in Econstr_back
8329         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8330      &      +sum_sgtheta/sum_gtheta*waga_theta
8331      &               *waga_homology(iset)
8332 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8333 c     &               *waga_homology(iset)
8334 c       dutheta(i)=sum_sgtheta/sum_gtheta
8335 c
8336 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8337         Eval=Eval-dLOG(gutheta_i/constr_homology)
8338 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8339 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8340 c       Uconst_back=Uconst_back+utheta(i)
8341       enddo ! (i-loop for theta)
8342 #ifdef DEBUG
8343       write(iout,*) "------- theta restrs end -------"
8344 #endif
8345       endif
8346 c
8347 c Deviation of local SC geometry
8348 c
8349 c Separation of two i-loops (instructed by AL - 11/3/2014)
8350 c
8351 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8352 c     write (iout,*) "waga_d",waga_d
8353
8354 #ifdef DEBUG
8355       write(iout,*) "------- SC restrs start -------"
8356       write (iout,*) "Initial duscdiff,duscdiffx"
8357       do i=loc_start,loc_end
8358         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8359      &                 (duscdiffx(jik,i),jik=1,3)
8360       enddo
8361 #endif
8362       do i=loc_start,loc_end
8363         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8364         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8365 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8366 c       write(iout,*) "xxtab, yytab, zztab"
8367 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8368         do k=1,constr_homology
8369 c
8370           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8371 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8372           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8373           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8374 c         write(iout,*) "dxx, dyy, dzz"
8375 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8376 c
8377           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8378 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8379 c         uscdiffk(k)=usc_diff(i)
8380           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8381 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8382 c     &       " guscdiff2",guscdiff2(k)
8383           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8384 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8385 c     &      xxref(j),yyref(j),zzref(j)
8386         enddo
8387 c
8388 c       Gradient
8389 c
8390 c       Generalized expression for multiple Gaussian acc to that for a single
8391 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8392 c
8393 c       Original implementation
8394 c       sum_guscdiff=guscdiff(i)
8395 c
8396 c       sum_sguscdiff=0.0d0
8397 c       do k=1,constr_homology
8398 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8399 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8400 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8401 c       enddo
8402 c
8403 c       Implementation of new expressions for gradient (Jan. 2015)
8404 c
8405 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8406         do k=1,constr_homology
8407 c
8408 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8409 c       before. Now the drivatives should be correct
8410 c
8411           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8412 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8413           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8414           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8415 c
8416 c         New implementation
8417 c
8418           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8419      &                 sigma_d(k,i) ! for the grad wrt r'
8420 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8421 c
8422 c
8423 c        New implementation
8424          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8425          do jik=1,3
8426             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8427      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8428      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8429             duscdiff(jik,i)=duscdiff(jik,i)+
8430      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8431      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8432             duscdiffx(jik,i)=duscdiffx(jik,i)+
8433      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8434      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8435 c
8436 #ifdef DEBUG
8437              write(iout,*) "jik",jik,"i",i
8438              write(iout,*) "dxx, dyy, dzz"
8439              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8440              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8441 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8442 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8443 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8444 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8445 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8446 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8447 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8448 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8449 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8450 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8451 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8452 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8453 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8454 c            endif
8455 #endif
8456          enddo
8457         enddo
8458 c
8459 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8460 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8461 c
8462 c        write (iout,*) i," uscdiff",uscdiff(i)
8463 c
8464 c Put together deviations from local geometry
8465
8466 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8467 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8468         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8469 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8470 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8471 c       Uconst_back=Uconst_back+usc_diff(i)
8472 c
8473 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8474 c
8475 c     New implment: multiplied by sum_sguscdiff
8476 c
8477
8478       enddo ! (i-loop for dscdiff)
8479
8480 c      endif
8481
8482 #ifdef DEBUG
8483       write(iout,*) "------- SC restrs end -------"
8484         write (iout,*) "------ After SC loop in e_modeller ------"
8485         do i=loc_start,loc_end
8486          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8487          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8488         enddo
8489       if (waga_theta.eq.1.0d0) then
8490       write (iout,*) "in e_modeller after SC restr end: dutheta"
8491       do i=ithet_start,ithet_end
8492         write (iout,*) i,dutheta(i)
8493       enddo
8494       endif
8495       if (waga_d.eq.1.0d0) then
8496       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8497       do i=1,nres
8498         write (iout,*) i,(duscdiff(j,i),j=1,3)
8499         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8500       enddo
8501       endif
8502 #endif
8503
8504 c Total energy from homology restraints
8505 #ifdef DEBUG
8506       write (iout,*) "odleg",odleg," kat",kat
8507 #endif
8508 c
8509 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8510 c
8511 c     ehomology_constr=odleg+kat
8512 c
8513 c     For Lorentzian-type Urestr
8514 c
8515
8516       if (waga_dist.ge.0.0d0) then
8517 c
8518 c          For Gaussian-type Urestr
8519 c
8520         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8521      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8522 c     write (iout,*) "ehomology_constr=",ehomology_constr
8523       else
8524 c
8525 c          For Lorentzian-type Urestr
8526 c
8527         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8528      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8529 c     write (iout,*) "ehomology_constr=",ehomology_constr
8530       endif
8531 #ifdef DEBUG
8532       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8533      & "Eval",waga_theta,eval,
8534      &   "Erot",waga_d,Erot
8535       write (iout,*) "ehomology_constr",ehomology_constr
8536 #endif
8537       return
8538 c
8539 c FP 01/15 end
8540 c
8541   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8542   747 format(a12,i4,i4,i4,f8.3,f8.3)
8543   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8544   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8545   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8546      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8547       end
8548 c----------------------------------------------------------------------------
8549 C The rigorous attempt to derive energy function
8550       subroutine ebend_kcc(etheta)
8551
8552       implicit real*8 (a-h,o-z)
8553       include 'DIMENSIONS'
8554       include 'COMMON.VAR'
8555       include 'COMMON.GEO'
8556       include 'COMMON.LOCAL'
8557       include 'COMMON.TORSION'
8558       include 'COMMON.INTERACT'
8559       include 'COMMON.DERIV'
8560       include 'COMMON.CHAIN'
8561       include 'COMMON.NAMES'
8562       include 'COMMON.IOUNITS'
8563       include 'COMMON.FFIELD'
8564       include 'COMMON.TORCNSTR'
8565       include 'COMMON.CONTROL'
8566       logical lprn
8567       double precision thybt1(maxang_kcc)
8568 C Set lprn=.true. for debugging
8569       lprn=energy_dec
8570 c     lprn=.true.
8571 C      print *,"wchodze kcc"
8572       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8573       etheta=0.0D0
8574       do i=ithet_start,ithet_end
8575 c        print *,i,itype(i-1),itype(i),itype(i-2)
8576         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8577      &  .or.itype(i).eq.ntyp1) cycle
8578         iti=iabs(itortyp(itype(i-1)))
8579         sinthet=dsin(theta(i))
8580         costhet=dcos(theta(i))
8581         do j=1,nbend_kcc_Tb(iti)
8582           thybt1(j)=v1bend_chyb(j,iti)
8583         enddo
8584         sumth1thyb=v1bend_chyb(0,iti)+
8585      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8586         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8587      &    sumth1thyb
8588         ihelp=nbend_kcc_Tb(iti)-1
8589         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8590         etheta=etheta+sumth1thyb
8591 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8592         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8593       enddo
8594       return
8595       end
8596 c-------------------------------------------------------------------------------------
8597       subroutine etheta_constr(ethetacnstr)
8598
8599       implicit real*8 (a-h,o-z)
8600       include 'DIMENSIONS'
8601       include 'COMMON.VAR'
8602       include 'COMMON.GEO'
8603       include 'COMMON.LOCAL'
8604       include 'COMMON.TORSION'
8605       include 'COMMON.INTERACT'
8606       include 'COMMON.DERIV'
8607       include 'COMMON.CHAIN'
8608       include 'COMMON.NAMES'
8609       include 'COMMON.IOUNITS'
8610       include 'COMMON.FFIELD'
8611       include 'COMMON.TORCNSTR'
8612       include 'COMMON.CONTROL'
8613       ethetacnstr=0.0d0
8614 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8615       do i=ithetaconstr_start,ithetaconstr_end
8616         itheta=itheta_constr(i)
8617         thetiii=theta(itheta)
8618         difi=pinorm(thetiii-theta_constr0(i))
8619         if (difi.gt.theta_drange(i)) then
8620           difi=difi-theta_drange(i)
8621           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8622           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8623      &    +for_thet_constr(i)*difi**3
8624         else if (difi.lt.-drange(i)) then
8625           difi=difi+drange(i)
8626           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8627           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8628      &    +for_thet_constr(i)*difi**3
8629         else
8630           difi=0.0
8631         endif
8632        if (energy_dec) then
8633         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8634      &    i,itheta,rad2deg*thetiii,
8635      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8636      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8637      &    gloc(itheta+nphi-2,icg)
8638         endif
8639       enddo
8640       return
8641       end
8642 c------------------------------------------------------------------------------
8643       subroutine eback_sc_corr(esccor)
8644 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8645 c        conformational states; temporarily implemented as differences
8646 c        between UNRES torsional potentials (dependent on three types of
8647 c        residues) and the torsional potentials dependent on all 20 types
8648 c        of residues computed from AM1  energy surfaces of terminally-blocked
8649 c        amino-acid residues.
8650       implicit real*8 (a-h,o-z)
8651       include 'DIMENSIONS'
8652       include 'COMMON.VAR'
8653       include 'COMMON.GEO'
8654       include 'COMMON.LOCAL'
8655       include 'COMMON.TORSION'
8656       include 'COMMON.SCCOR'
8657       include 'COMMON.INTERACT'
8658       include 'COMMON.DERIV'
8659       include 'COMMON.CHAIN'
8660       include 'COMMON.NAMES'
8661       include 'COMMON.IOUNITS'
8662       include 'COMMON.FFIELD'
8663       include 'COMMON.CONTROL'
8664       logical lprn
8665 C Set lprn=.true. for debugging
8666       lprn=.false.
8667 c      lprn=.true.
8668 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8669       esccor=0.0D0
8670       do i=itau_start,itau_end
8671         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8672         esccor_ii=0.0D0
8673         isccori=isccortyp(itype(i-2))
8674         isccori1=isccortyp(itype(i-1))
8675 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8676         phii=phi(i)
8677         do intertyp=1,3 !intertyp
8678 cc Added 09 May 2012 (Adasko)
8679 cc  Intertyp means interaction type of backbone mainchain correlation:
8680 c   1 = SC...Ca...Ca...Ca
8681 c   2 = Ca...Ca...Ca...SC
8682 c   3 = SC...Ca...Ca...SCi
8683         gloci=0.0D0
8684         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8685      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8686      &      (itype(i-1).eq.ntyp1)))
8687      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8688      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8689      &     .or.(itype(i).eq.ntyp1)))
8690      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8691      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8692      &      (itype(i-3).eq.ntyp1)))) cycle
8693         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8694         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8695      & cycle
8696        do j=1,nterm_sccor(isccori,isccori1)
8697           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8698           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8699           cosphi=dcos(j*tauangle(intertyp,i))
8700           sinphi=dsin(j*tauangle(intertyp,i))
8701           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8702           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8703         enddo
8704 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8705         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8706         if (lprn)
8707      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8708      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8709      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8710      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8711         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8712        enddo !intertyp
8713       enddo
8714
8715       return
8716       end
8717 c----------------------------------------------------------------------------
8718       subroutine multibody(ecorr)
8719 C This subroutine calculates multi-body contributions to energy following
8720 C the idea of Skolnick et al. If side chains I and J make a contact and
8721 C at the same time side chains I+1 and J+1 make a contact, an extra
8722 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8723       implicit real*8 (a-h,o-z)
8724       include 'DIMENSIONS'
8725       include 'COMMON.IOUNITS'
8726       include 'COMMON.DERIV'
8727       include 'COMMON.INTERACT'
8728       include 'COMMON.CONTACTS'
8729       double precision gx(3),gx1(3)
8730       logical lprn
8731
8732 C Set lprn=.true. for debugging
8733       lprn=.false.
8734
8735       if (lprn) then
8736         write (iout,'(a)') 'Contact function values:'
8737         do i=nnt,nct-2
8738           write (iout,'(i2,20(1x,i2,f10.5))')
8739      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8740         enddo
8741       endif
8742       ecorr=0.0D0
8743       do i=nnt,nct
8744         do j=1,3
8745           gradcorr(j,i)=0.0D0
8746           gradxorr(j,i)=0.0D0
8747         enddo
8748       enddo
8749       do i=nnt,nct-2
8750
8751         DO ISHIFT = 3,4
8752
8753         i1=i+ishift
8754         num_conti=num_cont(i)
8755         num_conti1=num_cont(i1)
8756         do jj=1,num_conti
8757           j=jcont(jj,i)
8758           do kk=1,num_conti1
8759             j1=jcont(kk,i1)
8760             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8761 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8762 cd   &                   ' ishift=',ishift
8763 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8764 C The system gains extra energy.
8765               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8766             endif   ! j1==j+-ishift
8767           enddo     ! kk
8768         enddo       ! jj
8769
8770         ENDDO ! ISHIFT
8771
8772       enddo         ! i
8773       return
8774       end
8775 c------------------------------------------------------------------------------
8776       double precision function esccorr(i,j,k,l,jj,kk)
8777       implicit real*8 (a-h,o-z)
8778       include 'DIMENSIONS'
8779       include 'COMMON.IOUNITS'
8780       include 'COMMON.DERIV'
8781       include 'COMMON.INTERACT'
8782       include 'COMMON.CONTACTS'
8783       include 'COMMON.SHIELD'
8784       double precision gx(3),gx1(3)
8785       logical lprn
8786       lprn=.false.
8787       eij=facont(jj,i)
8788       ekl=facont(kk,k)
8789 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8790 C Calculate the multi-body contribution to energy.
8791 C Calculate multi-body contributions to the gradient.
8792 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8793 cd   & k,l,(gacont(m,kk,k),m=1,3)
8794       do m=1,3
8795         gx(m) =ekl*gacont(m,jj,i)
8796         gx1(m)=eij*gacont(m,kk,k)
8797         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8798         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8799         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8800         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8801       enddo
8802       do m=i,j-1
8803         do ll=1,3
8804           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8805         enddo
8806       enddo
8807       do m=k,l-1
8808         do ll=1,3
8809           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8810         enddo
8811       enddo
8812       esccorr=-eij*ekl
8813       return
8814       end
8815 c------------------------------------------------------------------------------
8816       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8817 C This subroutine calculates multi-body contributions to hydrogen-bonding
8818       implicit real*8 (a-h,o-z)
8819       include 'DIMENSIONS'
8820       include 'COMMON.IOUNITS'
8821 #ifdef MPI
8822       include "mpif.h"
8823       parameter (max_cont=maxconts)
8824       parameter (max_dim=26)
8825       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8826       double precision zapas(max_dim,maxconts,max_fg_procs),
8827      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8828       common /przechowalnia/ zapas
8829       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8830      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8831 #endif
8832       include 'COMMON.SETUP'
8833       include 'COMMON.FFIELD'
8834       include 'COMMON.DERIV'
8835       include 'COMMON.INTERACT'
8836       include 'COMMON.CONTACTS'
8837       include 'COMMON.CONTROL'
8838       include 'COMMON.LOCAL'
8839       double precision gx(3),gx1(3),time00
8840       logical lprn,ldone
8841
8842 C Set lprn=.true. for debugging
8843       lprn=.false.
8844 #ifdef MPI
8845       n_corr=0
8846       n_corr1=0
8847       if (nfgtasks.le.1) goto 30
8848       if (lprn) then
8849         write (iout,'(a)') 'Contact function values before RECEIVE:'
8850         do i=nnt,nct-2
8851           write (iout,'(2i3,50(1x,i2,f5.2))')
8852      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8853      &    j=1,num_cont_hb(i))
8854         enddo
8855         call flush(iout)
8856       endif
8857       do i=1,ntask_cont_from
8858         ncont_recv(i)=0
8859       enddo
8860       do i=1,ntask_cont_to
8861         ncont_sent(i)=0
8862       enddo
8863 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8864 c     & ntask_cont_to
8865 C Make the list of contacts to send to send to other procesors
8866 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8867 c      call flush(iout)
8868       do i=iturn3_start,iturn3_end
8869 c        write (iout,*) "make contact list turn3",i," num_cont",
8870 c     &    num_cont_hb(i)
8871         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8872       enddo
8873       do i=iturn4_start,iturn4_end
8874 c        write (iout,*) "make contact list turn4",i," num_cont",
8875 c     &   num_cont_hb(i)
8876         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8877       enddo
8878       do ii=1,nat_sent
8879         i=iat_sent(ii)
8880 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8881 c     &    num_cont_hb(i)
8882         do j=1,num_cont_hb(i)
8883         do k=1,4
8884           jjc=jcont_hb(j,i)
8885           iproc=iint_sent_local(k,jjc,ii)
8886 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8887           if (iproc.gt.0) then
8888             ncont_sent(iproc)=ncont_sent(iproc)+1
8889             nn=ncont_sent(iproc)
8890             zapas(1,nn,iproc)=i
8891             zapas(2,nn,iproc)=jjc
8892             zapas(3,nn,iproc)=facont_hb(j,i)
8893             zapas(4,nn,iproc)=ees0p(j,i)
8894             zapas(5,nn,iproc)=ees0m(j,i)
8895             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8896             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8897             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8898             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8899             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8900             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8901             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8902             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8903             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8904             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8905             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8906             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8907             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8908             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8909             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8910             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8911             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8912             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8913             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8914             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8915             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8916           endif
8917         enddo
8918         enddo
8919       enddo
8920       if (lprn) then
8921       write (iout,*)
8922      &  "Numbers of contacts to be sent to other processors",
8923      &  (ncont_sent(i),i=1,ntask_cont_to)
8924       write (iout,*) "Contacts sent"
8925       do ii=1,ntask_cont_to
8926         nn=ncont_sent(ii)
8927         iproc=itask_cont_to(ii)
8928         write (iout,*) nn," contacts to processor",iproc,
8929      &   " of CONT_TO_COMM group"
8930         do i=1,nn
8931           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8932         enddo
8933       enddo
8934       call flush(iout)
8935       endif
8936       CorrelType=477
8937       CorrelID=fg_rank+1
8938       CorrelType1=478
8939       CorrelID1=nfgtasks+fg_rank+1
8940       ireq=0
8941 C Receive the numbers of needed contacts from other processors
8942       do ii=1,ntask_cont_from
8943         iproc=itask_cont_from(ii)
8944         ireq=ireq+1
8945         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8946      &    FG_COMM,req(ireq),IERR)
8947       enddo
8948 c      write (iout,*) "IRECV ended"
8949 c      call flush(iout)
8950 C Send the number of contacts needed by other processors
8951       do ii=1,ntask_cont_to
8952         iproc=itask_cont_to(ii)
8953         ireq=ireq+1
8954         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8955      &    FG_COMM,req(ireq),IERR)
8956       enddo
8957 c      write (iout,*) "ISEND ended"
8958 c      write (iout,*) "number of requests (nn)",ireq
8959 c      call flush(iout)
8960       if (ireq.gt.0)
8961      &  call MPI_Waitall(ireq,req,status_array,ierr)
8962 c      write (iout,*)
8963 c     &  "Numbers of contacts to be received from other processors",
8964 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8965 c      call flush(iout)
8966 C Receive contacts
8967       ireq=0
8968       do ii=1,ntask_cont_from
8969         iproc=itask_cont_from(ii)
8970         nn=ncont_recv(ii)
8971 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8972 c     &   " of CONT_TO_COMM group"
8973 c        call flush(iout)
8974         if (nn.gt.0) then
8975           ireq=ireq+1
8976           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8977      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8978 c          write (iout,*) "ireq,req",ireq,req(ireq)
8979         endif
8980       enddo
8981 C Send the contacts to processors that need them
8982       do ii=1,ntask_cont_to
8983         iproc=itask_cont_to(ii)
8984         nn=ncont_sent(ii)
8985 c        write (iout,*) nn," contacts to processor",iproc,
8986 c     &   " of CONT_TO_COMM group"
8987         if (nn.gt.0) then
8988           ireq=ireq+1
8989           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8990      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8991 c          write (iout,*) "ireq,req",ireq,req(ireq)
8992 c          do i=1,nn
8993 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8994 c          enddo
8995         endif
8996       enddo
8997 c      write (iout,*) "number of requests (contacts)",ireq
8998 c      write (iout,*) "req",(req(i),i=1,4)
8999 c      call flush(iout)
9000       if (ireq.gt.0)
9001      & call MPI_Waitall(ireq,req,status_array,ierr)
9002       do iii=1,ntask_cont_from
9003         iproc=itask_cont_from(iii)
9004         nn=ncont_recv(iii)
9005         if (lprn) then
9006         write (iout,*) "Received",nn," contacts from processor",iproc,
9007      &   " of CONT_FROM_COMM group"
9008         call flush(iout)
9009         do i=1,nn
9010           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9011         enddo
9012         call flush(iout)
9013         endif
9014         do i=1,nn
9015           ii=zapas_recv(1,i,iii)
9016 c Flag the received contacts to prevent double-counting
9017           jj=-zapas_recv(2,i,iii)
9018 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9019 c          call flush(iout)
9020           nnn=num_cont_hb(ii)+1
9021           num_cont_hb(ii)=nnn
9022           jcont_hb(nnn,ii)=jj
9023           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9024           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9025           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9026           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9027           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9028           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9029           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9030           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9031           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9032           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9033           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9034           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9035           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9036           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9037           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9038           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9039           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9040           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9041           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9042           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9043           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9044           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9045           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9046           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9047         enddo
9048       enddo
9049       if (lprn) then
9050         write (iout,'(a)') 'Contact function values after receive:'
9051         do i=nnt,nct-2
9052           write (iout,'(2i3,50(1x,i3,f5.2))')
9053      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9054      &    j=1,num_cont_hb(i))
9055         enddo
9056         call flush(iout)
9057       endif
9058    30 continue
9059 #endif
9060       if (lprn) then
9061         write (iout,'(a)') 'Contact function values:'
9062         do i=nnt,nct-2
9063           write (iout,'(2i3,50(1x,i3,f5.2))')
9064      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9065      &    j=1,num_cont_hb(i))
9066         enddo
9067         call flush(iout)
9068       endif
9069       ecorr=0.0D0
9070 C Remove the loop below after debugging !!!
9071       do i=nnt,nct
9072         do j=1,3
9073           gradcorr(j,i)=0.0D0
9074           gradxorr(j,i)=0.0D0
9075         enddo
9076       enddo
9077 C Calculate the local-electrostatic correlation terms
9078       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9079         i1=i+1
9080         num_conti=num_cont_hb(i)
9081         num_conti1=num_cont_hb(i+1)
9082         do jj=1,num_conti
9083           j=jcont_hb(jj,i)
9084           jp=iabs(j)
9085           do kk=1,num_conti1
9086             j1=jcont_hb(kk,i1)
9087             jp1=iabs(j1)
9088 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9089 c     &         ' jj=',jj,' kk=',kk
9090 c            call flush(iout)
9091             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9092      &          .or. j.lt.0 .and. j1.gt.0) .and.
9093      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9094 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9095 C The system gains extra energy.
9096               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9097               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9098      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9099               n_corr=n_corr+1
9100             else if (j1.eq.j) then
9101 C Contacts I-J and I-(J+1) occur simultaneously.
9102 C The system loses extra energy.
9103 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9104             endif
9105           enddo ! kk
9106           do kk=1,num_conti
9107             j1=jcont_hb(kk,i)
9108 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9109 c    &         ' jj=',jj,' kk=',kk
9110             if (j1.eq.j+1) then
9111 C Contacts I-J and (I+1)-J occur simultaneously.
9112 C The system loses extra energy.
9113 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9114             endif ! j1==j+1
9115           enddo ! kk
9116         enddo ! jj
9117       enddo ! i
9118       return
9119       end
9120 c------------------------------------------------------------------------------
9121       subroutine add_hb_contact(ii,jj,itask)
9122       implicit real*8 (a-h,o-z)
9123       include "DIMENSIONS"
9124       include "COMMON.IOUNITS"
9125       integer max_cont
9126       integer max_dim
9127       parameter (max_cont=maxconts)
9128       parameter (max_dim=26)
9129       include "COMMON.CONTACTS"
9130       double precision zapas(max_dim,maxconts,max_fg_procs),
9131      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9132       common /przechowalnia/ zapas
9133       integer i,j,ii,jj,iproc,itask(4),nn
9134 c      write (iout,*) "itask",itask
9135       do i=1,2
9136         iproc=itask(i)
9137         if (iproc.gt.0) then
9138           do j=1,num_cont_hb(ii)
9139             jjc=jcont_hb(j,ii)
9140 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9141             if (jjc.eq.jj) then
9142               ncont_sent(iproc)=ncont_sent(iproc)+1
9143               nn=ncont_sent(iproc)
9144               zapas(1,nn,iproc)=ii
9145               zapas(2,nn,iproc)=jjc
9146               zapas(3,nn,iproc)=facont_hb(j,ii)
9147               zapas(4,nn,iproc)=ees0p(j,ii)
9148               zapas(5,nn,iproc)=ees0m(j,ii)
9149               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9150               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9151               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9152               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9153               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9154               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9155               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9156               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9157               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9158               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9159               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9160               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9161               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9162               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9163               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9164               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9165               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9166               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9167               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9168               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9169               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9170               exit
9171             endif
9172           enddo
9173         endif
9174       enddo
9175       return
9176       end
9177 c------------------------------------------------------------------------------
9178       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9179      &  n_corr1)
9180 C This subroutine calculates multi-body contributions to hydrogen-bonding
9181       implicit real*8 (a-h,o-z)
9182       include 'DIMENSIONS'
9183       include 'COMMON.IOUNITS'
9184 #ifdef MPI
9185       include "mpif.h"
9186       parameter (max_cont=maxconts)
9187       parameter (max_dim=70)
9188       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9189       double precision zapas(max_dim,maxconts,max_fg_procs),
9190      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9191       common /przechowalnia/ zapas
9192       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9193      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9194 #endif
9195       include 'COMMON.SETUP'
9196       include 'COMMON.FFIELD'
9197       include 'COMMON.DERIV'
9198       include 'COMMON.LOCAL'
9199       include 'COMMON.INTERACT'
9200       include 'COMMON.CONTACTS'
9201       include 'COMMON.CHAIN'
9202       include 'COMMON.CONTROL'
9203       include 'COMMON.SHIELD'
9204       double precision gx(3),gx1(3)
9205       integer num_cont_hb_old(maxres)
9206       logical lprn,ldone
9207       double precision eello4,eello5,eelo6,eello_turn6
9208       external eello4,eello5,eello6,eello_turn6
9209 C Set lprn=.true. for debugging
9210       lprn=.false.
9211       eturn6=0.0d0
9212 #ifdef MPI
9213       do i=1,nres
9214         num_cont_hb_old(i)=num_cont_hb(i)
9215       enddo
9216       n_corr=0
9217       n_corr1=0
9218       if (nfgtasks.le.1) goto 30
9219       if (lprn) then
9220         write (iout,'(a)') 'Contact function values before RECEIVE:'
9221         do i=nnt,nct-2
9222           write (iout,'(2i3,50(1x,i2,f5.2))')
9223      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9224      &    j=1,num_cont_hb(i))
9225         enddo
9226       endif
9227       do i=1,ntask_cont_from
9228         ncont_recv(i)=0
9229       enddo
9230       do i=1,ntask_cont_to
9231         ncont_sent(i)=0
9232       enddo
9233 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9234 c     & ntask_cont_to
9235 C Make the list of contacts to send to send to other procesors
9236       do i=iturn3_start,iturn3_end
9237 c        write (iout,*) "make contact list turn3",i," num_cont",
9238 c     &    num_cont_hb(i)
9239         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9240       enddo
9241       do i=iturn4_start,iturn4_end
9242 c        write (iout,*) "make contact list turn4",i," num_cont",
9243 c     &   num_cont_hb(i)
9244         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9245       enddo
9246       do ii=1,nat_sent
9247         i=iat_sent(ii)
9248 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9249 c     &    num_cont_hb(i)
9250         do j=1,num_cont_hb(i)
9251         do k=1,4
9252           jjc=jcont_hb(j,i)
9253           iproc=iint_sent_local(k,jjc,ii)
9254 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9255           if (iproc.ne.0) then
9256             ncont_sent(iproc)=ncont_sent(iproc)+1
9257             nn=ncont_sent(iproc)
9258             zapas(1,nn,iproc)=i
9259             zapas(2,nn,iproc)=jjc
9260             zapas(3,nn,iproc)=d_cont(j,i)
9261             ind=3
9262             do kk=1,3
9263               ind=ind+1
9264               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9265             enddo
9266             do kk=1,2
9267               do ll=1,2
9268                 ind=ind+1
9269                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9270               enddo
9271             enddo
9272             do jj=1,5
9273               do kk=1,3
9274                 do ll=1,2
9275                   do mm=1,2
9276                     ind=ind+1
9277                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9278                   enddo
9279                 enddo
9280               enddo
9281             enddo
9282           endif
9283         enddo
9284         enddo
9285       enddo
9286       if (lprn) then
9287       write (iout,*)
9288      &  "Numbers of contacts to be sent to other processors",
9289      &  (ncont_sent(i),i=1,ntask_cont_to)
9290       write (iout,*) "Contacts sent"
9291       do ii=1,ntask_cont_to
9292         nn=ncont_sent(ii)
9293         iproc=itask_cont_to(ii)
9294         write (iout,*) nn," contacts to processor",iproc,
9295      &   " of CONT_TO_COMM group"
9296         do i=1,nn
9297           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9298         enddo
9299       enddo
9300       call flush(iout)
9301       endif
9302       CorrelType=477
9303       CorrelID=fg_rank+1
9304       CorrelType1=478
9305       CorrelID1=nfgtasks+fg_rank+1
9306       ireq=0
9307 C Receive the numbers of needed contacts from other processors
9308       do ii=1,ntask_cont_from
9309         iproc=itask_cont_from(ii)
9310         ireq=ireq+1
9311         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9312      &    FG_COMM,req(ireq),IERR)
9313       enddo
9314 c      write (iout,*) "IRECV ended"
9315 c      call flush(iout)
9316 C Send the number of contacts needed by other processors
9317       do ii=1,ntask_cont_to
9318         iproc=itask_cont_to(ii)
9319         ireq=ireq+1
9320         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9321      &    FG_COMM,req(ireq),IERR)
9322       enddo
9323 c      write (iout,*) "ISEND ended"
9324 c      write (iout,*) "number of requests (nn)",ireq
9325 c      call flush(iout)
9326       if (ireq.gt.0)
9327      &  call MPI_Waitall(ireq,req,status_array,ierr)
9328 c      write (iout,*)
9329 c     &  "Numbers of contacts to be received from other processors",
9330 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9331 c      call flush(iout)
9332 C Receive contacts
9333       ireq=0
9334       do ii=1,ntask_cont_from
9335         iproc=itask_cont_from(ii)
9336         nn=ncont_recv(ii)
9337 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9338 c     &   " of CONT_TO_COMM group"
9339 c        call flush(iout)
9340         if (nn.gt.0) then
9341           ireq=ireq+1
9342           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9343      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9344 c          write (iout,*) "ireq,req",ireq,req(ireq)
9345         endif
9346       enddo
9347 C Send the contacts to processors that need them
9348       do ii=1,ntask_cont_to
9349         iproc=itask_cont_to(ii)
9350         nn=ncont_sent(ii)
9351 c        write (iout,*) nn," contacts to processor",iproc,
9352 c     &   " of CONT_TO_COMM group"
9353         if (nn.gt.0) then
9354           ireq=ireq+1
9355           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9356      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9357 c          write (iout,*) "ireq,req",ireq,req(ireq)
9358 c          do i=1,nn
9359 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9360 c          enddo
9361         endif
9362       enddo
9363 c      write (iout,*) "number of requests (contacts)",ireq
9364 c      write (iout,*) "req",(req(i),i=1,4)
9365 c      call flush(iout)
9366       if (ireq.gt.0)
9367      & call MPI_Waitall(ireq,req,status_array,ierr)
9368       do iii=1,ntask_cont_from
9369         iproc=itask_cont_from(iii)
9370         nn=ncont_recv(iii)
9371         if (lprn) then
9372         write (iout,*) "Received",nn," contacts from processor",iproc,
9373      &   " of CONT_FROM_COMM group"
9374         call flush(iout)
9375         do i=1,nn
9376           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9377         enddo
9378         call flush(iout)
9379         endif
9380         do i=1,nn
9381           ii=zapas_recv(1,i,iii)
9382 c Flag the received contacts to prevent double-counting
9383           jj=-zapas_recv(2,i,iii)
9384 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9385 c          call flush(iout)
9386           nnn=num_cont_hb(ii)+1
9387           num_cont_hb(ii)=nnn
9388           jcont_hb(nnn,ii)=jj
9389           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9390           ind=3
9391           do kk=1,3
9392             ind=ind+1
9393             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9394           enddo
9395           do kk=1,2
9396             do ll=1,2
9397               ind=ind+1
9398               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9399             enddo
9400           enddo
9401           do jj=1,5
9402             do kk=1,3
9403               do ll=1,2
9404                 do mm=1,2
9405                   ind=ind+1
9406                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9407                 enddo
9408               enddo
9409             enddo
9410           enddo
9411         enddo
9412       enddo
9413       if (lprn) then
9414         write (iout,'(a)') 'Contact function values after receive:'
9415         do i=nnt,nct-2
9416           write (iout,'(2i3,50(1x,i3,5f6.3))')
9417      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9418      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9419         enddo
9420         call flush(iout)
9421       endif
9422    30 continue
9423 #endif
9424       if (lprn) then
9425         write (iout,'(a)') 'Contact function values:'
9426         do i=nnt,nct-2
9427           write (iout,'(2i3,50(1x,i2,5f6.3))')
9428      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9429      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9430         enddo
9431       endif
9432       ecorr=0.0D0
9433       ecorr5=0.0d0
9434       ecorr6=0.0d0
9435 C Remove the loop below after debugging !!!
9436       do i=nnt,nct
9437         do j=1,3
9438           gradcorr(j,i)=0.0D0
9439           gradxorr(j,i)=0.0D0
9440         enddo
9441       enddo
9442 C Calculate the dipole-dipole interaction energies
9443       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9444       do i=iatel_s,iatel_e+1
9445         num_conti=num_cont_hb(i)
9446         do jj=1,num_conti
9447           j=jcont_hb(jj,i)
9448 #ifdef MOMENT
9449           call dipole(i,j,jj)
9450 #endif
9451         enddo
9452       enddo
9453       endif
9454 C Calculate the local-electrostatic correlation terms
9455 c                write (iout,*) "gradcorr5 in eello5 before loop"
9456 c                do iii=1,nres
9457 c                  write (iout,'(i5,3f10.5)')
9458 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9459 c                enddo
9460       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9461 c        write (iout,*) "corr loop i",i
9462         i1=i+1
9463         num_conti=num_cont_hb(i)
9464         num_conti1=num_cont_hb(i+1)
9465         do jj=1,num_conti
9466           j=jcont_hb(jj,i)
9467           jp=iabs(j)
9468           do kk=1,num_conti1
9469             j1=jcont_hb(kk,i1)
9470             jp1=iabs(j1)
9471 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9472 c     &         ' jj=',jj,' kk=',kk
9473 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9474             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9475      &          .or. j.lt.0 .and. j1.gt.0) .and.
9476      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9477 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9478 C The system gains extra energy.
9479               n_corr=n_corr+1
9480               sqd1=dsqrt(d_cont(jj,i))
9481               sqd2=dsqrt(d_cont(kk,i1))
9482               sred_geom = sqd1*sqd2
9483               IF (sred_geom.lt.cutoff_corr) THEN
9484                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9485      &            ekont,fprimcont)
9486 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9487 cd     &         ' jj=',jj,' kk=',kk
9488                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9489                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9490                 do l=1,3
9491                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9492                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9493                 enddo
9494                 n_corr1=n_corr1+1
9495 cd               write (iout,*) 'sred_geom=',sred_geom,
9496 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9497 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9498 cd               write (iout,*) "g_contij",g_contij
9499 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9500 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9501                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9502                 if (wcorr4.gt.0.0d0)
9503      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9504 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9505                   if (energy_dec.and.wcorr4.gt.0.0d0)
9506      1                 write (iout,'(a6,4i5,0pf7.3)')
9507      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9508 c                write (iout,*) "gradcorr5 before eello5"
9509 c                do iii=1,nres
9510 c                  write (iout,'(i5,3f10.5)')
9511 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9512 c                enddo
9513                 if (wcorr5.gt.0.0d0)
9514      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9515 c                write (iout,*) "gradcorr5 after eello5"
9516 c                do iii=1,nres
9517 c                  write (iout,'(i5,3f10.5)')
9518 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9519 c                enddo
9520                   if (energy_dec.and.wcorr5.gt.0.0d0)
9521      1                 write (iout,'(a6,4i5,0pf7.3)')
9522      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9523 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9524 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9525                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9526      &               .or. wturn6.eq.0.0d0))then
9527 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9528                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9529                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9530      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9531 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9532 cd     &            'ecorr6=',ecorr6
9533 cd                write (iout,'(4e15.5)') sred_geom,
9534 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9535 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9536 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9537                 else if (wturn6.gt.0.0d0
9538      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9539 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9540                   eturn6=eturn6+eello_turn6(i,jj,kk)
9541                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9542      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9543 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9544                 endif
9545               ENDIF
9546 1111          continue
9547             endif
9548           enddo ! kk
9549         enddo ! jj
9550       enddo ! i
9551       do i=1,nres
9552         num_cont_hb(i)=num_cont_hb_old(i)
9553       enddo
9554 c                write (iout,*) "gradcorr5 in eello5"
9555 c                do iii=1,nres
9556 c                  write (iout,'(i5,3f10.5)')
9557 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9558 c                enddo
9559       return
9560       end
9561 c------------------------------------------------------------------------------
9562       subroutine add_hb_contact_eello(ii,jj,itask)
9563       implicit real*8 (a-h,o-z)
9564       include "DIMENSIONS"
9565       include "COMMON.IOUNITS"
9566       integer max_cont
9567       integer max_dim
9568       parameter (max_cont=maxconts)
9569       parameter (max_dim=70)
9570       include "COMMON.CONTACTS"
9571       double precision zapas(max_dim,maxconts,max_fg_procs),
9572      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9573       common /przechowalnia/ zapas
9574       integer i,j,ii,jj,iproc,itask(4),nn
9575 c      write (iout,*) "itask",itask
9576       do i=1,2
9577         iproc=itask(i)
9578         if (iproc.gt.0) then
9579           do j=1,num_cont_hb(ii)
9580             jjc=jcont_hb(j,ii)
9581 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9582             if (jjc.eq.jj) then
9583               ncont_sent(iproc)=ncont_sent(iproc)+1
9584               nn=ncont_sent(iproc)
9585               zapas(1,nn,iproc)=ii
9586               zapas(2,nn,iproc)=jjc
9587               zapas(3,nn,iproc)=d_cont(j,ii)
9588               ind=3
9589               do kk=1,3
9590                 ind=ind+1
9591                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9592               enddo
9593               do kk=1,2
9594                 do ll=1,2
9595                   ind=ind+1
9596                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9597                 enddo
9598               enddo
9599               do jj=1,5
9600                 do kk=1,3
9601                   do ll=1,2
9602                     do mm=1,2
9603                       ind=ind+1
9604                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9605                     enddo
9606                   enddo
9607                 enddo
9608               enddo
9609               exit
9610             endif
9611           enddo
9612         endif
9613       enddo
9614       return
9615       end
9616 c------------------------------------------------------------------------------
9617       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9618       implicit real*8 (a-h,o-z)
9619       include 'DIMENSIONS'
9620       include 'COMMON.IOUNITS'
9621       include 'COMMON.DERIV'
9622       include 'COMMON.INTERACT'
9623       include 'COMMON.CONTACTS'
9624       include 'COMMON.SHIELD'
9625       include 'COMMON.CONTROL'
9626       double precision gx(3),gx1(3)
9627       logical lprn
9628       lprn=.false.
9629 C      print *,"wchodze",fac_shield(i),shield_mode
9630       eij=facont_hb(jj,i)
9631       ekl=facont_hb(kk,k)
9632       ees0pij=ees0p(jj,i)
9633       ees0pkl=ees0p(kk,k)
9634       ees0mij=ees0m(jj,i)
9635       ees0mkl=ees0m(kk,k)
9636       ekont=eij*ekl
9637       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9638 C*
9639 C     & fac_shield(i)**2*fac_shield(j)**2
9640 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9641 C Following 4 lines for diagnostics.
9642 cd    ees0pkl=0.0D0
9643 cd    ees0pij=1.0D0
9644 cd    ees0mkl=0.0D0
9645 cd    ees0mij=1.0D0
9646 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9647 c     & 'Contacts ',i,j,
9648 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9649 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9650 c     & 'gradcorr_long'
9651 C Calculate the multi-body contribution to energy.
9652 C      ecorr=ecorr+ekont*ees
9653 C Calculate multi-body contributions to the gradient.
9654       coeffpees0pij=coeffp*ees0pij
9655       coeffmees0mij=coeffm*ees0mij
9656       coeffpees0pkl=coeffp*ees0pkl
9657       coeffmees0mkl=coeffm*ees0mkl
9658       do ll=1,3
9659 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9660         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9661      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9662      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9663         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9664      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9665      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9666 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9667         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9668      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9669      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9670         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9671      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9672      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9673         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9674      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9675      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9676         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9677         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9678         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9679      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9680      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9681         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9682         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9683 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9684       enddo
9685 c      write (iout,*)
9686 cgrad      do m=i+1,j-1
9687 cgrad        do ll=1,3
9688 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9689 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9690 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9691 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9692 cgrad        enddo
9693 cgrad      enddo
9694 cgrad      do m=k+1,l-1
9695 cgrad        do ll=1,3
9696 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9697 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9698 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9699 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9700 cgrad        enddo
9701 cgrad      enddo
9702 c      write (iout,*) "ehbcorr",ekont*ees
9703 C      print *,ekont,ees,i,k
9704       ehbcorr=ekont*ees
9705 C now gradient over shielding
9706 C      return
9707       if (shield_mode.gt.0) then
9708        j=ees0plist(jj,i)
9709        l=ees0plist(kk,k)
9710 C        print *,i,j,fac_shield(i),fac_shield(j),
9711 C     &fac_shield(k),fac_shield(l)
9712         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9713      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9714           do ilist=1,ishield_list(i)
9715            iresshield=shield_list(ilist,i)
9716            do m=1,3
9717            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9718 C     &      *2.0
9719            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9720      &              rlocshield
9721      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9722             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9723      &+rlocshield
9724            enddo
9725           enddo
9726           do ilist=1,ishield_list(j)
9727            iresshield=shield_list(ilist,j)
9728            do m=1,3
9729            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9730 C     &     *2.0
9731            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9732      &              rlocshield
9733      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9734            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9735      &     +rlocshield
9736            enddo
9737           enddo
9738
9739           do ilist=1,ishield_list(k)
9740            iresshield=shield_list(ilist,k)
9741            do m=1,3
9742            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9743 C     &     *2.0
9744            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9745      &              rlocshield
9746      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9747            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9748      &     +rlocshield
9749            enddo
9750           enddo
9751           do ilist=1,ishield_list(l)
9752            iresshield=shield_list(ilist,l)
9753            do m=1,3
9754            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9755 C     &     *2.0
9756            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9757      &              rlocshield
9758      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9759            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9760      &     +rlocshield
9761            enddo
9762           enddo
9763 C          print *,gshieldx(m,iresshield)
9764           do m=1,3
9765             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9766      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9767             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9768      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9769             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9770      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9771             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9772      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9773
9774             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9775      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9776             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9777      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9778             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9779      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9780             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9781      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9782
9783            enddo
9784       endif
9785       endif
9786       return
9787       end
9788 #ifdef MOMENT
9789 C---------------------------------------------------------------------------
9790       subroutine dipole(i,j,jj)
9791       implicit real*8 (a-h,o-z)
9792       include 'DIMENSIONS'
9793       include 'COMMON.IOUNITS'
9794       include 'COMMON.CHAIN'
9795       include 'COMMON.FFIELD'
9796       include 'COMMON.DERIV'
9797       include 'COMMON.INTERACT'
9798       include 'COMMON.CONTACTS'
9799       include 'COMMON.TORSION'
9800       include 'COMMON.VAR'
9801       include 'COMMON.GEO'
9802       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9803      &  auxmat(2,2)
9804       iti1 = itortyp(itype(i+1))
9805       if (j.lt.nres-1) then
9806         itj1 = itype2loc(itype(j+1))
9807       else
9808         itj1=nloctyp
9809       endif
9810       do iii=1,2
9811         dipi(iii,1)=Ub2(iii,i)
9812         dipderi(iii)=Ub2der(iii,i)
9813         dipi(iii,2)=b1(iii,i+1)
9814         dipj(iii,1)=Ub2(iii,j)
9815         dipderj(iii)=Ub2der(iii,j)
9816         dipj(iii,2)=b1(iii,j+1)
9817       enddo
9818       kkk=0
9819       do iii=1,2
9820         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9821         do jjj=1,2
9822           kkk=kkk+1
9823           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9824         enddo
9825       enddo
9826       do kkk=1,5
9827         do lll=1,3
9828           mmm=0
9829           do iii=1,2
9830             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9831      &        auxvec(1))
9832             do jjj=1,2
9833               mmm=mmm+1
9834               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9835             enddo
9836           enddo
9837         enddo
9838       enddo
9839       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9840       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9841       do iii=1,2
9842         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9843       enddo
9844       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9845       do iii=1,2
9846         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9847       enddo
9848       return
9849       end
9850 #endif
9851 C---------------------------------------------------------------------------
9852       subroutine calc_eello(i,j,k,l,jj,kk)
9853 C
9854 C This subroutine computes matrices and vectors needed to calculate
9855 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9856 C
9857       implicit real*8 (a-h,o-z)
9858       include 'DIMENSIONS'
9859       include 'COMMON.IOUNITS'
9860       include 'COMMON.CHAIN'
9861       include 'COMMON.DERIV'
9862       include 'COMMON.INTERACT'
9863       include 'COMMON.CONTACTS'
9864       include 'COMMON.TORSION'
9865       include 'COMMON.VAR'
9866       include 'COMMON.GEO'
9867       include 'COMMON.FFIELD'
9868       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9869      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9870       logical lprn
9871       common /kutas/ lprn
9872 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9873 cd     & ' jj=',jj,' kk=',kk
9874 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9875 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9876 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9877       do iii=1,2
9878         do jjj=1,2
9879           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9880           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9881         enddo
9882       enddo
9883       call transpose2(aa1(1,1),aa1t(1,1))
9884       call transpose2(aa2(1,1),aa2t(1,1))
9885       do kkk=1,5
9886         do lll=1,3
9887           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9888      &      aa1tder(1,1,lll,kkk))
9889           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9890      &      aa2tder(1,1,lll,kkk))
9891         enddo
9892       enddo
9893       if (l.eq.j+1) then
9894 C parallel orientation of the two CA-CA-CA frames.
9895         if (i.gt.1) then
9896           iti=itype2loc(itype(i))
9897         else
9898           iti=nloctyp
9899         endif
9900         itk1=itype2loc(itype(k+1))
9901         itj=itype2loc(itype(j))
9902         if (l.lt.nres-1) then
9903           itl1=itype2loc(itype(l+1))
9904         else
9905           itl1=nloctyp
9906         endif
9907 C A1 kernel(j+1) A2T
9908 cd        do iii=1,2
9909 cd          write (iout,'(3f10.5,5x,3f10.5)')
9910 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9911 cd        enddo
9912         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9913      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9914      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9915 C Following matrices are needed only for 6-th order cumulants
9916         IF (wcorr6.gt.0.0d0) THEN
9917         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9918      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9919      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9921      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9922      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9923      &   ADtEAderx(1,1,1,1,1,1))
9924         lprn=.false.
9925         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9926      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9927      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9928      &   ADtEA1derx(1,1,1,1,1,1))
9929         ENDIF
9930 C End 6-th order cumulants
9931 cd        lprn=.false.
9932 cd        if (lprn) then
9933 cd        write (2,*) 'In calc_eello6'
9934 cd        do iii=1,2
9935 cd          write (2,*) 'iii=',iii
9936 cd          do kkk=1,5
9937 cd            write (2,*) 'kkk=',kkk
9938 cd            do jjj=1,2
9939 cd              write (2,'(3(2f10.5),5x)')
9940 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9941 cd            enddo
9942 cd          enddo
9943 cd        enddo
9944 cd        endif
9945         call transpose2(EUgder(1,1,k),auxmat(1,1))
9946         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9947         call transpose2(EUg(1,1,k),auxmat(1,1))
9948         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9949         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9950 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9951 c    in theta; to be sriten later.
9952 c#ifdef NEWCORR
9953 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9954 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9955 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9956 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9957 c#endif
9958         do iii=1,2
9959           do kkk=1,5
9960             do lll=1,3
9961               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9962      &          EAEAderx(1,1,lll,kkk,iii,1))
9963             enddo
9964           enddo
9965         enddo
9966 C A1T kernel(i+1) A2
9967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9968      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9969      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9970 C Following matrices are needed only for 6-th order cumulants
9971         IF (wcorr6.gt.0.0d0) THEN
9972         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9973      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9974      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9975         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9976      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9977      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9978      &   ADtEAderx(1,1,1,1,1,2))
9979         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9980      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9981      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9982      &   ADtEA1derx(1,1,1,1,1,2))
9983         ENDIF
9984 C End 6-th order cumulants
9985         call transpose2(EUgder(1,1,l),auxmat(1,1))
9986         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9987         call transpose2(EUg(1,1,l),auxmat(1,1))
9988         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9989         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9990         do iii=1,2
9991           do kkk=1,5
9992             do lll=1,3
9993               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9994      &          EAEAderx(1,1,lll,kkk,iii,2))
9995             enddo
9996           enddo
9997         enddo
9998 C AEAb1 and AEAb2
9999 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10000 C They are needed only when the fifth- or the sixth-order cumulants are
10001 C indluded.
10002         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10003         call transpose2(AEA(1,1,1),auxmat(1,1))
10004         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10005         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10006         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10007         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10008         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10009         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10010         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10011         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10012         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10013         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10014         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10015         call transpose2(AEA(1,1,2),auxmat(1,1))
10016         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10017         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10018         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10019         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10020         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10021         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10022         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10023         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10024         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10025         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10026         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10027 C Calculate the Cartesian derivatives of the vectors.
10028         do iii=1,2
10029           do kkk=1,5
10030             do lll=1,3
10031               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10032               call matvec2(auxmat(1,1),b1(1,i),
10033      &          AEAb1derx(1,lll,kkk,iii,1,1))
10034               call matvec2(auxmat(1,1),Ub2(1,i),
10035      &          AEAb2derx(1,lll,kkk,iii,1,1))
10036               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10037      &          AEAb1derx(1,lll,kkk,iii,2,1))
10038               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10039      &          AEAb2derx(1,lll,kkk,iii,2,1))
10040               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10041               call matvec2(auxmat(1,1),b1(1,j),
10042      &          AEAb1derx(1,lll,kkk,iii,1,2))
10043               call matvec2(auxmat(1,1),Ub2(1,j),
10044      &          AEAb2derx(1,lll,kkk,iii,1,2))
10045               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10046      &          AEAb1derx(1,lll,kkk,iii,2,2))
10047               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10048      &          AEAb2derx(1,lll,kkk,iii,2,2))
10049             enddo
10050           enddo
10051         enddo
10052         ENDIF
10053 C End vectors
10054       else
10055 C Antiparallel orientation of the two CA-CA-CA frames.
10056         if (i.gt.1) then
10057           iti=itype2loc(itype(i))
10058         else
10059           iti=nloctyp
10060         endif
10061         itk1=itype2loc(itype(k+1))
10062         itl=itype2loc(itype(l))
10063         itj=itype2loc(itype(j))
10064         if (j.lt.nres-1) then
10065           itj1=itype2loc(itype(j+1))
10066         else
10067           itj1=nloctyp
10068         endif
10069 C A2 kernel(j-1)T A1T
10070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10071      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10072      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10073 C Following matrices are needed only for 6-th order cumulants
10074         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10075      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10077      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10078      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10079         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10080      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10081      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10082      &   ADtEAderx(1,1,1,1,1,1))
10083         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10084      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10085      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10086      &   ADtEA1derx(1,1,1,1,1,1))
10087         ENDIF
10088 C End 6-th order cumulants
10089         call transpose2(EUgder(1,1,k),auxmat(1,1))
10090         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10091         call transpose2(EUg(1,1,k),auxmat(1,1))
10092         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10093         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10094         do iii=1,2
10095           do kkk=1,5
10096             do lll=1,3
10097               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10098      &          EAEAderx(1,1,lll,kkk,iii,1))
10099             enddo
10100           enddo
10101         enddo
10102 C A2T kernel(i+1)T A1
10103         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10104      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10105      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10106 C Following matrices are needed only for 6-th order cumulants
10107         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10108      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10109         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10110      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10111      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10112         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10113      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10114      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10115      &   ADtEAderx(1,1,1,1,1,2))
10116         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10117      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10118      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10119      &   ADtEA1derx(1,1,1,1,1,2))
10120         ENDIF
10121 C End 6-th order cumulants
10122         call transpose2(EUgder(1,1,j),auxmat(1,1))
10123         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10124         call transpose2(EUg(1,1,j),auxmat(1,1))
10125         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10126         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10127         do iii=1,2
10128           do kkk=1,5
10129             do lll=1,3
10130               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10131      &          EAEAderx(1,1,lll,kkk,iii,2))
10132             enddo
10133           enddo
10134         enddo
10135 C AEAb1 and AEAb2
10136 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10137 C They are needed only when the fifth- or the sixth-order cumulants are
10138 C indluded.
10139         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10140      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10141         call transpose2(AEA(1,1,1),auxmat(1,1))
10142         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10144         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10145         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10146         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10147         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10148         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10149         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10150         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10151         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10152         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10153         call transpose2(AEA(1,1,2),auxmat(1,1))
10154         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10155         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10156         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10157         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10158         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10159         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10160         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10161         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10162         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10163         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10164         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10165 C Calculate the Cartesian derivatives of the vectors.
10166         do iii=1,2
10167           do kkk=1,5
10168             do lll=1,3
10169               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10170               call matvec2(auxmat(1,1),b1(1,i),
10171      &          AEAb1derx(1,lll,kkk,iii,1,1))
10172               call matvec2(auxmat(1,1),Ub2(1,i),
10173      &          AEAb2derx(1,lll,kkk,iii,1,1))
10174               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10175      &          AEAb1derx(1,lll,kkk,iii,2,1))
10176               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10177      &          AEAb2derx(1,lll,kkk,iii,2,1))
10178               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10179               call matvec2(auxmat(1,1),b1(1,l),
10180      &          AEAb1derx(1,lll,kkk,iii,1,2))
10181               call matvec2(auxmat(1,1),Ub2(1,l),
10182      &          AEAb2derx(1,lll,kkk,iii,1,2))
10183               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10184      &          AEAb1derx(1,lll,kkk,iii,2,2))
10185               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10186      &          AEAb2derx(1,lll,kkk,iii,2,2))
10187             enddo
10188           enddo
10189         enddo
10190         ENDIF
10191 C End vectors
10192       endif
10193       return
10194       end
10195 C---------------------------------------------------------------------------
10196       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10197      &  KK,KKderg,AKA,AKAderg,AKAderx)
10198       implicit none
10199       integer nderg
10200       logical transp
10201       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10202      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10203      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10204       integer iii,kkk,lll
10205       integer jjj,mmm
10206       logical lprn
10207       common /kutas/ lprn
10208       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10209       do iii=1,nderg
10210         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10211      &    AKAderg(1,1,iii))
10212       enddo
10213 cd      if (lprn) write (2,*) 'In kernel'
10214       do kkk=1,5
10215 cd        if (lprn) write (2,*) 'kkk=',kkk
10216         do lll=1,3
10217           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10218      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10219 cd          if (lprn) then
10220 cd            write (2,*) 'lll=',lll
10221 cd            write (2,*) 'iii=1'
10222 cd            do jjj=1,2
10223 cd              write (2,'(3(2f10.5),5x)')
10224 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10225 cd            enddo
10226 cd          endif
10227           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10228      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10229 cd          if (lprn) then
10230 cd            write (2,*) 'lll=',lll
10231 cd            write (2,*) 'iii=2'
10232 cd            do jjj=1,2
10233 cd              write (2,'(3(2f10.5),5x)')
10234 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10235 cd            enddo
10236 cd          endif
10237         enddo
10238       enddo
10239       return
10240       end
10241 C---------------------------------------------------------------------------
10242       double precision function eello4(i,j,k,l,jj,kk)
10243       implicit real*8 (a-h,o-z)
10244       include 'DIMENSIONS'
10245       include 'COMMON.IOUNITS'
10246       include 'COMMON.CHAIN'
10247       include 'COMMON.DERIV'
10248       include 'COMMON.INTERACT'
10249       include 'COMMON.CONTACTS'
10250       include 'COMMON.TORSION'
10251       include 'COMMON.VAR'
10252       include 'COMMON.GEO'
10253       double precision pizda(2,2),ggg1(3),ggg2(3)
10254 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10255 cd        eello4=0.0d0
10256 cd        return
10257 cd      endif
10258 cd      print *,'eello4:',i,j,k,l,jj,kk
10259 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10260 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10261 cold      eij=facont_hb(jj,i)
10262 cold      ekl=facont_hb(kk,k)
10263 cold      ekont=eij*ekl
10264       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10265 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10266       gcorr_loc(k-1)=gcorr_loc(k-1)
10267      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10268       if (l.eq.j+1) then
10269         gcorr_loc(l-1)=gcorr_loc(l-1)
10270      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10271 C Al 4/16/16: Derivatives in theta, to be added later.
10272 c#ifdef NEWCORR
10273 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10274 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10275 c#endif
10276       else
10277         gcorr_loc(j-1)=gcorr_loc(j-1)
10278      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10279 c#ifdef NEWCORR
10280 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10281 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10282 c#endif
10283       endif
10284       do iii=1,2
10285         do kkk=1,5
10286           do lll=1,3
10287             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10288      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10289 cd            derx(lll,kkk,iii)=0.0d0
10290           enddo
10291         enddo
10292       enddo
10293 cd      gcorr_loc(l-1)=0.0d0
10294 cd      gcorr_loc(j-1)=0.0d0
10295 cd      gcorr_loc(k-1)=0.0d0
10296 cd      eel4=1.0d0
10297 cd      write (iout,*)'Contacts have occurred for peptide groups',
10298 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10299 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10300       if (j.lt.nres-1) then
10301         j1=j+1
10302         j2=j-1
10303       else
10304         j1=j-1
10305         j2=j-2
10306       endif
10307       if (l.lt.nres-1) then
10308         l1=l+1
10309         l2=l-1
10310       else
10311         l1=l-1
10312         l2=l-2
10313       endif
10314       do ll=1,3
10315 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10316 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10317         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10318         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10319 cgrad        ghalf=0.5d0*ggg1(ll)
10320         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10321         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10322         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10323         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10324         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10325         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10326 cgrad        ghalf=0.5d0*ggg2(ll)
10327         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10328         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10329         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10330         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10331         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10332         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10333       enddo
10334 cgrad      do m=i+1,j-1
10335 cgrad        do ll=1,3
10336 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10337 cgrad        enddo
10338 cgrad      enddo
10339 cgrad      do m=k+1,l-1
10340 cgrad        do ll=1,3
10341 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10342 cgrad        enddo
10343 cgrad      enddo
10344 cgrad      do m=i+2,j2
10345 cgrad        do ll=1,3
10346 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10347 cgrad        enddo
10348 cgrad      enddo
10349 cgrad      do m=k+2,l2
10350 cgrad        do ll=1,3
10351 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10352 cgrad        enddo
10353 cgrad      enddo
10354 cd      do iii=1,nres-3
10355 cd        write (2,*) iii,gcorr_loc(iii)
10356 cd      enddo
10357       eello4=ekont*eel4
10358 cd      write (2,*) 'ekont',ekont
10359 cd      write (iout,*) 'eello4',ekont*eel4
10360       return
10361       end
10362 C---------------------------------------------------------------------------
10363       double precision function eello5(i,j,k,l,jj,kk)
10364       implicit real*8 (a-h,o-z)
10365       include 'DIMENSIONS'
10366       include 'COMMON.IOUNITS'
10367       include 'COMMON.CHAIN'
10368       include 'COMMON.DERIV'
10369       include 'COMMON.INTERACT'
10370       include 'COMMON.CONTACTS'
10371       include 'COMMON.TORSION'
10372       include 'COMMON.VAR'
10373       include 'COMMON.GEO'
10374       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10375       double precision ggg1(3),ggg2(3)
10376 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10377 C                                                                              C
10378 C                            Parallel chains                                   C
10379 C                                                                              C
10380 C          o             o                   o             o                   C
10381 C         /l\           / \             \   / \           / \   /              C
10382 C        /   \         /   \             \ /   \         /   \ /               C
10383 C       j| o |l1       | o |              o| o |         | o |o                C
10384 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10385 C      \i/   \         /   \ /             /   \         /   \                 C
10386 C       o    k1             o                                                  C
10387 C         (I)          (II)                (III)          (IV)                 C
10388 C                                                                              C
10389 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10390 C                                                                              C
10391 C                            Antiparallel chains                               C
10392 C                                                                              C
10393 C          o             o                   o             o                   C
10394 C         /j\           / \             \   / \           / \   /              C
10395 C        /   \         /   \             \ /   \         /   \ /               C
10396 C      j1| o |l        | o |              o| o |         | o |o                C
10397 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10398 C      \i/   \         /   \ /             /   \         /   \                 C
10399 C       o     k1            o                                                  C
10400 C         (I)          (II)                (III)          (IV)                 C
10401 C                                                                              C
10402 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10403 C                                                                              C
10404 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10405 C                                                                              C
10406 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10407 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10408 cd        eello5=0.0d0
10409 cd        return
10410 cd      endif
10411 cd      write (iout,*)
10412 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10413 cd     &   ' and',k,l
10414       itk=itype2loc(itype(k))
10415       itl=itype2loc(itype(l))
10416       itj=itype2loc(itype(j))
10417       eello5_1=0.0d0
10418       eello5_2=0.0d0
10419       eello5_3=0.0d0
10420       eello5_4=0.0d0
10421 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10422 cd     &   eel5_3_num,eel5_4_num)
10423       do iii=1,2
10424         do kkk=1,5
10425           do lll=1,3
10426             derx(lll,kkk,iii)=0.0d0
10427           enddo
10428         enddo
10429       enddo
10430 cd      eij=facont_hb(jj,i)
10431 cd      ekl=facont_hb(kk,k)
10432 cd      ekont=eij*ekl
10433 cd      write (iout,*)'Contacts have occurred for peptide groups',
10434 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10435 cd      goto 1111
10436 C Contribution from the graph I.
10437 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10438 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10439       call transpose2(EUg(1,1,k),auxmat(1,1))
10440       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10441       vv(1)=pizda(1,1)-pizda(2,2)
10442       vv(2)=pizda(1,2)+pizda(2,1)
10443       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10444      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10445 C Explicit gradient in virtual-dihedral angles.
10446       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10447      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10448      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10449       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10450       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10451       vv(1)=pizda(1,1)-pizda(2,2)
10452       vv(2)=pizda(1,2)+pizda(2,1)
10453       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10454      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10455      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10456       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10457       vv(1)=pizda(1,1)-pizda(2,2)
10458       vv(2)=pizda(1,2)+pizda(2,1)
10459       if (l.eq.j+1) then
10460         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10461      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10462      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10463       else
10464         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10465      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10466      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10467       endif
10468 C Cartesian gradient
10469       do iii=1,2
10470         do kkk=1,5
10471           do lll=1,3
10472             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10473      &        pizda(1,1))
10474             vv(1)=pizda(1,1)-pizda(2,2)
10475             vv(2)=pizda(1,2)+pizda(2,1)
10476             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10477      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10478      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10479           enddo
10480         enddo
10481       enddo
10482 c      goto 1112
10483 c1111  continue
10484 C Contribution from graph II
10485       call transpose2(EE(1,1,k),auxmat(1,1))
10486       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10487       vv(1)=pizda(1,1)+pizda(2,2)
10488       vv(2)=pizda(2,1)-pizda(1,2)
10489       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10490      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10491 C Explicit gradient in virtual-dihedral angles.
10492       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10493      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10494       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10495       vv(1)=pizda(1,1)+pizda(2,2)
10496       vv(2)=pizda(2,1)-pizda(1,2)
10497       if (l.eq.j+1) then
10498         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10499      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10500      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10501       else
10502         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10503      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10504      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10505       endif
10506 C Cartesian gradient
10507       do iii=1,2
10508         do kkk=1,5
10509           do lll=1,3
10510             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10511      &        pizda(1,1))
10512             vv(1)=pizda(1,1)+pizda(2,2)
10513             vv(2)=pizda(2,1)-pizda(1,2)
10514             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10515      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10516      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10517           enddo
10518         enddo
10519       enddo
10520 cd      goto 1112
10521 cd1111  continue
10522       if (l.eq.j+1) then
10523 cd        goto 1110
10524 C Parallel orientation
10525 C Contribution from graph III
10526         call transpose2(EUg(1,1,l),auxmat(1,1))
10527         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10528         vv(1)=pizda(1,1)-pizda(2,2)
10529         vv(2)=pizda(1,2)+pizda(2,1)
10530         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10531      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10532 C Explicit gradient in virtual-dihedral angles.
10533         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10534      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10535      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10536         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10537         vv(1)=pizda(1,1)-pizda(2,2)
10538         vv(2)=pizda(1,2)+pizda(2,1)
10539         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10540      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10541      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10542         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10543         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10544         vv(1)=pizda(1,1)-pizda(2,2)
10545         vv(2)=pizda(1,2)+pizda(2,1)
10546         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10547      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10548      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10549 C Cartesian gradient
10550         do iii=1,2
10551           do kkk=1,5
10552             do lll=1,3
10553               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10554      &          pizda(1,1))
10555               vv(1)=pizda(1,1)-pizda(2,2)
10556               vv(2)=pizda(1,2)+pizda(2,1)
10557               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10558      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10559      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10560             enddo
10561           enddo
10562         enddo
10563 cd        goto 1112
10564 C Contribution from graph IV
10565 cd1110    continue
10566         call transpose2(EE(1,1,l),auxmat(1,1))
10567         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10568         vv(1)=pizda(1,1)+pizda(2,2)
10569         vv(2)=pizda(2,1)-pizda(1,2)
10570         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10571      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10572 C Explicit gradient in virtual-dihedral angles.
10573         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10574      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10575         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10576         vv(1)=pizda(1,1)+pizda(2,2)
10577         vv(2)=pizda(2,1)-pizda(1,2)
10578         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10579      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10580      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10581 C Cartesian gradient
10582         do iii=1,2
10583           do kkk=1,5
10584             do lll=1,3
10585               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10586      &          pizda(1,1))
10587               vv(1)=pizda(1,1)+pizda(2,2)
10588               vv(2)=pizda(2,1)-pizda(1,2)
10589               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10590      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10591      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10592             enddo
10593           enddo
10594         enddo
10595       else
10596 C Antiparallel orientation
10597 C Contribution from graph III
10598 c        goto 1110
10599         call transpose2(EUg(1,1,j),auxmat(1,1))
10600         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10601         vv(1)=pizda(1,1)-pizda(2,2)
10602         vv(2)=pizda(1,2)+pizda(2,1)
10603         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10604      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10605 C Explicit gradient in virtual-dihedral angles.
10606         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10607      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10608      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10609         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10610         vv(1)=pizda(1,1)-pizda(2,2)
10611         vv(2)=pizda(1,2)+pizda(2,1)
10612         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10613      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10615         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10616         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10617         vv(1)=pizda(1,1)-pizda(2,2)
10618         vv(2)=pizda(1,2)+pizda(2,1)
10619         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10620      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10621      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10622 C Cartesian gradient
10623         do iii=1,2
10624           do kkk=1,5
10625             do lll=1,3
10626               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10627      &          pizda(1,1))
10628               vv(1)=pizda(1,1)-pizda(2,2)
10629               vv(2)=pizda(1,2)+pizda(2,1)
10630               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10631      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10632      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10633             enddo
10634           enddo
10635         enddo
10636 cd        goto 1112
10637 C Contribution from graph IV
10638 1110    continue
10639         call transpose2(EE(1,1,j),auxmat(1,1))
10640         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10641         vv(1)=pizda(1,1)+pizda(2,2)
10642         vv(2)=pizda(2,1)-pizda(1,2)
10643         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10644      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10645 C Explicit gradient in virtual-dihedral angles.
10646         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10647      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10648         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10649         vv(1)=pizda(1,1)+pizda(2,2)
10650         vv(2)=pizda(2,1)-pizda(1,2)
10651         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10652      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10653      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10654 C Cartesian gradient
10655         do iii=1,2
10656           do kkk=1,5
10657             do lll=1,3
10658               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10659      &          pizda(1,1))
10660               vv(1)=pizda(1,1)+pizda(2,2)
10661               vv(2)=pizda(2,1)-pizda(1,2)
10662               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10663      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10664      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10665             enddo
10666           enddo
10667         enddo
10668       endif
10669 1112  continue
10670       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10671 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10672 cd        write (2,*) 'ijkl',i,j,k,l
10673 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10674 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10675 cd      endif
10676 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10677 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10678 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10679 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10680       if (j.lt.nres-1) then
10681         j1=j+1
10682         j2=j-1
10683       else
10684         j1=j-1
10685         j2=j-2
10686       endif
10687       if (l.lt.nres-1) then
10688         l1=l+1
10689         l2=l-1
10690       else
10691         l1=l-1
10692         l2=l-2
10693       endif
10694 cd      eij=1.0d0
10695 cd      ekl=1.0d0
10696 cd      ekont=1.0d0
10697 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10698 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10699 C        summed up outside the subrouine as for the other subroutines
10700 C        handling long-range interactions. The old code is commented out
10701 C        with "cgrad" to keep track of changes.
10702       do ll=1,3
10703 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10704 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10705         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10706         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10707 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10708 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10709 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10710 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10711 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10712 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10713 c     &   gradcorr5ij,
10714 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10715 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10716 cgrad        ghalf=0.5d0*ggg1(ll)
10717 cd        ghalf=0.0d0
10718         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10719         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10720         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10721         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10722         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10723         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10724 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10725 cgrad        ghalf=0.5d0*ggg2(ll)
10726 cd        ghalf=0.0d0
10727         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10728         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10729         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10730         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10731         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10732         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10733       enddo
10734 cd      goto 1112
10735 cgrad      do m=i+1,j-1
10736 cgrad        do ll=1,3
10737 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10738 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10739 cgrad        enddo
10740 cgrad      enddo
10741 cgrad      do m=k+1,l-1
10742 cgrad        do ll=1,3
10743 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10744 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10745 cgrad        enddo
10746 cgrad      enddo
10747 c1112  continue
10748 cgrad      do m=i+2,j2
10749 cgrad        do ll=1,3
10750 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10751 cgrad        enddo
10752 cgrad      enddo
10753 cgrad      do m=k+2,l2
10754 cgrad        do ll=1,3
10755 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10756 cgrad        enddo
10757 cgrad      enddo
10758 cd      do iii=1,nres-3
10759 cd        write (2,*) iii,g_corr5_loc(iii)
10760 cd      enddo
10761       eello5=ekont*eel5
10762 cd      write (2,*) 'ekont',ekont
10763 cd      write (iout,*) 'eello5',ekont*eel5
10764       return
10765       end
10766 c--------------------------------------------------------------------------
10767       double precision function eello6(i,j,k,l,jj,kk)
10768       implicit real*8 (a-h,o-z)
10769       include 'DIMENSIONS'
10770       include 'COMMON.IOUNITS'
10771       include 'COMMON.CHAIN'
10772       include 'COMMON.DERIV'
10773       include 'COMMON.INTERACT'
10774       include 'COMMON.CONTACTS'
10775       include 'COMMON.TORSION'
10776       include 'COMMON.VAR'
10777       include 'COMMON.GEO'
10778       include 'COMMON.FFIELD'
10779       double precision ggg1(3),ggg2(3)
10780 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10781 cd        eello6=0.0d0
10782 cd        return
10783 cd      endif
10784 cd      write (iout,*)
10785 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10786 cd     &   ' and',k,l
10787       eello6_1=0.0d0
10788       eello6_2=0.0d0
10789       eello6_3=0.0d0
10790       eello6_4=0.0d0
10791       eello6_5=0.0d0
10792       eello6_6=0.0d0
10793 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10794 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10795       do iii=1,2
10796         do kkk=1,5
10797           do lll=1,3
10798             derx(lll,kkk,iii)=0.0d0
10799           enddo
10800         enddo
10801       enddo
10802 cd      eij=facont_hb(jj,i)
10803 cd      ekl=facont_hb(kk,k)
10804 cd      ekont=eij*ekl
10805 cd      eij=1.0d0
10806 cd      ekl=1.0d0
10807 cd      ekont=1.0d0
10808       if (l.eq.j+1) then
10809         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10810         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10811         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10812         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10813         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10814         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10815       else
10816         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10817         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10818         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10819         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10820         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10821           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10822         else
10823           eello6_5=0.0d0
10824         endif
10825         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10826       endif
10827 C If turn contributions are considered, they will be handled separately.
10828       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10829 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10830 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10831 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10832 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10833 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10834 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10835 cd      goto 1112
10836       if (j.lt.nres-1) then
10837         j1=j+1
10838         j2=j-1
10839       else
10840         j1=j-1
10841         j2=j-2
10842       endif
10843       if (l.lt.nres-1) then
10844         l1=l+1
10845         l2=l-1
10846       else
10847         l1=l-1
10848         l2=l-2
10849       endif
10850       do ll=1,3
10851 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10852 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10853 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10854 cgrad        ghalf=0.5d0*ggg1(ll)
10855 cd        ghalf=0.0d0
10856         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10857         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10858         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10859         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10860         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10861         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10862         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10863         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10864 cgrad        ghalf=0.5d0*ggg2(ll)
10865 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10866 cd        ghalf=0.0d0
10867         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10868         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10869         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10870         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10871         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10872         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10873       enddo
10874 cd      goto 1112
10875 cgrad      do m=i+1,j-1
10876 cgrad        do ll=1,3
10877 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10878 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10879 cgrad        enddo
10880 cgrad      enddo
10881 cgrad      do m=k+1,l-1
10882 cgrad        do ll=1,3
10883 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10884 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10885 cgrad        enddo
10886 cgrad      enddo
10887 cgrad1112  continue
10888 cgrad      do m=i+2,j2
10889 cgrad        do ll=1,3
10890 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10891 cgrad        enddo
10892 cgrad      enddo
10893 cgrad      do m=k+2,l2
10894 cgrad        do ll=1,3
10895 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10896 cgrad        enddo
10897 cgrad      enddo
10898 cd      do iii=1,nres-3
10899 cd        write (2,*) iii,g_corr6_loc(iii)
10900 cd      enddo
10901       eello6=ekont*eel6
10902 cd      write (2,*) 'ekont',ekont
10903 cd      write (iout,*) 'eello6',ekont*eel6
10904       return
10905       end
10906 c--------------------------------------------------------------------------
10907       double precision function eello6_graph1(i,j,k,l,imat,swap)
10908       implicit real*8 (a-h,o-z)
10909       include 'DIMENSIONS'
10910       include 'COMMON.IOUNITS'
10911       include 'COMMON.CHAIN'
10912       include 'COMMON.DERIV'
10913       include 'COMMON.INTERACT'
10914       include 'COMMON.CONTACTS'
10915       include 'COMMON.TORSION'
10916       include 'COMMON.VAR'
10917       include 'COMMON.GEO'
10918       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10919       logical swap
10920       logical lprn
10921       common /kutas/ lprn
10922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10923 C                                                                              C
10924 C      Parallel       Antiparallel                                             C
10925 C                                                                              C
10926 C          o             o                                                     C
10927 C         /l\           /j\                                                    C
10928 C        /   \         /   \                                                   C
10929 C       /| o |         | o |\                                                  C
10930 C     \ j|/k\|  /   \  |/k\|l /                                                C
10931 C      \ /   \ /     \ /   \ /                                                 C
10932 C       o     o       o     o                                                  C
10933 C       i             i                                                        C
10934 C                                                                              C
10935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10936       itk=itype2loc(itype(k))
10937       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10938       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10939       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10940       call transpose2(EUgC(1,1,k),auxmat(1,1))
10941       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10942       vv1(1)=pizda1(1,1)-pizda1(2,2)
10943       vv1(2)=pizda1(1,2)+pizda1(2,1)
10944       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10945       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10946       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10947       s5=scalar2(vv(1),Dtobr2(1,i))
10948 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10949       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10950       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10951      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10952      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10953      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10954      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10955      & +scalar2(vv(1),Dtobr2der(1,i)))
10956       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10957       vv1(1)=pizda1(1,1)-pizda1(2,2)
10958       vv1(2)=pizda1(1,2)+pizda1(2,1)
10959       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10960       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10961       if (l.eq.j+1) then
10962         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10963      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10964      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10965      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10966      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10967       else
10968         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10969      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10970      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10971      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10972      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10973       endif
10974       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10975       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10976       vv1(1)=pizda1(1,1)-pizda1(2,2)
10977       vv1(2)=pizda1(1,2)+pizda1(2,1)
10978       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10979      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10980      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10981      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10982       do iii=1,2
10983         if (swap) then
10984           ind=3-iii
10985         else
10986           ind=iii
10987         endif
10988         do kkk=1,5
10989           do lll=1,3
10990             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10991             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10992             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10993             call transpose2(EUgC(1,1,k),auxmat(1,1))
10994             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10995      &        pizda1(1,1))
10996             vv1(1)=pizda1(1,1)-pizda1(2,2)
10997             vv1(2)=pizda1(1,2)+pizda1(2,1)
10998             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10999             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11000      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11001             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11002      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11003             s5=scalar2(vv(1),Dtobr2(1,i))
11004             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11005           enddo
11006         enddo
11007       enddo
11008       return
11009       end
11010 c----------------------------------------------------------------------------
11011       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11012       implicit real*8 (a-h,o-z)
11013       include 'DIMENSIONS'
11014       include 'COMMON.IOUNITS'
11015       include 'COMMON.CHAIN'
11016       include 'COMMON.DERIV'
11017       include 'COMMON.INTERACT'
11018       include 'COMMON.CONTACTS'
11019       include 'COMMON.TORSION'
11020       include 'COMMON.VAR'
11021       include 'COMMON.GEO'
11022       logical swap
11023       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11024      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11025       logical lprn
11026       common /kutas/ lprn
11027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11028 C                                                                              C
11029 C      Parallel       Antiparallel                                             C
11030 C                                                                              C
11031 C          o             o                                                     C
11032 C     \   /l\           /j\   /                                                C
11033 C      \ /   \         /   \ /                                                 C
11034 C       o| o |         | o |o                                                  C
11035 C     \ j|/k\|      \  |/k\|l                                                  C
11036 C      \ /   \       \ /   \                                                   C
11037 C       o             o                                                        C
11038 C       i             i                                                        C
11039 C                                                                              C
11040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11041 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11042 C AL 7/4/01 s1 would occur in the sixth-order moment,
11043 C           but not in a cluster cumulant
11044 #ifdef MOMENT
11045       s1=dip(1,jj,i)*dip(1,kk,k)
11046 #endif
11047       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11048       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11049       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11050       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11051       call transpose2(EUg(1,1,k),auxmat(1,1))
11052       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11053       vv(1)=pizda(1,1)-pizda(2,2)
11054       vv(2)=pizda(1,2)+pizda(2,1)
11055       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11056 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11057 #ifdef MOMENT
11058       eello6_graph2=-(s1+s2+s3+s4)
11059 #else
11060       eello6_graph2=-(s2+s3+s4)
11061 #endif
11062 c      eello6_graph2=-s3
11063 C Derivatives in gamma(i-1)
11064       if (i.gt.1) then
11065 #ifdef MOMENT
11066         s1=dipderg(1,jj,i)*dip(1,kk,k)
11067 #endif
11068         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11069         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11070         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11071         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11072 #ifdef MOMENT
11073         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11074 #else
11075         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11076 #endif
11077 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11078       endif
11079 C Derivatives in gamma(k-1)
11080 #ifdef MOMENT
11081       s1=dip(1,jj,i)*dipderg(1,kk,k)
11082 #endif
11083       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11084       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11085       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11086       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11087       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11088       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11089       vv(1)=pizda(1,1)-pizda(2,2)
11090       vv(2)=pizda(1,2)+pizda(2,1)
11091       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11092 #ifdef MOMENT
11093       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11094 #else
11095       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11096 #endif
11097 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11098 C Derivatives in gamma(j-1) or gamma(l-1)
11099       if (j.gt.1) then
11100 #ifdef MOMENT
11101         s1=dipderg(3,jj,i)*dip(1,kk,k)
11102 #endif
11103         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11104         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11105         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11106         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11107         vv(1)=pizda(1,1)-pizda(2,2)
11108         vv(2)=pizda(1,2)+pizda(2,1)
11109         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11110 #ifdef MOMENT
11111         if (swap) then
11112           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11113         else
11114           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11115         endif
11116 #endif
11117         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11118 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11119       endif
11120 C Derivatives in gamma(l-1) or gamma(j-1)
11121       if (l.gt.1) then
11122 #ifdef MOMENT
11123         s1=dip(1,jj,i)*dipderg(3,kk,k)
11124 #endif
11125         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11126         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11127         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11128         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11129         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11130         vv(1)=pizda(1,1)-pizda(2,2)
11131         vv(2)=pizda(1,2)+pizda(2,1)
11132         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11133 #ifdef MOMENT
11134         if (swap) then
11135           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11136         else
11137           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11138         endif
11139 #endif
11140         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11141 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11142       endif
11143 C Cartesian derivatives.
11144       if (lprn) then
11145         write (2,*) 'In eello6_graph2'
11146         do iii=1,2
11147           write (2,*) 'iii=',iii
11148           do kkk=1,5
11149             write (2,*) 'kkk=',kkk
11150             do jjj=1,2
11151               write (2,'(3(2f10.5),5x)')
11152      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11153             enddo
11154           enddo
11155         enddo
11156       endif
11157       do iii=1,2
11158         do kkk=1,5
11159           do lll=1,3
11160 #ifdef MOMENT
11161             if (iii.eq.1) then
11162               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11163             else
11164               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11165             endif
11166 #endif
11167             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11168      &        auxvec(1))
11169             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11170             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11171      &        auxvec(1))
11172             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11173             call transpose2(EUg(1,1,k),auxmat(1,1))
11174             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11175      &        pizda(1,1))
11176             vv(1)=pizda(1,1)-pizda(2,2)
11177             vv(2)=pizda(1,2)+pizda(2,1)
11178             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11179 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11180 #ifdef MOMENT
11181             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11182 #else
11183             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11184 #endif
11185             if (swap) then
11186               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11187             else
11188               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11189             endif
11190           enddo
11191         enddo
11192       enddo
11193       return
11194       end
11195 c----------------------------------------------------------------------------
11196       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11197       implicit real*8 (a-h,o-z)
11198       include 'DIMENSIONS'
11199       include 'COMMON.IOUNITS'
11200       include 'COMMON.CHAIN'
11201       include 'COMMON.DERIV'
11202       include 'COMMON.INTERACT'
11203       include 'COMMON.CONTACTS'
11204       include 'COMMON.TORSION'
11205       include 'COMMON.VAR'
11206       include 'COMMON.GEO'
11207       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11208       logical swap
11209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11210 C                                                                              C
11211 C      Parallel       Antiparallel                                             C
11212 C                                                                              C
11213 C          o             o                                                     C
11214 C         /l\   /   \   /j\                                                    C
11215 C        /   \ /     \ /   \                                                   C
11216 C       /| o |o       o| o |\                                                  C
11217 C       j|/k\|  /      |/k\|l /                                                C
11218 C        /   \ /       /   \ /                                                 C
11219 C       /     o       /     o                                                  C
11220 C       i             i                                                        C
11221 C                                                                              C
11222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11223 C
11224 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11225 C           energy moment and not to the cluster cumulant.
11226       iti=itortyp(itype(i))
11227       if (j.lt.nres-1) then
11228         itj1=itype2loc(itype(j+1))
11229       else
11230         itj1=nloctyp
11231       endif
11232       itk=itype2loc(itype(k))
11233       itk1=itype2loc(itype(k+1))
11234       if (l.lt.nres-1) then
11235         itl1=itype2loc(itype(l+1))
11236       else
11237         itl1=nloctyp
11238       endif
11239 #ifdef MOMENT
11240       s1=dip(4,jj,i)*dip(4,kk,k)
11241 #endif
11242       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11243       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11244       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11245       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11246       call transpose2(EE(1,1,k),auxmat(1,1))
11247       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11248       vv(1)=pizda(1,1)+pizda(2,2)
11249       vv(2)=pizda(2,1)-pizda(1,2)
11250       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11251 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11252 cd     & "sum",-(s2+s3+s4)
11253 #ifdef MOMENT
11254       eello6_graph3=-(s1+s2+s3+s4)
11255 #else
11256       eello6_graph3=-(s2+s3+s4)
11257 #endif
11258 c      eello6_graph3=-s4
11259 C Derivatives in gamma(k-1)
11260       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11261       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11262       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11263       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11264 C Derivatives in gamma(l-1)
11265       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11266       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11267       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11268       vv(1)=pizda(1,1)+pizda(2,2)
11269       vv(2)=pizda(2,1)-pizda(1,2)
11270       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11271       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11272 C Cartesian derivatives.
11273       do iii=1,2
11274         do kkk=1,5
11275           do lll=1,3
11276 #ifdef MOMENT
11277             if (iii.eq.1) then
11278               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11279             else
11280               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11281             endif
11282 #endif
11283             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11284      &        auxvec(1))
11285             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11286             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11287      &        auxvec(1))
11288             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11289             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11290      &        pizda(1,1))
11291             vv(1)=pizda(1,1)+pizda(2,2)
11292             vv(2)=pizda(2,1)-pizda(1,2)
11293             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11294 #ifdef MOMENT
11295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11296 #else
11297             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11298 #endif
11299             if (swap) then
11300               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11301             else
11302               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11303             endif
11304 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11305           enddo
11306         enddo
11307       enddo
11308       return
11309       end
11310 c----------------------------------------------------------------------------
11311       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11312       implicit real*8 (a-h,o-z)
11313       include 'DIMENSIONS'
11314       include 'COMMON.IOUNITS'
11315       include 'COMMON.CHAIN'
11316       include 'COMMON.DERIV'
11317       include 'COMMON.INTERACT'
11318       include 'COMMON.CONTACTS'
11319       include 'COMMON.TORSION'
11320       include 'COMMON.VAR'
11321       include 'COMMON.GEO'
11322       include 'COMMON.FFIELD'
11323       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11324      & auxvec1(2),auxmat1(2,2)
11325       logical swap
11326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11327 C                                                                              C
11328 C      Parallel       Antiparallel                                             C
11329 C                                                                              C
11330 C          o             o                                                     C
11331 C         /l\   /   \   /j\                                                    C
11332 C        /   \ /     \ /   \                                                   C
11333 C       /| o |o       o| o |\                                                  C
11334 C     \ j|/k\|      \  |/k\|l                                                  C
11335 C      \ /   \       \ /   \                                                   C
11336 C       o     \       o     \                                                  C
11337 C       i             i                                                        C
11338 C                                                                              C
11339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11340 C
11341 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11342 C           energy moment and not to the cluster cumulant.
11343 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11344       iti=itype2loc(itype(i))
11345       itj=itype2loc(itype(j))
11346       if (j.lt.nres-1) then
11347         itj1=itype2loc(itype(j+1))
11348       else
11349         itj1=nloctyp
11350       endif
11351       itk=itype2loc(itype(k))
11352       if (k.lt.nres-1) then
11353         itk1=itype2loc(itype(k+1))
11354       else
11355         itk1=nloctyp
11356       endif
11357       itl=itype2loc(itype(l))
11358       if (l.lt.nres-1) then
11359         itl1=itype2loc(itype(l+1))
11360       else
11361         itl1=nloctyp
11362       endif
11363 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11364 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11365 cd     & ' itl',itl,' itl1',itl1
11366 #ifdef MOMENT
11367       if (imat.eq.1) then
11368         s1=dip(3,jj,i)*dip(3,kk,k)
11369       else
11370         s1=dip(2,jj,j)*dip(2,kk,l)
11371       endif
11372 #endif
11373       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11374       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11375       if (j.eq.l+1) then
11376         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11377         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11378       else
11379         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11380         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11381       endif
11382       call transpose2(EUg(1,1,k),auxmat(1,1))
11383       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11384       vv(1)=pizda(1,1)-pizda(2,2)
11385       vv(2)=pizda(2,1)+pizda(1,2)
11386       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11387 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11388 #ifdef MOMENT
11389       eello6_graph4=-(s1+s2+s3+s4)
11390 #else
11391       eello6_graph4=-(s2+s3+s4)
11392 #endif
11393 C Derivatives in gamma(i-1)
11394       if (i.gt.1) then
11395 #ifdef MOMENT
11396         if (imat.eq.1) then
11397           s1=dipderg(2,jj,i)*dip(3,kk,k)
11398         else
11399           s1=dipderg(4,jj,j)*dip(2,kk,l)
11400         endif
11401 #endif
11402         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11403         if (j.eq.l+1) then
11404           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11405           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11406         else
11407           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11408           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11409         endif
11410         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11411         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11412 cd          write (2,*) 'turn6 derivatives'
11413 #ifdef MOMENT
11414           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11415 #else
11416           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11417 #endif
11418         else
11419 #ifdef MOMENT
11420           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11421 #else
11422           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11423 #endif
11424         endif
11425       endif
11426 C Derivatives in gamma(k-1)
11427 #ifdef MOMENT
11428       if (imat.eq.1) then
11429         s1=dip(3,jj,i)*dipderg(2,kk,k)
11430       else
11431         s1=dip(2,jj,j)*dipderg(4,kk,l)
11432       endif
11433 #endif
11434       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11435       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11436       if (j.eq.l+1) then
11437         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11438         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11439       else
11440         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11441         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11442       endif
11443       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11444       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11445       vv(1)=pizda(1,1)-pizda(2,2)
11446       vv(2)=pizda(2,1)+pizda(1,2)
11447       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11448       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11449 #ifdef MOMENT
11450         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11451 #else
11452         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11453 #endif
11454       else
11455 #ifdef MOMENT
11456         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11457 #else
11458         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11459 #endif
11460       endif
11461 C Derivatives in gamma(j-1) or gamma(l-1)
11462       if (l.eq.j+1 .and. l.gt.1) then
11463         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11464         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11465         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11466         vv(1)=pizda(1,1)-pizda(2,2)
11467         vv(2)=pizda(2,1)+pizda(1,2)
11468         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11469         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11470       else if (j.gt.1) then
11471         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11472         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11473         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11474         vv(1)=pizda(1,1)-pizda(2,2)
11475         vv(2)=pizda(2,1)+pizda(1,2)
11476         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11477         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11478           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11479         else
11480           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11481         endif
11482       endif
11483 C Cartesian derivatives.
11484       do iii=1,2
11485         do kkk=1,5
11486           do lll=1,3
11487 #ifdef MOMENT
11488             if (iii.eq.1) then
11489               if (imat.eq.1) then
11490                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11491               else
11492                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11493               endif
11494             else
11495               if (imat.eq.1) then
11496                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11497               else
11498                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11499               endif
11500             endif
11501 #endif
11502             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11503      &        auxvec(1))
11504             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11505             if (j.eq.l+1) then
11506               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11507      &          b1(1,j+1),auxvec(1))
11508               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11509             else
11510               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11511      &          b1(1,l+1),auxvec(1))
11512               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11513             endif
11514             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11515      &        pizda(1,1))
11516             vv(1)=pizda(1,1)-pizda(2,2)
11517             vv(2)=pizda(2,1)+pizda(1,2)
11518             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11519             if (swap) then
11520               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11521 #ifdef MOMENT
11522                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11523      &             -(s1+s2+s4)
11524 #else
11525                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11526      &             -(s2+s4)
11527 #endif
11528                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11529               else
11530 #ifdef MOMENT
11531                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11532 #else
11533                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11534 #endif
11535                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11536               endif
11537             else
11538 #ifdef MOMENT
11539               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11540 #else
11541               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11542 #endif
11543               if (l.eq.j+1) then
11544                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11545               else
11546                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11547               endif
11548             endif
11549           enddo
11550         enddo
11551       enddo
11552       return
11553       end
11554 c----------------------------------------------------------------------------
11555       double precision function eello_turn6(i,jj,kk)
11556       implicit real*8 (a-h,o-z)
11557       include 'DIMENSIONS'
11558       include 'COMMON.IOUNITS'
11559       include 'COMMON.CHAIN'
11560       include 'COMMON.DERIV'
11561       include 'COMMON.INTERACT'
11562       include 'COMMON.CONTACTS'
11563       include 'COMMON.TORSION'
11564       include 'COMMON.VAR'
11565       include 'COMMON.GEO'
11566       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11567      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11568      &  ggg1(3),ggg2(3)
11569       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11570      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11571 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11572 C           the respective energy moment and not to the cluster cumulant.
11573       s1=0.0d0
11574       s8=0.0d0
11575       s13=0.0d0
11576 c
11577       eello_turn6=0.0d0
11578       j=i+4
11579       k=i+1
11580       l=i+3
11581       iti=itype2loc(itype(i))
11582       itk=itype2loc(itype(k))
11583       itk1=itype2loc(itype(k+1))
11584       itl=itype2loc(itype(l))
11585       itj=itype2loc(itype(j))
11586 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11587 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11588 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11589 cd        eello6=0.0d0
11590 cd        return
11591 cd      endif
11592 cd      write (iout,*)
11593 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11594 cd     &   ' and',k,l
11595 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11596       do iii=1,2
11597         do kkk=1,5
11598           do lll=1,3
11599             derx_turn(lll,kkk,iii)=0.0d0
11600           enddo
11601         enddo
11602       enddo
11603 cd      eij=1.0d0
11604 cd      ekl=1.0d0
11605 cd      ekont=1.0d0
11606       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11607 cd      eello6_5=0.0d0
11608 cd      write (2,*) 'eello6_5',eello6_5
11609 #ifdef MOMENT
11610       call transpose2(AEA(1,1,1),auxmat(1,1))
11611       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11612       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11613       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11614 #endif
11615       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11616       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11617       s2 = scalar2(b1(1,k),vtemp1(1))
11618 #ifdef MOMENT
11619       call transpose2(AEA(1,1,2),atemp(1,1))
11620       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11621       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11622       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11623 #endif
11624       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11625       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11626       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11627 #ifdef MOMENT
11628       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11629       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11630       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11631       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11632       ss13 = scalar2(b1(1,k),vtemp4(1))
11633       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11634 #endif
11635 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11636 c      s1=0.0d0
11637 c      s2=0.0d0
11638 c      s8=0.0d0
11639 c      s12=0.0d0
11640 c      s13=0.0d0
11641       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11642 C Derivatives in gamma(i+2)
11643       s1d =0.0d0
11644       s8d =0.0d0
11645 #ifdef MOMENT
11646       call transpose2(AEA(1,1,1),auxmatd(1,1))
11647       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11648       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11649       call transpose2(AEAderg(1,1,2),atempd(1,1))
11650       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11651       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11652 #endif
11653       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11654       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11655       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11656 c      s1d=0.0d0
11657 c      s2d=0.0d0
11658 c      s8d=0.0d0
11659 c      s12d=0.0d0
11660 c      s13d=0.0d0
11661       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11662 C Derivatives in gamma(i+3)
11663 #ifdef MOMENT
11664       call transpose2(AEA(1,1,1),auxmatd(1,1))
11665       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11666       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11667       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11668 #endif
11669       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11670       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11671       s2d = scalar2(b1(1,k),vtemp1d(1))
11672 #ifdef MOMENT
11673       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11674       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11675 #endif
11676       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11677 #ifdef MOMENT
11678       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11679       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11680       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11681 #endif
11682 c      s1d=0.0d0
11683 c      s2d=0.0d0
11684 c      s8d=0.0d0
11685 c      s12d=0.0d0
11686 c      s13d=0.0d0
11687 #ifdef MOMENT
11688       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11689      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11690 #else
11691       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11692      &               -0.5d0*ekont*(s2d+s12d)
11693 #endif
11694 C Derivatives in gamma(i+4)
11695       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11696       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11697       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11698 #ifdef MOMENT
11699       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11700       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11701       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11702 #endif
11703 c      s1d=0.0d0
11704 c      s2d=0.0d0
11705 c      s8d=0.0d0
11706 C      s12d=0.0d0
11707 c      s13d=0.0d0
11708 #ifdef MOMENT
11709       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11710 #else
11711       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11712 #endif
11713 C Derivatives in gamma(i+5)
11714 #ifdef MOMENT
11715       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11716       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11717       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11718 #endif
11719       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11720       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11721       s2d = scalar2(b1(1,k),vtemp1d(1))
11722 #ifdef MOMENT
11723       call transpose2(AEA(1,1,2),atempd(1,1))
11724       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11725       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11726 #endif
11727       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11728       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11729 #ifdef MOMENT
11730       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11731       ss13d = scalar2(b1(1,k),vtemp4d(1))
11732       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11733 #endif
11734 c      s1d=0.0d0
11735 c      s2d=0.0d0
11736 c      s8d=0.0d0
11737 c      s12d=0.0d0
11738 c      s13d=0.0d0
11739 #ifdef MOMENT
11740       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11741      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11742 #else
11743       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11744      &               -0.5d0*ekont*(s2d+s12d)
11745 #endif
11746 C Cartesian derivatives
11747       do iii=1,2
11748         do kkk=1,5
11749           do lll=1,3
11750 #ifdef MOMENT
11751             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11752             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11753             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11754 #endif
11755             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11756             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11757      &          vtemp1d(1))
11758             s2d = scalar2(b1(1,k),vtemp1d(1))
11759 #ifdef MOMENT
11760             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11761             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11762             s8d = -(atempd(1,1)+atempd(2,2))*
11763      &           scalar2(cc(1,1,l),vtemp2(1))
11764 #endif
11765             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11766      &           auxmatd(1,1))
11767             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11768             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11769 c      s1d=0.0d0
11770 c      s2d=0.0d0
11771 c      s8d=0.0d0
11772 c      s12d=0.0d0
11773 c      s13d=0.0d0
11774 #ifdef MOMENT
11775             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11776      &        - 0.5d0*(s1d+s2d)
11777 #else
11778             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11779      &        - 0.5d0*s2d
11780 #endif
11781 #ifdef MOMENT
11782             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11783      &        - 0.5d0*(s8d+s12d)
11784 #else
11785             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11786      &        - 0.5d0*s12d
11787 #endif
11788           enddo
11789         enddo
11790       enddo
11791 #ifdef MOMENT
11792       do kkk=1,5
11793         do lll=1,3
11794           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11795      &      achuj_tempd(1,1))
11796           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11797           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11798           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11799           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11800           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11801      &      vtemp4d(1))
11802           ss13d = scalar2(b1(1,k),vtemp4d(1))
11803           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11804           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11805         enddo
11806       enddo
11807 #endif
11808 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11809 cd     &  16*eel_turn6_num
11810 cd      goto 1112
11811       if (j.lt.nres-1) then
11812         j1=j+1
11813         j2=j-1
11814       else
11815         j1=j-1
11816         j2=j-2
11817       endif
11818       if (l.lt.nres-1) then
11819         l1=l+1
11820         l2=l-1
11821       else
11822         l1=l-1
11823         l2=l-2
11824       endif
11825       do ll=1,3
11826 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11827 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11828 cgrad        ghalf=0.5d0*ggg1(ll)
11829 cd        ghalf=0.0d0
11830         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11831         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11832         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11833      &    +ekont*derx_turn(ll,2,1)
11834         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11835         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11836      &    +ekont*derx_turn(ll,4,1)
11837         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11838         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11839         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11840 cgrad        ghalf=0.5d0*ggg2(ll)
11841 cd        ghalf=0.0d0
11842         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11843      &    +ekont*derx_turn(ll,2,2)
11844         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11845         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11846      &    +ekont*derx_turn(ll,4,2)
11847         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11848         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11849         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11850       enddo
11851 cd      goto 1112
11852 cgrad      do m=i+1,j-1
11853 cgrad        do ll=1,3
11854 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11855 cgrad        enddo
11856 cgrad      enddo
11857 cgrad      do m=k+1,l-1
11858 cgrad        do ll=1,3
11859 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11860 cgrad        enddo
11861 cgrad      enddo
11862 cgrad1112  continue
11863 cgrad      do m=i+2,j2
11864 cgrad        do ll=1,3
11865 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11866 cgrad        enddo
11867 cgrad      enddo
11868 cgrad      do m=k+2,l2
11869 cgrad        do ll=1,3
11870 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11871 cgrad        enddo
11872 cgrad      enddo
11873 cd      do iii=1,nres-3
11874 cd        write (2,*) iii,g_corr6_loc(iii)
11875 cd      enddo
11876       eello_turn6=ekont*eel_turn6
11877 cd      write (2,*) 'ekont',ekont
11878 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11879       return
11880       end
11881
11882 C-----------------------------------------------------------------------------
11883       double precision function scalar(u,v)
11884 !DIR$ INLINEALWAYS scalar
11885 #ifndef OSF
11886 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11887 #endif
11888       implicit none
11889       double precision u(3),v(3)
11890 cd      double precision sc
11891 cd      integer i
11892 cd      sc=0.0d0
11893 cd      do i=1,3
11894 cd        sc=sc+u(i)*v(i)
11895 cd      enddo
11896 cd      scalar=sc
11897
11898       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11899       return
11900       end
11901 crc-------------------------------------------------
11902       SUBROUTINE MATVEC2(A1,V1,V2)
11903 !DIR$ INLINEALWAYS MATVEC2
11904 #ifndef OSF
11905 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11906 #endif
11907       implicit real*8 (a-h,o-z)
11908       include 'DIMENSIONS'
11909       DIMENSION A1(2,2),V1(2),V2(2)
11910 c      DO 1 I=1,2
11911 c        VI=0.0
11912 c        DO 3 K=1,2
11913 c    3     VI=VI+A1(I,K)*V1(K)
11914 c        Vaux(I)=VI
11915 c    1 CONTINUE
11916
11917       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11918       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11919
11920       v2(1)=vaux1
11921       v2(2)=vaux2
11922       END
11923 C---------------------------------------
11924       SUBROUTINE MATMAT2(A1,A2,A3)
11925 #ifndef OSF
11926 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11927 #endif
11928       implicit real*8 (a-h,o-z)
11929       include 'DIMENSIONS'
11930       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11931 c      DIMENSION AI3(2,2)
11932 c        DO  J=1,2
11933 c          A3IJ=0.0
11934 c          DO K=1,2
11935 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11936 c          enddo
11937 c          A3(I,J)=A3IJ
11938 c       enddo
11939 c      enddo
11940
11941       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11942       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11943       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11944       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11945
11946       A3(1,1)=AI3_11
11947       A3(2,1)=AI3_21
11948       A3(1,2)=AI3_12
11949       A3(2,2)=AI3_22
11950       END
11951
11952 c-------------------------------------------------------------------------
11953       double precision function scalar2(u,v)
11954 !DIR$ INLINEALWAYS scalar2
11955       implicit none
11956       double precision u(2),v(2)
11957       double precision sc
11958       integer i
11959       scalar2=u(1)*v(1)+u(2)*v(2)
11960       return
11961       end
11962
11963 C-----------------------------------------------------------------------------
11964
11965       subroutine transpose2(a,at)
11966 !DIR$ INLINEALWAYS transpose2
11967 #ifndef OSF
11968 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11969 #endif
11970       implicit none
11971       double precision a(2,2),at(2,2)
11972       at(1,1)=a(1,1)
11973       at(1,2)=a(2,1)
11974       at(2,1)=a(1,2)
11975       at(2,2)=a(2,2)
11976       return
11977       end
11978 c--------------------------------------------------------------------------
11979       subroutine transpose(n,a,at)
11980       implicit none
11981       integer n,i,j
11982       double precision a(n,n),at(n,n)
11983       do i=1,n
11984         do j=1,n
11985           at(j,i)=a(i,j)
11986         enddo
11987       enddo
11988       return
11989       end
11990 C---------------------------------------------------------------------------
11991       subroutine prodmat3(a1,a2,kk,transp,prod)
11992 !DIR$ INLINEALWAYS prodmat3
11993 #ifndef OSF
11994 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11995 #endif
11996       implicit none
11997       integer i,j
11998       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11999       logical transp
12000 crc      double precision auxmat(2,2),prod_(2,2)
12001
12002       if (transp) then
12003 crc        call transpose2(kk(1,1),auxmat(1,1))
12004 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12005 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12006
12007            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12008      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12009            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12010      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12011            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12012      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12013            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12014      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12015
12016       else
12017 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12018 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12019
12020            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12021      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12022            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12023      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12024            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12025      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12026            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12027      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12028
12029       endif
12030 c      call transpose2(a2(1,1),a2t(1,1))
12031
12032 crc      print *,transp
12033 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12034 crc      print *,((prod(i,j),i=1,2),j=1,2)
12035
12036       return
12037       end
12038 CCC----------------------------------------------
12039       subroutine Eliptransfer(eliptran)
12040       implicit real*8 (a-h,o-z)
12041       include 'DIMENSIONS'
12042       include 'COMMON.GEO'
12043       include 'COMMON.VAR'
12044       include 'COMMON.LOCAL'
12045       include 'COMMON.CHAIN'
12046       include 'COMMON.DERIV'
12047       include 'COMMON.NAMES'
12048       include 'COMMON.INTERACT'
12049       include 'COMMON.IOUNITS'
12050       include 'COMMON.CALC'
12051       include 'COMMON.CONTROL'
12052       include 'COMMON.SPLITELE'
12053       include 'COMMON.SBRIDGE'
12054 C this is done by Adasko
12055 C      print *,"wchodze"
12056 C structure of box:
12057 C      water
12058 C--bordliptop-- buffore starts
12059 C--bufliptop--- here true lipid starts
12060 C      lipid
12061 C--buflipbot--- lipid ends buffore starts
12062 C--bordlipbot--buffore ends
12063       eliptran=0.0
12064       do i=ilip_start,ilip_end
12065 C       do i=1,1
12066         if (itype(i).eq.ntyp1) cycle
12067
12068         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12069         if (positi.le.0.0) positi=positi+boxzsize
12070 C        print *,i
12071 C first for peptide groups
12072 c for each residue check if it is in lipid or lipid water border area
12073        if ((positi.gt.bordlipbot)
12074      &.and.(positi.lt.bordliptop)) then
12075 C the energy transfer exist
12076         if (positi.lt.buflipbot) then
12077 C what fraction I am in
12078          fracinbuf=1.0d0-
12079      &        ((positi-bordlipbot)/lipbufthick)
12080 C lipbufthick is thickenes of lipid buffore
12081          sslip=sscalelip(fracinbuf)
12082          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12083          eliptran=eliptran+sslip*pepliptran
12084          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12085          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12086 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12087
12088 C        print *,"doing sccale for lower part"
12089 C         print *,i,sslip,fracinbuf,ssgradlip
12090         elseif (positi.gt.bufliptop) then
12091          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12092          sslip=sscalelip(fracinbuf)
12093          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12094          eliptran=eliptran+sslip*pepliptran
12095          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12096          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12097 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12098 C          print *, "doing sscalefor top part"
12099 C         print *,i,sslip,fracinbuf,ssgradlip
12100         else
12101          eliptran=eliptran+pepliptran
12102 C         print *,"I am in true lipid"
12103         endif
12104 C       else
12105 C       eliptran=elpitran+0.0 ! I am in water
12106        endif
12107        enddo
12108 C       print *, "nic nie bylo w lipidzie?"
12109 C now multiply all by the peptide group transfer factor
12110 C       eliptran=eliptran*pepliptran
12111 C now the same for side chains
12112 CV       do i=1,1
12113        do i=ilip_start,ilip_end
12114         if (itype(i).eq.ntyp1) cycle
12115         positi=(mod(c(3,i+nres),boxzsize))
12116         if (positi.le.0) positi=positi+boxzsize
12117 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12118 c for each residue check if it is in lipid or lipid water border area
12119 C       respos=mod(c(3,i+nres),boxzsize)
12120 C       print *,positi,bordlipbot,buflipbot
12121        if ((positi.gt.bordlipbot)
12122      & .and.(positi.lt.bordliptop)) then
12123 C the energy transfer exist
12124         if (positi.lt.buflipbot) then
12125          fracinbuf=1.0d0-
12126      &     ((positi-bordlipbot)/lipbufthick)
12127 C lipbufthick is thickenes of lipid buffore
12128          sslip=sscalelip(fracinbuf)
12129          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12130          eliptran=eliptran+sslip*liptranene(itype(i))
12131          gliptranx(3,i)=gliptranx(3,i)
12132      &+ssgradlip*liptranene(itype(i))
12133          gliptranc(3,i-1)= gliptranc(3,i-1)
12134      &+ssgradlip*liptranene(itype(i))
12135 C         print *,"doing sccale for lower part"
12136         elseif (positi.gt.bufliptop) then
12137          fracinbuf=1.0d0-
12138      &((bordliptop-positi)/lipbufthick)
12139          sslip=sscalelip(fracinbuf)
12140          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12141          eliptran=eliptran+sslip*liptranene(itype(i))
12142          gliptranx(3,i)=gliptranx(3,i)
12143      &+ssgradlip*liptranene(itype(i))
12144          gliptranc(3,i-1)= gliptranc(3,i-1)
12145      &+ssgradlip*liptranene(itype(i))
12146 C          print *, "doing sscalefor top part",sslip,fracinbuf
12147         else
12148          eliptran=eliptran+liptranene(itype(i))
12149 C         print *,"I am in true lipid"
12150         endif
12151         endif ! if in lipid or buffor
12152 C       else
12153 C       eliptran=elpitran+0.0 ! I am in water
12154        enddo
12155        return
12156        end
12157 C---------------------------------------------------------
12158 C AFM soubroutine for constant force
12159        subroutine AFMforce(Eafmforce)
12160        implicit real*8 (a-h,o-z)
12161       include 'DIMENSIONS'
12162       include 'COMMON.GEO'
12163       include 'COMMON.VAR'
12164       include 'COMMON.LOCAL'
12165       include 'COMMON.CHAIN'
12166       include 'COMMON.DERIV'
12167       include 'COMMON.NAMES'
12168       include 'COMMON.INTERACT'
12169       include 'COMMON.IOUNITS'
12170       include 'COMMON.CALC'
12171       include 'COMMON.CONTROL'
12172       include 'COMMON.SPLITELE'
12173       include 'COMMON.SBRIDGE'
12174       real*8 diffafm(3)
12175       dist=0.0d0
12176       Eafmforce=0.0d0
12177       do i=1,3
12178       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12179       dist=dist+diffafm(i)**2
12180       enddo
12181       dist=dsqrt(dist)
12182       Eafmforce=-forceAFMconst*(dist-distafminit)
12183       do i=1,3
12184       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12185       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12186       enddo
12187 C      print *,'AFM',Eafmforce
12188       return
12189       end
12190 C---------------------------------------------------------
12191 C AFM subroutine with pseudoconstant velocity
12192        subroutine AFMvel(Eafmforce)
12193        implicit real*8 (a-h,o-z)
12194       include 'DIMENSIONS'
12195       include 'COMMON.GEO'
12196       include 'COMMON.VAR'
12197       include 'COMMON.LOCAL'
12198       include 'COMMON.CHAIN'
12199       include 'COMMON.DERIV'
12200       include 'COMMON.NAMES'
12201       include 'COMMON.INTERACT'
12202       include 'COMMON.IOUNITS'
12203       include 'COMMON.CALC'
12204       include 'COMMON.CONTROL'
12205       include 'COMMON.SPLITELE'
12206       include 'COMMON.SBRIDGE'
12207       real*8 diffafm(3)
12208 C Only for check grad COMMENT if not used for checkgrad
12209 C      totT=3.0d0
12210 C--------------------------------------------------------
12211 C      print *,"wchodze"
12212       dist=0.0d0
12213       Eafmforce=0.0d0
12214       do i=1,3
12215       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12216       dist=dist+diffafm(i)**2
12217       enddo
12218       dist=dsqrt(dist)
12219       Eafmforce=0.5d0*forceAFMconst
12220      & *(distafminit+totTafm*velAFMconst-dist)**2
12221 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12222       do i=1,3
12223       gradafm(i,afmend-1)=-forceAFMconst*
12224      &(distafminit+totTafm*velAFMconst-dist)
12225      &*diffafm(i)/dist
12226       gradafm(i,afmbeg-1)=forceAFMconst*
12227      &(distafminit+totTafm*velAFMconst-dist)
12228      &*diffafm(i)/dist
12229       enddo
12230 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12231       return
12232       end
12233 C-----------------------------------------------------------
12234 C first for shielding is setting of function of side-chains
12235        subroutine set_shield_fac
12236       implicit real*8 (a-h,o-z)
12237       include 'DIMENSIONS'
12238       include 'COMMON.CHAIN'
12239       include 'COMMON.DERIV'
12240       include 'COMMON.IOUNITS'
12241       include 'COMMON.SHIELD'
12242       include 'COMMON.INTERACT'
12243 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12244       double precision div77_81/0.974996043d0/,
12245      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12246
12247 C the vector between center of side_chain and peptide group
12248        double precision pep_side(3),long,side_calf(3),
12249      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12250      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12251 C the line belowe needs to be changed for FGPROC>1
12252       do i=1,nres-1
12253       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12254       ishield_list(i)=0
12255 Cif there two consequtive dummy atoms there is no peptide group between them
12256 C the line below has to be changed for FGPROC>1
12257       VolumeTotal=0.0
12258       do k=1,nres
12259        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12260        dist_pep_side=0.0
12261        dist_side_calf=0.0
12262        do j=1,3
12263 C first lets set vector conecting the ithe side-chain with kth side-chain
12264       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12265 C      pep_side(j)=2.0d0
12266 C and vector conecting the side-chain with its proper calfa
12267       side_calf(j)=c(j,k+nres)-c(j,k)
12268 C      side_calf(j)=2.0d0
12269       pept_group(j)=c(j,i)-c(j,i+1)
12270 C lets have their lenght
12271       dist_pep_side=pep_side(j)**2+dist_pep_side
12272       dist_side_calf=dist_side_calf+side_calf(j)**2
12273       dist_pept_group=dist_pept_group+pept_group(j)**2
12274       enddo
12275        dist_pep_side=dsqrt(dist_pep_side)
12276        dist_pept_group=dsqrt(dist_pept_group)
12277        dist_side_calf=dsqrt(dist_side_calf)
12278       do j=1,3
12279         pep_side_norm(j)=pep_side(j)/dist_pep_side
12280         side_calf_norm(j)=dist_side_calf
12281       enddo
12282 C now sscale fraction
12283        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12284 C       print *,buff_shield,"buff"
12285 C now sscale
12286         if (sh_frac_dist.le.0.0) cycle
12287 C If we reach here it means that this side chain reaches the shielding sphere
12288 C Lets add him to the list for gradient
12289         ishield_list(i)=ishield_list(i)+1
12290 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12291 C this list is essential otherwise problem would be O3
12292         shield_list(ishield_list(i),i)=k
12293 C Lets have the sscale value
12294         if (sh_frac_dist.gt.1.0) then
12295          scale_fac_dist=1.0d0
12296          do j=1,3
12297          sh_frac_dist_grad(j)=0.0d0
12298          enddo
12299         else
12300          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12301      &                   *(2.0*sh_frac_dist-3.0d0)
12302          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12303      &                  /dist_pep_side/buff_shield*0.5
12304 C remember for the final gradient multiply sh_frac_dist_grad(j)
12305 C for side_chain by factor -2 !
12306          do j=1,3
12307          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12308 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12309 C     &                    sh_frac_dist_grad(j)
12310          enddo
12311         endif
12312 C        if ((i.eq.3).and.(k.eq.2)) then
12313 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12314 C     & ,"TU"
12315 C        endif
12316
12317 C this is what is now we have the distance scaling now volume...
12318       short=short_r_sidechain(itype(k))
12319       long=long_r_sidechain(itype(k))
12320       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12321 C now costhet_grad
12322 C       costhet=0.0d0
12323        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12324 C       costhet_fac=0.0d0
12325        do j=1,3
12326          costhet_grad(j)=costhet_fac*pep_side(j)
12327        enddo
12328 C remember for the final gradient multiply costhet_grad(j)
12329 C for side_chain by factor -2 !
12330 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12331 C pep_side0pept_group is vector multiplication
12332       pep_side0pept_group=0.0
12333       do j=1,3
12334       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12335       enddo
12336       cosalfa=(pep_side0pept_group/
12337      & (dist_pep_side*dist_side_calf))
12338       fac_alfa_sin=1.0-cosalfa**2
12339       fac_alfa_sin=dsqrt(fac_alfa_sin)
12340       rkprim=fac_alfa_sin*(long-short)+short
12341 C now costhet_grad
12342        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12343        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12344
12345        do j=1,3
12346          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12347      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12348      &*(long-short)/fac_alfa_sin*cosalfa/
12349      &((dist_pep_side*dist_side_calf))*
12350      &((side_calf(j))-cosalfa*
12351      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12352
12353         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12354      &*(long-short)/fac_alfa_sin*cosalfa
12355      &/((dist_pep_side*dist_side_calf))*
12356      &(pep_side(j)-
12357      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12358        enddo
12359
12360       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12361      &                    /VSolvSphere_div
12362      &                    *wshield
12363 C now the gradient...
12364 C grad_shield is gradient of Calfa for peptide groups
12365 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12366 C     &               costhet,cosphi
12367 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12368 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12369       do j=1,3
12370       grad_shield(j,i)=grad_shield(j,i)
12371 C gradient po skalowaniu
12372      &                +(sh_frac_dist_grad(j)
12373 C  gradient po costhet
12374      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12375      &-scale_fac_dist*(cosphi_grad_long(j))
12376      &/(1.0-cosphi) )*div77_81
12377      &*VofOverlap
12378 C grad_shield_side is Cbeta sidechain gradient
12379       grad_shield_side(j,ishield_list(i),i)=
12380      &        (sh_frac_dist_grad(j)*(-2.0d0)
12381      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12382      &       +scale_fac_dist*(cosphi_grad_long(j))
12383      &        *2.0d0/(1.0-cosphi))
12384      &        *div77_81*VofOverlap
12385
12386        grad_shield_loc(j,ishield_list(i),i)=
12387      &   scale_fac_dist*cosphi_grad_loc(j)
12388      &        *2.0d0/(1.0-cosphi)
12389      &        *div77_81*VofOverlap
12390       enddo
12391       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12392       enddo
12393       fac_shield(i)=VolumeTotal*div77_81+div4_81
12394 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12395       enddo
12396       return
12397       end
12398 C--------------------------------------------------------------------------
12399       double precision function tschebyshev(m,n,x,y)
12400       implicit none
12401       include "DIMENSIONS"
12402       integer i,m,n
12403       double precision x(n),y,yy(0:maxvar),aux
12404 c Tschebyshev polynomial. Note that the first term is omitted
12405 c m=0: the constant term is included
12406 c m=1: the constant term is not included
12407       yy(0)=1.0d0
12408       yy(1)=y
12409       do i=2,n
12410         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12411       enddo
12412       aux=0.0d0
12413       do i=m,n
12414         aux=aux+x(i)*yy(i)
12415       enddo
12416       tschebyshev=aux
12417       return
12418       end
12419 C--------------------------------------------------------------------------
12420       double precision function gradtschebyshev(m,n,x,y)
12421       implicit none
12422       include "DIMENSIONS"
12423       integer i,m,n
12424       double precision x(n+1),y,yy(0:maxvar),aux
12425 c Tschebyshev polynomial. Note that the first term is omitted
12426 c m=0: the constant term is included
12427 c m=1: the constant term is not included
12428       yy(0)=1.0d0
12429       yy(1)=2.0d0*y
12430       do i=2,n
12431         yy(i)=2*y*yy(i-1)-yy(i-2)
12432       enddo
12433       aux=0.0d0
12434       do i=m,n
12435         aux=aux+x(i+1)*yy(i)*(i+1)
12436 C        print *, x(i+1),yy(i),i
12437       enddo
12438       gradtschebyshev=aux
12439       return
12440       end
12441 C------------------------------------------------------------------------
12442 C first for shielding is setting of function of side-chains
12443        subroutine set_shield_fac2
12444       implicit real*8 (a-h,o-z)
12445       include 'DIMENSIONS'
12446       include 'COMMON.CHAIN'
12447       include 'COMMON.DERIV'
12448       include 'COMMON.IOUNITS'
12449       include 'COMMON.SHIELD'
12450       include 'COMMON.INTERACT'
12451 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12452       double precision div77_81/0.974996043d0/,
12453      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12454
12455 C the vector between center of side_chain and peptide group
12456        double precision pep_side(3),long,side_calf(3),
12457      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12458      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12459 C the line belowe needs to be changed for FGPROC>1
12460       do i=1,nres-1
12461       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12462       ishield_list(i)=0
12463 Cif there two consequtive dummy atoms there is no peptide group between them
12464 C the line below has to be changed for FGPROC>1
12465       VolumeTotal=0.0
12466       do k=1,nres
12467        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12468        dist_pep_side=0.0
12469        dist_side_calf=0.0
12470        do j=1,3
12471 C first lets set vector conecting the ithe side-chain with kth side-chain
12472       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12473 C      pep_side(j)=2.0d0
12474 C and vector conecting the side-chain with its proper calfa
12475       side_calf(j)=c(j,k+nres)-c(j,k)
12476 C      side_calf(j)=2.0d0
12477       pept_group(j)=c(j,i)-c(j,i+1)
12478 C lets have their lenght
12479       dist_pep_side=pep_side(j)**2+dist_pep_side
12480       dist_side_calf=dist_side_calf+side_calf(j)**2
12481       dist_pept_group=dist_pept_group+pept_group(j)**2
12482       enddo
12483        dist_pep_side=dsqrt(dist_pep_side)
12484        dist_pept_group=dsqrt(dist_pept_group)
12485        dist_side_calf=dsqrt(dist_side_calf)
12486       do j=1,3
12487         pep_side_norm(j)=pep_side(j)/dist_pep_side
12488         side_calf_norm(j)=dist_side_calf
12489       enddo
12490 C now sscale fraction
12491        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12492 C       print *,buff_shield,"buff"
12493 C now sscale
12494         if (sh_frac_dist.le.0.0) cycle
12495 C If we reach here it means that this side chain reaches the shielding sphere
12496 C Lets add him to the list for gradient
12497         ishield_list(i)=ishield_list(i)+1
12498 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12499 C this list is essential otherwise problem would be O3
12500         shield_list(ishield_list(i),i)=k
12501 C Lets have the sscale value
12502         if (sh_frac_dist.gt.1.0) then
12503          scale_fac_dist=1.0d0
12504          do j=1,3
12505          sh_frac_dist_grad(j)=0.0d0
12506          enddo
12507         else
12508          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12509      &                   *(2.0d0*sh_frac_dist-3.0d0)
12510          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12511      &                  /dist_pep_side/buff_shield*0.5d0
12512 C remember for the final gradient multiply sh_frac_dist_grad(j)
12513 C for side_chain by factor -2 !
12514          do j=1,3
12515          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12516 C         sh_frac_dist_grad(j)=0.0d0
12517 C         scale_fac_dist=1.0d0
12518 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12519 C     &                    sh_frac_dist_grad(j)
12520          enddo
12521         endif
12522 C this is what is now we have the distance scaling now volume...
12523       short=short_r_sidechain(itype(k))
12524       long=long_r_sidechain(itype(k))
12525       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12526       sinthet=short/dist_pep_side*costhet
12527 C now costhet_grad
12528 C       costhet=0.6d0
12529 C       sinthet=0.8
12530        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12531 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12532 C     &             -short/dist_pep_side**2/costhet)
12533 C       costhet_fac=0.0d0
12534        do j=1,3
12535          costhet_grad(j)=costhet_fac*pep_side(j)
12536        enddo
12537 C remember for the final gradient multiply costhet_grad(j)
12538 C for side_chain by factor -2 !
12539 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12540 C pep_side0pept_group is vector multiplication
12541       pep_side0pept_group=0.0d0
12542       do j=1,3
12543       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12544       enddo
12545       cosalfa=(pep_side0pept_group/
12546      & (dist_pep_side*dist_side_calf))
12547       fac_alfa_sin=1.0d0-cosalfa**2
12548       fac_alfa_sin=dsqrt(fac_alfa_sin)
12549       rkprim=fac_alfa_sin*(long-short)+short
12550 C      rkprim=short
12551
12552 C now costhet_grad
12553        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12554 C       cosphi=0.6
12555        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12556        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12557      &      dist_pep_side**2)
12558 C       sinphi=0.8
12559        do j=1,3
12560          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12561      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12562      &*(long-short)/fac_alfa_sin*cosalfa/
12563      &((dist_pep_side*dist_side_calf))*
12564      &((side_calf(j))-cosalfa*
12565      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12566 C       cosphi_grad_long(j)=0.0d0
12567         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12568      &*(long-short)/fac_alfa_sin*cosalfa
12569      &/((dist_pep_side*dist_side_calf))*
12570      &(pep_side(j)-
12571      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12572 C       cosphi_grad_loc(j)=0.0d0
12573        enddo
12574 C      print *,sinphi,sinthet
12575 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12576 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12577       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12578      &                    /VSolvSphere_div
12579 C     &                    *wshield
12580 C now the gradient...
12581       do j=1,3
12582       grad_shield(j,i)=grad_shield(j,i)
12583 C gradient po skalowaniu
12584      &                +(sh_frac_dist_grad(j)*VofOverlap
12585 C  gradient po costhet
12586      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12587      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12588      &       sinphi/sinthet*costhet*costhet_grad(j)
12589      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12590      & )*wshield
12591 C grad_shield_side is Cbeta sidechain gradient
12592       grad_shield_side(j,ishield_list(i),i)=
12593      &        (sh_frac_dist_grad(j)*(-2.0d0)
12594      &        *VofOverlap
12595      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12596      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12597      &       sinphi/sinthet*costhet*costhet_grad(j)
12598      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12599      &       )*wshield
12600
12601        grad_shield_loc(j,ishield_list(i),i)=
12602      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12603      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12604      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12605      &        ))
12606      &        *wshield
12607       enddo
12608 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12609 c     & scale_fac_dist
12610       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12611       enddo
12612       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12613 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12614 c     &  " wshield",wshield
12615 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12616       enddo
12617       return
12618       end
12619 C-----------------------------------------------------------------------
12620 C-----------------------------------------------------------
12621 C This subroutine is to mimic the histone like structure but as well can be
12622 C utilizet to nanostructures (infinit) small modification has to be used to
12623 C make it finite (z gradient at the ends has to be changes as well as the x,y
12624 C gradient has to be modified at the ends
12625 C The energy function is Kihara potential
12626 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12627 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12628 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12629 C simple Kihara potential
12630       subroutine calctube(Etube)
12631        implicit real*8 (a-h,o-z)
12632       include 'DIMENSIONS'
12633       include 'COMMON.GEO'
12634       include 'COMMON.VAR'
12635       include 'COMMON.LOCAL'
12636       include 'COMMON.CHAIN'
12637       include 'COMMON.DERIV'
12638       include 'COMMON.NAMES'
12639       include 'COMMON.INTERACT'
12640       include 'COMMON.IOUNITS'
12641       include 'COMMON.CALC'
12642       include 'COMMON.CONTROL'
12643       include 'COMMON.SPLITELE'
12644       include 'COMMON.SBRIDGE'
12645       double precision tub_r,vectube(3),enetube(maxres*2)
12646       Etube=0.0d0
12647       do i=1,2*nres
12648         enetube(i)=0.0d0
12649       enddo
12650 C first we calculate the distance from tube center
12651 C first sugare-phosphate group for NARES this would be peptide group
12652 C for UNRES
12653       do i=1,nres
12654 C lets ommit dummy atoms for now
12655        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12656 C now calculate distance from center of tube and direction vectors
12657       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12658           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12659       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12660           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12661       vectube(1)=vectube(1)-tubecenter(1)
12662       vectube(2)=vectube(2)-tubecenter(2)
12663
12664 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12665 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12666
12667 C as the tube is infinity we do not calculate the Z-vector use of Z
12668 C as chosen axis
12669       vectube(3)=0.0d0
12670 C now calculte the distance
12671        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12672 C now normalize vector
12673       vectube(1)=vectube(1)/tub_r
12674       vectube(2)=vectube(2)/tub_r
12675 C calculte rdiffrence between r and r0
12676       rdiff=tub_r-tubeR0
12677 C and its 6 power
12678       rdiff6=rdiff**6.0d0
12679 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12680        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12681 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12682 C       print *,rdiff,rdiff6,pep_aa_tube
12683 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12684 C now we calculate gradient
12685        fac=(-12.0d0*pep_aa_tube/rdiff6+
12686      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12687 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12688 C     &rdiff,fac
12689
12690 C now direction of gg_tube vector
12691         do j=1,3
12692         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12693         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12694         enddo
12695         enddo
12696 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12697         do i=1,nres
12698 C Lets not jump over memory as we use many times iti
12699          iti=itype(i)
12700 C lets ommit dummy atoms for now
12701          if ((iti.eq.ntyp1)
12702 C in UNRES uncomment the line below as GLY has no side-chain...
12703 C      .or.(iti.eq.10)
12704      &   ) cycle
12705           vectube(1)=c(1,i+nres)
12706           vectube(1)=mod(vectube(1),boxxsize)
12707           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12708           vectube(2)=c(2,i+nres)
12709           vectube(2)=mod(vectube(2),boxxsize)
12710           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12711
12712       vectube(1)=vectube(1)-tubecenter(1)
12713       vectube(2)=vectube(2)-tubecenter(2)
12714
12715 C as the tube is infinity we do not calculate the Z-vector use of Z
12716 C as chosen axis
12717       vectube(3)=0.0d0
12718 C now calculte the distance
12719        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12720 C now normalize vector
12721       vectube(1)=vectube(1)/tub_r
12722       vectube(2)=vectube(2)/tub_r
12723 C calculte rdiffrence between r and r0
12724       rdiff=tub_r-tubeR0
12725 C and its 6 power
12726       rdiff6=rdiff**6.0d0
12727 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12728        sc_aa_tube=sc_aa_tube_par(iti)
12729        sc_bb_tube=sc_bb_tube_par(iti)
12730        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12731 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12732 C now we calculate gradient
12733        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12734      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12735 C now direction of gg_tube vector
12736          do j=1,3
12737           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12738           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12739          enddo
12740         enddo
12741         do i=1,2*nres
12742           Etube=Etube+enetube(i)
12743         enddo
12744 C        print *,"ETUBE", etube
12745         return
12746         end
12747 C TO DO 1) add to total energy
12748 C       2) add to gradient summation
12749 C       3) add reading parameters (AND of course oppening of PARAM file)
12750 C       4) add reading the center of tube
12751 C       5) add COMMONs
12752 C       6) add to zerograd
12753
12754 C-----------------------------------------------------------------------
12755 C-----------------------------------------------------------
12756 C This subroutine is to mimic the histone like structure but as well can be
12757 C utilizet to nanostructures (infinit) small modification has to be used to
12758 C make it finite (z gradient at the ends has to be changes as well as the x,y
12759 C gradient has to be modified at the ends
12760 C The energy function is Kihara potential
12761 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12762 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12763 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12764 C simple Kihara potential
12765       subroutine calctube2(Etube)
12766        implicit real*8 (a-h,o-z)
12767       include 'DIMENSIONS'
12768       include 'COMMON.GEO'
12769       include 'COMMON.VAR'
12770       include 'COMMON.LOCAL'
12771       include 'COMMON.CHAIN'
12772       include 'COMMON.DERIV'
12773       include 'COMMON.NAMES'
12774       include 'COMMON.INTERACT'
12775       include 'COMMON.IOUNITS'
12776       include 'COMMON.CALC'
12777       include 'COMMON.CONTROL'
12778       include 'COMMON.SPLITELE'
12779       include 'COMMON.SBRIDGE'
12780       double precision tub_r,vectube(3),enetube(maxres*2)
12781       Etube=0.0d0
12782       do i=1,2*nres
12783         enetube(i)=0.0d0
12784       enddo
12785 C first we calculate the distance from tube center
12786 C first sugare-phosphate group for NARES this would be peptide group
12787 C for UNRES
12788       do i=1,nres
12789 C lets ommit dummy atoms for now
12790        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12791 C now calculate distance from center of tube and direction vectors
12792       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12793           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12794       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12795           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12796       vectube(1)=vectube(1)-tubecenter(1)
12797       vectube(2)=vectube(2)-tubecenter(2)
12798
12799 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12800 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12801
12802 C as the tube is infinity we do not calculate the Z-vector use of Z
12803 C as chosen axis
12804       vectube(3)=0.0d0
12805 C now calculte the distance
12806        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12807 C now normalize vector
12808       vectube(1)=vectube(1)/tub_r
12809       vectube(2)=vectube(2)/tub_r
12810 C calculte rdiffrence between r and r0
12811       rdiff=tub_r-tubeR0
12812 C and its 6 power
12813       rdiff6=rdiff**6.0d0
12814 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12815        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12816 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12817 C       print *,rdiff,rdiff6,pep_aa_tube
12818 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12819 C now we calculate gradient
12820        fac=(-12.0d0*pep_aa_tube/rdiff6+
12821      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12822 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12823 C     &rdiff,fac
12824
12825 C now direction of gg_tube vector
12826         do j=1,3
12827         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12828         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12829         enddo
12830         enddo
12831 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12832         do i=1,nres
12833 C Lets not jump over memory as we use many times iti
12834          iti=itype(i)
12835 C lets ommit dummy atoms for now
12836          if ((iti.eq.ntyp1)
12837 C in UNRES uncomment the line below as GLY has no side-chain...
12838      &      .or.(iti.eq.10)
12839      &   ) cycle
12840           vectube(1)=c(1,i+nres)
12841           vectube(1)=mod(vectube(1),boxxsize)
12842           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12843           vectube(2)=c(2,i+nres)
12844           vectube(2)=mod(vectube(2),boxxsize)
12845           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12846
12847       vectube(1)=vectube(1)-tubecenter(1)
12848       vectube(2)=vectube(2)-tubecenter(2)
12849 C THIS FRAGMENT MAKES TUBE FINITE
12850         positi=(mod(c(3,i+nres),boxzsize))
12851         if (positi.le.0) positi=positi+boxzsize
12852 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12853 c for each residue check if it is in lipid or lipid water border area
12854 C       respos=mod(c(3,i+nres),boxzsize)
12855        print *,positi,bordtubebot,buftubebot,bordtubetop
12856        if ((positi.gt.bordtubebot)
12857      & .and.(positi.lt.bordtubetop)) then
12858 C the energy transfer exist
12859         if (positi.lt.buftubebot) then
12860          fracinbuf=1.0d0-
12861      &     ((positi-bordtubebot)/tubebufthick)
12862 C lipbufthick is thickenes of lipid buffore
12863          sstube=sscalelip(fracinbuf)
12864          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12865          print *,ssgradtube, sstube,tubetranene(itype(i))
12866          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12867          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12868      &+ssgradtube*tubetranene(itype(i))
12869          gg_tube(3,i-1)= gg_tube(3,i-1)
12870      &+ssgradtube*tubetranene(itype(i))
12871 C         print *,"doing sccale for lower part"
12872         elseif (positi.gt.buftubetop) then
12873          fracinbuf=1.0d0-
12874      &((bordtubetop-positi)/tubebufthick)
12875          sstube=sscalelip(fracinbuf)
12876          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12877          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12878 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12879 C     &+ssgradtube*tubetranene(itype(i))
12880 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12881 C     &+ssgradtube*tubetranene(itype(i))
12882 C          print *, "doing sscalefor top part",sslip,fracinbuf
12883         else
12884          sstube=1.0d0
12885          ssgradtube=0.0d0
12886          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12887 C         print *,"I am in true lipid"
12888         endif
12889         else
12890 C          sstube=0.0d0
12891 C          ssgradtube=0.0d0
12892         cycle
12893         endif ! if in lipid or buffor
12894 CEND OF FINITE FRAGMENT
12895 C as the tube is infinity we do not calculate the Z-vector use of Z
12896 C as chosen axis
12897       vectube(3)=0.0d0
12898 C now calculte the distance
12899        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12900 C now normalize vector
12901       vectube(1)=vectube(1)/tub_r
12902       vectube(2)=vectube(2)/tub_r
12903 C calculte rdiffrence between r and r0
12904       rdiff=tub_r-tubeR0
12905 C and its 6 power
12906       rdiff6=rdiff**6.0d0
12907 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12908        sc_aa_tube=sc_aa_tube_par(iti)
12909        sc_bb_tube=sc_bb_tube_par(iti)
12910        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12911      &                 *sstube+enetube(i+nres)
12912 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12913 C now we calculate gradient
12914        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12915      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12916 C now direction of gg_tube vector
12917          do j=1,3
12918           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12919           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12920          enddo
12921          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12922      &+ssgradtube*enetube(i+nres)/sstube
12923          gg_tube(3,i-1)= gg_tube(3,i-1)
12924      &+ssgradtube*enetube(i+nres)/sstube
12925
12926         enddo
12927         do i=1,2*nres
12928           Etube=Etube+enetube(i)
12929         enddo
12930 C        print *,"ETUBE", etube
12931         return
12932         end
12933 C TO DO 1) add to total energy
12934 C       2) add to gradient summation
12935 C       3) add reading parameters (AND of course oppening of PARAM file)
12936 C       4) add reading the center of tube
12937 C       5) add COMMONs
12938 C       6) add to zerograd
12939 c----------------------------------------------------------------------------
12940       subroutine e_saxs(Esaxs_constr)
12941       implicit none
12942       include 'DIMENSIONS'
12943 #ifdef MPI
12944       include "mpif.h"
12945       include "COMMON.SETUP"
12946       integer IERR
12947 #endif
12948       include 'COMMON.SBRIDGE'
12949       include 'COMMON.CHAIN'
12950       include 'COMMON.GEO'
12951       include 'COMMON.DERIV'
12952       include 'COMMON.LOCAL'
12953       include 'COMMON.INTERACT'
12954       include 'COMMON.VAR'
12955       include 'COMMON.IOUNITS'
12956       include 'COMMON.MD'
12957       include 'COMMON.CONTROL'
12958       include 'COMMON.NAMES'
12959       include 'COMMON.TIME1'
12960       include 'COMMON.FFIELD'
12961 c
12962       double precision Esaxs_constr
12963       integer i,iint,j,k,l
12964       double precision PgradC(maxSAXS,3,maxres),
12965      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12966 #ifdef MPI
12967       double precision PgradC_(maxSAXS,3,maxres),
12968      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12969 #endif
12970       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12971      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12972      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12973      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12974       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12975       double precision dist,mygauss,mygaussder
12976       external dist
12977       integer llicz,lllicz
12978       double precision time01
12979 c  SAXS restraint penalty function
12980 #ifdef DEBUG
12981       write(iout,*) "------- SAXS penalty function start -------"
12982       write (iout,*) "nsaxs",nsaxs
12983       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12984       write (iout,*) "Psaxs"
12985       do i=1,nsaxs
12986         write (iout,'(i5,e15.5)') i, Psaxs(i)
12987       enddo
12988 #endif
12989 #ifdef TIMING
12990       time01=MPI_Wtime()
12991 #endif
12992       Esaxs_constr = 0.0d0
12993       do k=1,nsaxs
12994         Pcalc(k)=0.0d0
12995         do j=1,nres
12996           do l=1,3
12997             PgradC(k,l,j)=0.0d0
12998             PgradX(k,l,j)=0.0d0
12999           enddo
13000         enddo
13001       enddo
13002 c      lllicz=0
13003       do i=iatsc_s,iatsc_e
13004        if (itype(i).eq.ntyp1) cycle
13005        do iint=1,nint_gr(i)
13006          do j=istart(i,iint),iend(i,iint)
13007            if (itype(j).eq.ntyp1) cycle
13008 #ifdef ALLSAXS
13009            dijCACA=dist(i,j)
13010            dijCASC=dist(i,j+nres)
13011            dijSCCA=dist(i+nres,j)
13012            dijSCSC=dist(i+nres,j+nres)
13013            sigma2CACA=2.0d0/(pstok**2)
13014            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13015            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13016            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13017            do k=1,nsaxs
13018              dk = distsaxs(k)
13019              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13020              if (itype(j).ne.10) then
13021              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13022              else
13023              endif
13024              expCASC = 0.0d0
13025              if (itype(i).ne.10) then
13026              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13027              else
13028              expSCCA = 0.0d0
13029              endif
13030              if (itype(i).ne.10 .and. itype(j).ne.10) then
13031              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13032              else
13033              expSCSC = 0.0d0
13034              endif
13035              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13036 #ifdef DEBUG
13037              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13038 #endif
13039              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13040              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13041              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13042              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13043              do l=1,3
13044 c CA CA
13045                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13046                PgradC(k,l,i) = PgradC(k,l,i)-aux
13047                PgradC(k,l,j) = PgradC(k,l,j)+aux
13048 c CA SC
13049                if (itype(j).ne.10) then
13050                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13051                PgradC(k,l,i) = PgradC(k,l,i)-aux
13052                PgradC(k,l,j) = PgradC(k,l,j)+aux
13053                PgradX(k,l,j) = PgradX(k,l,j)+aux
13054                endif
13055 c SC CA
13056                if (itype(i).ne.10) then
13057                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13058                PgradX(k,l,i) = PgradX(k,l,i)-aux
13059                PgradC(k,l,i) = PgradC(k,l,i)-aux
13060                PgradC(k,l,j) = PgradC(k,l,j)+aux
13061                endif
13062 c SC SC
13063                if (itype(i).ne.10 .and. itype(j).ne.10) then
13064                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13065                PgradC(k,l,i) = PgradC(k,l,i)-aux
13066                PgradC(k,l,j) = PgradC(k,l,j)+aux
13067                PgradX(k,l,i) = PgradX(k,l,i)-aux
13068                PgradX(k,l,j) = PgradX(k,l,j)+aux
13069                endif
13070              enddo ! l
13071            enddo ! k
13072 #else
13073            dijCACA=dist(i,j)
13074            sigma2CACA=scal_rad**2*0.25d0/
13075      &        (restok(itype(j))**2+restok(itype(i))**2)
13076 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13077 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13078 #ifdef MYGAUSS
13079            sigmaCACA=dsqrt(sigma2CACA)
13080            threesig=3.0d0/sigmaCACA
13081 c           llicz=0
13082            do k=1,nsaxs
13083              dk = distsaxs(k)
13084              if (dabs(dijCACA-dk).ge.threesig) cycle
13085 c             llicz=llicz+1
13086 c             lllicz=lllicz+1
13087              aux = sigmaCACA*(dijCACA-dk)
13088              expCACA = mygauss(aux)
13089 c             if (expcaca.eq.0.0d0) cycle
13090              Pcalc(k) = Pcalc(k)+expCACA
13091              CACAgrad = -sigmaCACA*mygaussder(aux)
13092 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13093              do l=1,3
13094                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13095                PgradC(k,l,i) = PgradC(k,l,i)-aux
13096                PgradC(k,l,j) = PgradC(k,l,j)+aux
13097              enddo ! l
13098            enddo ! k
13099 c           write (iout,*) "i",i," j",j," llicz",llicz
13100 #else
13101            IF (saxs_cutoff.eq.0) THEN
13102            do k=1,nsaxs
13103              dk = distsaxs(k)
13104              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13105              Pcalc(k) = Pcalc(k)+expCACA
13106              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13107              do l=1,3
13108                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13109                PgradC(k,l,i) = PgradC(k,l,i)-aux
13110                PgradC(k,l,j) = PgradC(k,l,j)+aux
13111              enddo ! l
13112            enddo ! k
13113            ELSE
13114            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13115            do k=1,nsaxs
13116              dk = distsaxs(k)
13117 c             write (2,*) "ijk",i,j,k
13118              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13119              if (sss2.eq.0.0d0) cycle
13120              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13121              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13122      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13123      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13124      &           sss2,ssgrad2
13125              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13126              Pcalc(k) = Pcalc(k)+expCACA
13127 #ifdef DEBUG
13128              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13129 #endif
13130              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13131      &             ssgrad2*expCACA/sss2
13132              do l=1,3
13133 c CA CA
13134                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13135                PgradC(k,l,i) = PgradC(k,l,i)+aux
13136                PgradC(k,l,j) = PgradC(k,l,j)-aux
13137              enddo ! l
13138            enddo ! k
13139            ENDIF
13140 #endif
13141 #endif
13142          enddo ! j
13143        enddo ! iint
13144       enddo ! i
13145 c#ifdef TIMING
13146 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13147 c#endif
13148 c      write (iout,*) "lllicz",lllicz
13149 c#ifdef TIMING
13150 c      time01=MPI_Wtime()
13151 c#endif
13152 #ifdef MPI
13153       if (nfgtasks.gt.1) then
13154        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13155      &    MPI_SUM,FG_COMM,IERR)
13156 c        if (fg_rank.eq.king) then
13157           do k=1,nsaxs
13158             Pcalc(k) = Pcalc_(k)
13159           enddo
13160 c        endif
13161 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13162 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13163 c        if (fg_rank.eq.king) then
13164 c          do i=1,nres
13165 c            do l=1,3
13166 c              do k=1,nsaxs
13167 c                PgradC(k,l,i) = PgradC_(k,l,i)
13168 c              enddo
13169 c            enddo
13170 c          enddo
13171 c        endif
13172 #ifdef ALLSAXS
13173 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13174 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13175 c        if (fg_rank.eq.king) then
13176 c          do i=1,nres
13177 c            do l=1,3
13178 c              do k=1,nsaxs
13179 c                PgradX(k,l,i) = PgradX_(k,l,i)
13180 c              enddo
13181 c            enddo
13182 c          enddo
13183 c        endif
13184 #endif
13185       endif
13186 #endif
13187       Cnorm = 0.0d0
13188       do k=1,nsaxs
13189         Cnorm = Cnorm + Pcalc(k)
13190       enddo
13191 #ifdef MPI
13192       if (fg_rank.eq.king) then
13193 #endif
13194       Esaxs_constr = dlog(Cnorm)-wsaxs0
13195       do k=1,nsaxs
13196         if (Pcalc(k).gt.0.0d0)
13197      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13198 #ifdef DEBUG
13199         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13200 #endif
13201       enddo
13202 #ifdef DEBUG
13203       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13204 #endif
13205 #ifdef MPI
13206       endif
13207 #endif
13208       gsaxsC=0.0d0
13209       gsaxsX=0.0d0
13210       do i=nnt,nct
13211         do l=1,3
13212           auxC=0.0d0
13213           auxC1=0.0d0
13214           auxX=0.0d0
13215           auxX1=0.d0
13216           do k=1,nsaxs
13217             if (Pcalc(k).gt.0)
13218      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13219             auxC1 = auxC1+PgradC(k,l,i)
13220 #ifdef ALLSAXS
13221             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13222             auxX1 = auxX1+PgradX(k,l,i)
13223 #endif
13224           enddo
13225           gsaxsC(l,i) = auxC - auxC1/Cnorm
13226 #ifdef ALLSAXS
13227           gsaxsX(l,i) = auxX - auxX1/Cnorm
13228 #endif
13229 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13230 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13231 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13232 c     *     " gradX",wsaxs*gsaxsX(l,i)
13233         enddo
13234       enddo
13235 #ifdef TIMING
13236       time_SAXS=time_SAXS+MPI_Wtime()-time01
13237 #endif
13238 #ifdef DEBUG
13239       write (iout,*) "gsaxsc"
13240       do i=nnt,nct
13241         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13242       enddo
13243 #endif
13244 #ifdef MPI
13245 c      endif
13246 #endif
13247       return
13248       end
13249 c----------------------------------------------------------------------------
13250       subroutine e_saxsC(Esaxs_constr)
13251       implicit none
13252       include 'DIMENSIONS'
13253 #ifdef MPI
13254       include "mpif.h"
13255       include "COMMON.SETUP"
13256       integer IERR
13257 #endif
13258       include 'COMMON.SBRIDGE'
13259       include 'COMMON.CHAIN'
13260       include 'COMMON.GEO'
13261       include 'COMMON.DERIV'
13262       include 'COMMON.LOCAL'
13263       include 'COMMON.INTERACT'
13264       include 'COMMON.VAR'
13265       include 'COMMON.IOUNITS'
13266       include 'COMMON.MD'
13267       include 'COMMON.CONTROL'
13268       include 'COMMON.NAMES'
13269       include 'COMMON.TIME1'
13270       include 'COMMON.FFIELD'
13271 c
13272       double precision Esaxs_constr
13273       integer i,iint,j,k,l
13274       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13275 #ifdef MPI
13276       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13277 #endif
13278       double precision dk,dijCASPH,dijSCSPH,
13279      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13280      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13281      & auxX,auxX1,Cnorm
13282 c  SAXS restraint penalty function
13283 #ifdef DEBUG
13284       write(iout,*) "------- SAXS penalty function start -------"
13285       write (iout,*) "nsaxs",nsaxs
13286
13287       do i=nnt,nct
13288         print *,MyRank,"C",i,(C(j,i),j=1,3)
13289       enddo
13290       do i=nnt,nct
13291         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13292       enddo
13293 #endif
13294       Esaxs_constr = 0.0d0
13295       logPtot=0.0d0
13296       do j=isaxs_start,isaxs_end
13297         Pcalc=0.0d0
13298         do i=1,nres
13299           do l=1,3
13300             PgradC(l,i)=0.0d0
13301             PgradX(l,i)=0.0d0
13302           enddo
13303         enddo
13304         do i=nnt,nct
13305           if (itype(i).eq.ntyp1) cycle
13306           dijCASPH=0.0d0
13307           dijSCSPH=0.0d0
13308           do l=1,3
13309             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13310           enddo
13311           if (itype(i).ne.10) then
13312           do l=1,3
13313             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13314           enddo
13315           endif
13316           sigma2CA=2.0d0/pstok**2
13317           sigma2SC=4.0d0/restok(itype(i))**2
13318           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13319           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13320           Pcalc = Pcalc+expCASPH+expSCSPH
13321 #ifdef DEBUG
13322           write(*,*) "processor i j Pcalc",
13323      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13324 #endif
13325           CASPHgrad = sigma2CA*expCASPH
13326           SCSPHgrad = sigma2SC*expSCSPH
13327           do l=1,3
13328             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13329             PgradX(l,i) = PgradX(l,i) + aux
13330             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13331           enddo ! l
13332         enddo ! i
13333         do i=nnt,nct
13334           do l=1,3
13335             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13336             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13337           enddo
13338         enddo
13339         logPtot = logPtot - dlog(Pcalc)
13340 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13341 c     &    " logPtot",logPtot
13342       enddo ! j
13343 #ifdef MPI
13344       if (nfgtasks.gt.1) then
13345 c        write (iout,*) "logPtot before reduction",logPtot
13346         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13347      &    MPI_SUM,king,FG_COMM,IERR)
13348         logPtot = logPtot_
13349 c        write (iout,*) "logPtot after reduction",logPtot
13350         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13351      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13352         if (fg_rank.eq.king) then
13353           do i=1,nres
13354             do l=1,3
13355               gsaxsC(l,i) = gsaxsC_(l,i)
13356             enddo
13357           enddo
13358         endif
13359         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13360      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13361         if (fg_rank.eq.king) then
13362           do i=1,nres
13363             do l=1,3
13364               gsaxsX(l,i) = gsaxsX_(l,i)
13365             enddo
13366           enddo
13367         endif
13368       endif
13369 #endif
13370       Esaxs_constr = logPtot
13371       return
13372       end
13373 c----------------------------------------------------------------------------
13374       double precision function sscale2(r,r_cut,r0,rlamb)
13375       implicit none
13376       double precision r,gamm,r_cut,r0,rlamb,rr
13377       rr = dabs(r-r0)
13378 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13379 c      write (2,*) "rr",rr
13380       if(rr.lt.r_cut-rlamb) then
13381         sscale2=1.0d0
13382       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13383         gamm=(rr-(r_cut-rlamb))/rlamb
13384         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13385       else
13386         sscale2=0d0
13387       endif
13388       return
13389       end
13390 C-----------------------------------------------------------------------
13391       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13392       implicit none
13393       double precision r,gamm,r_cut,r0,rlamb,rr
13394       rr = dabs(r-r0)
13395       if(rr.lt.r_cut-rlamb) then
13396         sscalgrad2=0.0d0
13397       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13398         gamm=(rr-(r_cut-rlamb))/rlamb
13399         if (r.ge.r0) then
13400           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13401         else
13402           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13403         endif
13404       else
13405         sscalgrad2=0.0d0
13406       endif
13407       return
13408       end