source/unres/src_MD-M/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       integer IERR
  14       integer status(MPI_STATUS_SIZE)
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26       include 'COMMON.MD'
  27       include 'COMMON.CONTROL'
  28       include 'COMMON.TIME1'
  29       include 'COMMON.SPLITELE'
  30       include 'COMMON.SHIELD'
  31 #ifdef MPI
  32 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  33 c     & " nfgtasks",nfgtasks
  34       if (nfgtasks.gt.1) then
  35         time00=MPI_Wtime()
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wtube
  62
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wtube=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifdef TIMING
 103       time00=MPI_Wtime()
 104 #endif
 105 C
 106 C Compute the side-chain and electrostatic interaction energy
 107 C
 108 C      print *,ipot
 109       goto (101,102,103,104,105,106) ipot
 110 C Lennard-Jones potential.
 111   101 call elj(evdw)
 112 cd    print '(a)','Exit ELJ'
 113       goto 107
 114 C Lennard-Jones-Kihara potential (shifted).
 115   102 call eljk(evdw)
 116       goto 107
 117 C Berne-Pechukas potential (dilated LJ, angular dependence).
 118   103 call ebp(evdw)
 119       goto 107
 120 C Gay-Berne potential (shifted LJ, angular dependence).
 121   104 call egb(evdw)
 122 C      print *,"bylem w egb"
 123       goto 107
 124 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 125   105 call egbv(evdw)
 126       goto 107
 127 C Soft-sphere potential
 128   106 call e_softsphere(evdw)
 129 C
 130 C Calculate electrostatic (H-bonding) energy of the main chain.
 131 C
 132   107 continue
 133 cmc
 134 cmc Sep-06: egb takes care of dynamic ss bonds too
 135 cmc
 136 c      if (dyn_ss) call dyn_set_nss
 137
 138 c      print *,"Processor",myrank," computed USCSC"
 139 #ifdef TIMING
 140       time01=MPI_Wtime()
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144       time_vec=time_vec+MPI_Wtime()-time01
 145 #endif
 146 C Introduction of shielding effect first for each peptide group
 147 C the shielding factor is set this factor is describing how each
 148 C peptide group is shielded by side-chains
 149 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 150 C      write (iout,*) "shield_mode",shield_mode
 151       if (shield_mode.eq.1) then
 152        call set_shield_fac
 153       else if  (shield_mode.eq.2) then
 154        call set_shield_fac2
 155       if (nfgtasks.gt.1) then
 156 C#define DEBUG
 157 #ifdef DEBUG
 158        write(iout,*) "befor reduce fac_shield reduce"
 159        do i=1,nres
 160         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 161         write(2,*) "list", shield_list(1,i),ishield_list(i),
 162      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 163        enddo
 164 #endif
 165        call MPI_Allgatherv(fac_shield(ivec_start),ivec_count(fg_rank1),
 166      &  MPI_DOUBLE_PRECISION,fac_shield(1),ivec_count(0),ivec_displ(0),
 167      &  MPI_DOUBLE_PRECISION,FG_COMM,IERR)
 168        call MPI_Allgatherv(shield_list(1,ivec_start),
 169      &  ivec_count(fg_rank1),
 170      &  MPI_I50,shield_list(1,1),ivec_count(0),
 171      &  ivec_displ(0),
 172      &  MPI_I50,FG_COMM,IERR)
 173        call MPI_Allgatherv(ishield_list(ivec_start),
 174      &  ivec_count(fg_rank1),
 175      &  MPI_INTEGER,ishield_list(1),ivec_count(0),
 176      &  ivec_displ(0),
 177      &  MPI_INTEGER,FG_COMM,IERR)
 178        call MPI_Allgatherv(grad_shield(1,ivec_start),
 179      &  ivec_count(fg_rank1),
 180      &  MPI_UYZ,grad_shield(1,1),ivec_count(0),
 181      &  ivec_displ(0),
 182      &  MPI_UYZ,FG_COMM,IERR)
 183        call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
 184      &  ivec_count(fg_rank1),
 185      &  MPI_SHI,grad_shield_side(1,1,1),ivec_count(0),
 186      &  ivec_displ(0),
 187      &  MPI_SHI,FG_COMM,IERR)
 188        call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
 189      &  ivec_count(fg_rank1),
 190      &  MPI_SHI,grad_shield_loc(1,1,1),ivec_count(0),
 191      &  ivec_displ(0),
 192      &  MPI_SHI,FG_COMM,IERR)
 193 #ifdef DEBUG
 194        write(iout,*) "after reduce fac_shield reduce"
 195        do i=1,nres
 196         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 197         write(2,*) "list", shield_list(1,i),ishield_list(i),
 198      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 199        enddo
 200 #endif
 201 C#undef DEBUG
 202       endif
 203 #ifdef DEBUG
 204       do i=1,nres
 205       write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
 206         do j=1,ishield_list(i)
 207          write(iout,*) "grad", grad_shield_side(1,j,i),
 208      &   grad_shield_loc(1,j,i)
 209         enddo
 210       enddo
 211 #endif
 212       endif
 213 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 214       if (ipot.lt.6) then
 215 #ifdef SPLITELE
 216          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 217      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 218      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 219      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 220 #else
 221          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 222      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 223      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 224      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 225 #endif
 226             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 227          else
 228             ees=0.0d0
 229             evdw1=0.0d0
 230             eel_loc=0.0d0
 231             eello_turn3=0.0d0
 232             eello_turn4=0.0d0
 233          endif
 234       else
 235         write (iout,*) "Soft-spheer ELEC potential"
 236 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 237 c     &   eello_turn4)
 238       endif
 239 c      print *,"Processor",myrank," computed UELEC"
 240 C
 241 C Calculate excluded-volume interaction energy between peptide groups
 242 C and side chains.
 243 C
 244       if (ipot.lt.6) then
 245        if(wscp.gt.0d0) then
 246         call escp(evdw2,evdw2_14)
 247        else
 248         evdw2=0
 249         evdw2_14=0
 250        endif
 251       else
 252 c        write (iout,*) "Soft-sphere SCP potential"
 253         call escp_soft_sphere(evdw2,evdw2_14)
 254       endif
 255 c
 256 c Calculate the bond-stretching energy
 257 c
 258       call ebond(estr)
 259 C
 260 C Calculate the disulfide-bridge and other energy and the contributions
 261 C from other distance constraints.
 262 cd    print *,'Calling EHPB'
 263       call edis(ehpb)
 264 cd    print *,'EHPB exitted succesfully.'
 265 C
 266 C Calculate the virtual-bond-angle energy.
 267 C
 268       if (wang.gt.0d0) then
 269        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 270         call ebend(ebe,ethetacnstr)
 271         endif
 272 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 273 C energy function
 274        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 275          call ebend_kcc(ebe,ethetacnstr)
 276         endif
 277       else
 278         ebe=0
 279         ethetacnstr=0
 280       endif
 281 c      print *,"Processor",myrank," computed UB"
 282 C
 283 C Calculate the SC local energy.
 284 C
 285 C      print *,"TU DOCHODZE?"
 286       call esc(escloc)
 287 c      print *,"Processor",myrank," computed USC"
 288 C
 289 C Calculate the virtual-bond torsional energy.
 290 C
 291 cd    print *,'nterm=',nterm
 292 C      print *,"tor",tor_mode
 293       if (wtor.gt.0) then
 294        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 295        call etor(etors,edihcnstr)
 296        endif
 297 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 298 C energy function
 299        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 300        call etor_kcc(etors,edihcnstr)
 301        endif
 302       else
 303        etors=0
 304        edihcnstr=0
 305       endif
 306 c      print *,"Processor",myrank," computed Utor"
 307 C
 308 C 6/23/01 Calculate double-torsional energy
 309 C
 310       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 311        call etor_d(etors_d)
 312       else
 313        etors_d=0
 314       endif
 315 c      print *,"Processor",myrank," computed Utord"
 316 C
 317 C 21/5/07 Calculate local sicdechain correlation energy
 318 C
 319       if (wsccor.gt.0.0d0) then
 320         call eback_sc_corr(esccor)
 321       else
 322         esccor=0.0d0
 323       endif
 324 C      print *,"PRZED MULIt"
 325 c      print *,"Processor",myrank," computed Usccorr"
 326 C
 327 C 12/1/95 Multi-body terms
 328 C
 329       n_corr=0
 330       n_corr1=0
 331       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 332      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 333          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 334 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 335 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 336       else
 337          ecorr=0.0d0
 338          ecorr5=0.0d0
 339          ecorr6=0.0d0
 340          eturn6=0.0d0
 341       endif
 342       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 343          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 344 cd         write (iout,*) "multibody_hb ecorr",ecorr
 345       endif
 346 c      print *,"Processor",myrank," computed Ucorr"
 347 C
 348 C If performing constraint dynamics, call the constraint energy
 349 C  after the equilibration time
 350       if(usampl.and.totT.gt.eq_time) then
 351          call EconstrQ
 352          call Econstr_back
 353       else
 354          Uconst=0.0d0
 355          Uconst_back=0.0d0
 356       endif
 357 C 01/27/2015 added by adasko
 358 C the energy component below is energy transfer into lipid environment
 359 C based on partition function
 360 C      print *,"przed lipidami"
 361       if (wliptran.gt.0) then
 362         call Eliptransfer(eliptran)
 363       else
 364        eliptran=0.0d0
 365       endif
 366 C      print *,"za lipidami"
 367       if (AFMlog.gt.0) then
 368         call AFMforce(Eafmforce)
 369       else if (selfguide.gt.0) then
 370         call AFMvel(Eafmforce)
 371       endif
 372       if (TUBElog.eq.1) then
 373 C      print *,"just before call"
 374         call calctube(Etube)
 375        elseif (TUBElog.eq.2) then
 376         call calctube2(Etube)
 377        else
 378        Etube=0.0d0
 379        endif
 380
 381 #ifdef TIMING
 382       time_enecalc=time_enecalc+MPI_Wtime()-time00
 383 #endif
 384 c      print *,"Processor",myrank," computed Uconstr"
 385 #ifdef TIMING
 386       time00=MPI_Wtime()
 387 #endif
 388 c
 389 C Sum the energies
 390 C
 391       energia(1)=evdw
 392 #ifdef SCP14
 393       energia(2)=evdw2-evdw2_14
 394       energia(18)=evdw2_14
 395 #else
 396       energia(2)=evdw2
 397       energia(18)=0.0d0
 398 #endif
 399 #ifdef SPLITELE
 400       energia(3)=ees
 401       energia(16)=evdw1
 402 #else
 403       energia(3)=ees+evdw1
 404       energia(16)=0.0d0
 405 #endif
 406       energia(4)=ecorr
 407       energia(5)=ecorr5
 408       energia(6)=ecorr6
 409       energia(7)=eel_loc
 410       energia(8)=eello_turn3
 411       energia(9)=eello_turn4
 412       energia(10)=eturn6
 413       energia(11)=ebe
 414       energia(12)=escloc
 415       energia(13)=etors
 416       energia(14)=etors_d
 417       energia(15)=ehpb
 418       energia(19)=edihcnstr
 419       energia(17)=estr
 420       energia(20)=Uconst+Uconst_back
 421       energia(21)=esccor
 422       energia(22)=eliptran
 423       energia(23)=Eafmforce
 424       energia(24)=ethetacnstr
 425       energia(25)=Etube
 426 c    Here are the energies showed per procesor if the are more processors
 427 c    per molecule then we sum it up in sum_energy subroutine
 428 c      print *," Processor",myrank," calls SUM_ENERGY"
 429       call sum_energy(energia,.true.)
 430       if (dyn_ss) call dyn_set_nss
 431 c      print *," Processor",myrank," left SUM_ENERGY"
 432 #ifdef TIMING
 433       time_sumene=time_sumene+MPI_Wtime()-time00
 434 #endif
 435       return
 436       end
 437 c-------------------------------------------------------------------------------
 438       subroutine sum_energy(energia,reduce)
 439       implicit real*8 (a-h,o-z)
 440       include 'DIMENSIONS'
 441 #ifndef ISNAN
 442       external proc_proc
 443 #ifdef WINPGI
 444 cMS$ATTRIBUTES C ::  proc_proc
 445 #endif
 446 #endif
 447 #ifdef MPI
 448       include "mpif.h"
 449 #endif
 450       include 'COMMON.SETUP'
 451       include 'COMMON.IOUNITS'
 452       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 453       include 'COMMON.FFIELD'
 454       include 'COMMON.DERIV'
 455       include 'COMMON.INTERACT'
 456       include 'COMMON.SBRIDGE'
 457       include 'COMMON.CHAIN'
 458       include 'COMMON.VAR'
 459       include 'COMMON.CONTROL'
 460       include 'COMMON.TIME1'
 461       logical reduce
 462 #ifdef MPI
 463       if (nfgtasks.gt.1 .and. reduce) then
 464 #ifdef DEBUG
 465         write (iout,*) "energies before REDUCE"
 466         call enerprint(energia)
 467         call flush(iout)
 468 #endif
 469         do i=0,n_ene
 470           enebuff(i)=energia(i)
 471         enddo
 472         time00=MPI_Wtime()
 473         call MPI_Barrier(FG_COMM,IERR)
 474         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 475         time00=MPI_Wtime()
 476         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 477      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 478 C#ifdef DEBUG
 479         write (iout,*) "energies after REDUCE"
 480         call enerprint(energia)
 481         call flush(iout)
 482 C#endif
 483         time_Reduce=time_Reduce+MPI_Wtime()-time00
 484       endif
 485       if (fg_rank.eq.0) then
 486 #endif
 487       evdw=energia(1)
 488 #ifdef SCP14
 489       evdw2=energia(2)+energia(18)
 490       evdw2_14=energia(18)
 491 #else
 492       evdw2=energia(2)
 493 #endif
 494 #ifdef SPLITELE
 495       ees=energia(3)
 496       evdw1=energia(16)
 497 #else
 498       ees=energia(3)
 499       evdw1=0.0d0
 500 #endif
 501       ecorr=energia(4)
 502       ecorr5=energia(5)
 503       ecorr6=energia(6)
 504       eel_loc=energia(7)
 505       eello_turn3=energia(8)
 506       eello_turn4=energia(9)
 507       eturn6=energia(10)
 508       ebe=energia(11)
 509       escloc=energia(12)
 510       etors=energia(13)
 511       etors_d=energia(14)
 512       ehpb=energia(15)
 513       edihcnstr=energia(19)
 514       estr=energia(17)
 515       Uconst=energia(20)
 516       esccor=energia(21)
 517       eliptran=energia(22)
 518       Eafmforce=energia(23)
 519       ethetacnstr=energia(24)
 520       Etube=energia(25)
 521 #ifdef SPLITELE
 522       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 523      & +wang*ebe+wtor*etors+wscloc*escloc
 524      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 525      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 526      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 527      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 528      & +ethetacnstr+wtube*Etube
 529 #else
 530       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 531      & +wang*ebe+wtor*etors+wscloc*escloc
 532      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 533      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 534      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 535      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 536      & +Eafmforce
 537      & +ethetacnstr+wtube*Etube
 538 #endif
 539       energia(0)=etot
 540 c detecting NaNQ
 541 #ifdef ISNAN
 542 #ifdef AIX
 543       if (isnan(etot).ne.0) energia(0)=1.0d+99
 544 #else
 545       if (isnan(etot)) energia(0)=1.0d+99
 546 #endif
 547 #else
 548       i=0
 549 #ifdef WINPGI
 550       idumm=proc_proc(etot,i)
 551 #else
 552       call proc_proc(etot,i)
 553 #endif
 554       if(i.eq.1)energia(0)=1.0d+99
 555 #endif
 556 #ifdef MPI
 557       endif
 558 #endif
 559       return
 560       end
 561 c-------------------------------------------------------------------------------
 562       subroutine sum_gradient
 563       implicit real*8 (a-h,o-z)
 564       include 'DIMENSIONS'
 565 #ifndef ISNAN
 566       external proc_proc
 567 #ifdef WINPGI
 568 cMS$ATTRIBUTES C ::  proc_proc
 569 #endif
 570 #endif
 571 #ifdef MPI
 572       include 'mpif.h'
 573 #endif
 574       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 575      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 576      & ,gloc_scbuf(3,-1:maxres)
 577       include 'COMMON.SETUP'
 578       include 'COMMON.IOUNITS'
 579       include 'COMMON.FFIELD'
 580       include 'COMMON.DERIV'
 581       include 'COMMON.INTERACT'
 582       include 'COMMON.SBRIDGE'
 583       include 'COMMON.CHAIN'
 584       include 'COMMON.VAR'
 585       include 'COMMON.CONTROL'
 586       include 'COMMON.TIME1'
 587       include 'COMMON.MAXGRAD'
 588       include 'COMMON.SCCOR'
 589 #ifdef TIMING
 590       time01=MPI_Wtime()
 591 #endif
 592 #ifdef DEBUG
 593       write (iout,*) "sum_gradient gvdwc, gvdwx"
 594       do i=1,nres
 595         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 596      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 597       enddo
 598       call flush(iout)
 599 #endif
 600 #ifdef MPI
 601 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 602         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 603      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 604 #endif
 605 C
 606 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 607 C            in virtual-bond-vector coordinates
 608 C
 609 #ifdef DEBUG
 610 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 611 c      do i=1,nres-1
 612 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 613 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 614 c      enddo
 615 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 616 c      do i=1,nres-1
 617 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 618 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 619 c      enddo
 620       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 621       do i=1,nres
 622         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 623      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 624      &   g_corr5_loc(i)
 625       enddo
 626       call flush(iout)
 627 #endif
 628 #ifdef SPLITELE
 629       do i=0,nct
 630         do j=1,3
 631           gradbufc(j,i)=wsc*gvdwc(j,i)+
 632      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 633      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 634      &                wel_loc*gel_loc_long(j,i)+
 635      &                wcorr*gradcorr_long(j,i)+
 636      &                wcorr5*gradcorr5_long(j,i)+
 637      &                wcorr6*gradcorr6_long(j,i)+
 638      &                wturn6*gcorr6_turn_long(j,i)+
 639      &                wstrain*ghpbc(j,i)
 640      &                +wliptran*gliptranc(j,i)
 641      &                +gradafm(j,i)
 642      &                 +welec*gshieldc(j,i)
 643      &                 +wcorr*gshieldc_ec(j,i)
 644      &                 +wturn3*gshieldc_t3(j,i)
 645      &                 +wturn4*gshieldc_t4(j,i)
 646      &                 +wel_loc*gshieldc_ll(j,i)
 647      &                +wtube*gg_tube(j,i)
 648
 649
 650
 651         enddo
 652       enddo
 653 #else
 654       do i=0,nct
 655         do j=1,3
 656           gradbufc(j,i)=wsc*gvdwc(j,i)+
 657      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 658      &                welec*gelc_long(j,i)+
 659      &                wbond*gradb(j,i)+
 660      &                wel_loc*gel_loc_long(j,i)+
 661      &                wcorr*gradcorr_long(j,i)+
 662      &                wcorr5*gradcorr5_long(j,i)+
 663      &                wcorr6*gradcorr6_long(j,i)+
 664      &                wturn6*gcorr6_turn_long(j,i)+
 665      &                wstrain*ghpbc(j,i)
 666      &                +wliptran*gliptranc(j,i)
 667      &                +gradafm(j,i)
 668      &                 +welec*gshieldc(j,i)
 669      &                 +wcorr*gshieldc_ec(j,i)
 670      &                 +wturn4*gshieldc_t4(j,i)
 671      &                 +wel_loc*gshieldc_ll(j,i)
 672      &                +wtube*gg_tube(j,i)
 673
 674
 675
 676         enddo
 677       enddo
 678 #endif
 679 #ifdef MPI
 680       if (nfgtasks.gt.1) then
 681       time00=MPI_Wtime()
 682 #ifdef DEBUG
 683       write (iout,*) "gradbufc before allreduce"
 684       do i=1,nres
 685         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 686       enddo
 687       call flush(iout)
 688 #endif
 689       do i=0,nres
 690         do j=1,3
 691           gradbufc_sum(j,i)=gradbufc(j,i)
 692         enddo
 693       enddo
 694 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 695 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 696 c      time_reduce=time_reduce+MPI_Wtime()-time00
 697 #ifdef DEBUG
 698 c      write (iout,*) "gradbufc_sum after allreduce"
 699 c      do i=1,nres
 700 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 701 c      enddo
 702 c      call flush(iout)
 703 #endif
 704 #ifdef TIMING
 705 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 706 #endif
 707       do i=nnt,nres
 708         do k=1,3
 709           gradbufc(k,i)=0.0d0
 710         enddo
 711       enddo
 712 #ifdef DEBUG
 713       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 714       write (iout,*) (i," jgrad_start",jgrad_start(i),
 715      &                  " jgrad_end  ",jgrad_end(i),
 716      &                  i=igrad_start,igrad_end)
 717 #endif
 718 c
 719 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 720 c do not parallelize this part.
 721 c
 722 c      do i=igrad_start,igrad_end
 723 c        do j=jgrad_start(i),jgrad_end(i)
 724 c          do k=1,3
 725 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 726 c          enddo
 727 c        enddo
 728 c      enddo
 729       do j=1,3
 730         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 731       enddo
 732       do i=nres-2,-1,-1
 733         do j=1,3
 734           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 735         enddo
 736       enddo
 737 #ifdef DEBUG
 738       write (iout,*) "gradbufc after summing"
 739       do i=1,nres
 740         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 741       enddo
 742       call flush(iout)
 743 #endif
 744       else
 745 #endif
 746 #ifdef DEBUG
 747       write (iout,*) "gradbufc"
 748       do i=1,nres
 749         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 750       enddo
 751       call flush(iout)
 752 #endif
 753       do i=-1,nres
 754         do j=1,3
 755           gradbufc_sum(j,i)=gradbufc(j,i)
 756           gradbufc(j,i)=0.0d0
 757         enddo
 758       enddo
 759       do j=1,3
 760         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 761       enddo
 762       do i=nres-2,-1,-1
 763         do j=1,3
 764           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 765         enddo
 766       enddo
 767 c      do i=nnt,nres-1
 768 c        do k=1,3
 769 c          gradbufc(k,i)=0.0d0
 770 c        enddo
 771 c        do j=i+1,nres
 772 c          do k=1,3
 773 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 774 c          enddo
 775 c        enddo
 776 c      enddo
 777 #ifdef DEBUG
 778       write (iout,*) "gradbufc after summing"
 779       do i=1,nres
 780         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 781       enddo
 782       call flush(iout)
 783 #endif
 784 #ifdef MPI
 785       endif
 786 #endif
 787       do k=1,3
 788         gradbufc(k,nres)=0.0d0
 789       enddo
 790       do i=-1,nct
 791         do j=1,3
 792 #ifdef SPLITELE
 793 C          print *,gradbufc(1,13)
 794 C          print *,welec*gelc(1,13)
 795 C          print *,wel_loc*gel_loc(1,13)
 796 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 797 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 798 C          print *,wel_loc*gel_loc_long(1,13)
 799 C          print *,gradafm(1,13),"AFM"
 800           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 801      &                wel_loc*gel_loc(j,i)+
 802      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 803      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 804      &                wel_loc*gel_loc_long(j,i)+
 805      &                wcorr*gradcorr_long(j,i)+
 806      &                wcorr5*gradcorr5_long(j,i)+
 807      &                wcorr6*gradcorr6_long(j,i)+
 808      &                wturn6*gcorr6_turn_long(j,i))+
 809      &                wbond*gradb(j,i)+
 810      &                wcorr*gradcorr(j,i)+
 811      &                wturn3*gcorr3_turn(j,i)+
 812      &                wturn4*gcorr4_turn(j,i)+
 813      &                wcorr5*gradcorr5(j,i)+
 814      &                wcorr6*gradcorr6(j,i)+
 815      &                wturn6*gcorr6_turn(j,i)+
 816      &                wsccor*gsccorc(j,i)
 817      &               +wscloc*gscloc(j,i)
 818      &               +wliptran*gliptranc(j,i)
 819      &                +gradafm(j,i)
 820      &                 +welec*gshieldc(j,i)
 821      &                 +welec*gshieldc_loc(j,i)
 822      &                 +wcorr*gshieldc_ec(j,i)
 823      &                 +wcorr*gshieldc_loc_ec(j,i)
 824      &                 +wturn3*gshieldc_t3(j,i)
 825      &                 +wturn3*gshieldc_loc_t3(j,i)
 826      &                 +wturn4*gshieldc_t4(j,i)
 827      &                 +wturn4*gshieldc_loc_t4(j,i)
 828      &                 +wel_loc*gshieldc_ll(j,i)
 829      &                 +wel_loc*gshieldc_loc_ll(j,i)
 830      &                +wtube*gg_tube(j,i)
 831
 832 #else
 833           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 834      &                wel_loc*gel_loc(j,i)+
 835      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 836      &                welec*gelc_long(j,i)+
 837      &                wel_loc*gel_loc_long(j,i)+
 838      &                wcorr*gcorr_long(j,i)+
 839      &                wcorr5*gradcorr5_long(j,i)+
 840      &                wcorr6*gradcorr6_long(j,i)+
 841      &                wturn6*gcorr6_turn_long(j,i))+
 842      &                wbond*gradb(j,i)+
 843      &                wcorr*gradcorr(j,i)+
 844      &                wturn3*gcorr3_turn(j,i)+
 845      &                wturn4*gcorr4_turn(j,i)+
 846      &                wcorr5*gradcorr5(j,i)+
 847      &                wcorr6*gradcorr6(j,i)+
 848      &                wturn6*gcorr6_turn(j,i)+
 849      &                wsccor*gsccorc(j,i)
 850      &               +wscloc*gscloc(j,i)
 851      &               +wliptran*gliptranc(j,i)
 852      &                +gradafm(j,i)
 853      &                 +welec*gshieldc(j,i)
 854      &                 +welec*gshieldc_loc(j,i)
 855      &                 +wcorr*gshieldc_ec(j,i)
 856      &                 +wcorr*gshieldc_loc_ec(j,i)
 857      &                 +wturn3*gshieldc_t3(j,i)
 858      &                 +wturn3*gshieldc_loc_t3(j,i)
 859      &                 +wturn4*gshieldc_t4(j,i)
 860      &                 +wturn4*gshieldc_loc_t4(j,i)
 861      &                 +wel_loc*gshieldc_ll(j,i)
 862      &                 +wel_loc*gshieldc_loc_ll(j,i)
 863      &                +wtube*gg_tube(j,i)
 864
 865
 866 #endif
 867           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 868      &                  wbond*gradbx(j,i)+
 869      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 870      &                  wsccor*gsccorx(j,i)
 871      &                 +wscloc*gsclocx(j,i)
 872      &                 +wliptran*gliptranx(j,i)
 873      &                 +welec*gshieldx(j,i)
 874      &                 +wcorr*gshieldx_ec(j,i)
 875      &                 +wturn3*gshieldx_t3(j,i)
 876      &                 +wturn4*gshieldx_t4(j,i)
 877      &                 +wel_loc*gshieldx_ll(j,i)
 878      &                 +wtube*gg_tube_sc(j,i)
 879
 880
 881
 882         enddo
 883       enddo
 884 #ifdef DEBUG
 885       write (iout,*) "gloc before adding corr"
 886       do i=1,4*nres
 887         write (iout,*) i,gloc(i,icg)
 888       enddo
 889 #endif
 890       do i=1,nres-3
 891         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 892      &   +wcorr5*g_corr5_loc(i)
 893      &   +wcorr6*g_corr6_loc(i)
 894      &   +wturn4*gel_loc_turn4(i)
 895      &   +wturn3*gel_loc_turn3(i)
 896      &   +wturn6*gel_loc_turn6(i)
 897      &   +wel_loc*gel_loc_loc(i)
 898       enddo
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after adding corr"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905 #ifdef MPI
 906       if (nfgtasks.gt.1) then
 907         do j=1,3
 908           do i=1,nres
 909             gradbufc(j,i)=gradc(j,i,icg)
 910             gradbufx(j,i)=gradx(j,i,icg)
 911           enddo
 912         enddo
 913         do i=1,4*nres
 914           glocbuf(i)=gloc(i,icg)
 915         enddo
 916 c#define DEBUG
 917 #ifdef DEBUG
 918       write (iout,*) "gloc_sc before reduce"
 919       do i=1,nres
 920        do j=1,1
 921         write (iout,*) i,j,gloc_sc(j,i,icg)
 922        enddo
 923       enddo
 924 #endif
 925 c#undef DEBUG
 926         do i=1,nres
 927          do j=1,3
 928           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 929          enddo
 930         enddo
 931         time00=MPI_Wtime()
 932         call MPI_Barrier(FG_COMM,IERR)
 933         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 934         time00=MPI_Wtime()
 935         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 936      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 937         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 938      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 939         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 940      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 941         time_reduce=time_reduce+MPI_Wtime()-time00
 942         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 943      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 944         time_reduce=time_reduce+MPI_Wtime()-time00
 945 c#define DEBUG
 946 #ifdef DEBUG
 947       write (iout,*) "gloc_sc after reduce"
 948       do i=1,nres
 949        do j=1,1
 950         write (iout,*) i,j,gloc_sc(j,i,icg)
 951        enddo
 952       enddo
 953 #endif
 954 c#undef DEBUG
 955 #ifdef DEBUG
 956       write (iout,*) "gloc after reduce"
 957       do i=1,4*nres
 958         write (iout,*) i,gloc(i,icg)
 959       enddo
 960 #endif
 961       endif
 962 #endif
 963       if (gnorm_check) then
 964 c
 965 c Compute the maximum elements of the gradient
 966 c
 967       gvdwc_max=0.0d0
 968       gvdwc_scp_max=0.0d0
 969       gelc_max=0.0d0
 970       gvdwpp_max=0.0d0
 971       gradb_max=0.0d0
 972       ghpbc_max=0.0d0
 973       gradcorr_max=0.0d0
 974       gel_loc_max=0.0d0
 975       gcorr3_turn_max=0.0d0
 976       gcorr4_turn_max=0.0d0
 977       gradcorr5_max=0.0d0
 978       gradcorr6_max=0.0d0
 979       gcorr6_turn_max=0.0d0
 980       gsccorc_max=0.0d0
 981       gscloc_max=0.0d0
 982       gvdwx_max=0.0d0
 983       gradx_scp_max=0.0d0
 984       ghpbx_max=0.0d0
 985       gradxorr_max=0.0d0
 986       gsccorx_max=0.0d0
 987       gsclocx_max=0.0d0
 988       do i=1,nct
 989         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 990         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 991         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 992         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 993      &   gvdwc_scp_max=gvdwc_scp_norm
 994         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 995         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 996         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 997         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 998         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 999         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1000         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1001         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1002         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1003         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1004         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1005         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1006         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1007      &    gcorr3_turn(1,i)))
1008         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1009      &    gcorr3_turn_max=gcorr3_turn_norm
1010         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1011      &    gcorr4_turn(1,i)))
1012         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1013      &    gcorr4_turn_max=gcorr4_turn_norm
1014         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1015         if (gradcorr5_norm.gt.gradcorr5_max)
1016      &    gradcorr5_max=gradcorr5_norm
1017         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1018         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1019         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1020      &    gcorr6_turn(1,i)))
1021         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1022      &    gcorr6_turn_max=gcorr6_turn_norm
1023         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1024         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1025         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1026         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1027         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1028         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1029         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1030         if (gradx_scp_norm.gt.gradx_scp_max)
1031      &    gradx_scp_max=gradx_scp_norm
1032         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1033         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1034         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1035         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1036         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1037         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1038         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1039         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1040       enddo
1041       if (gradout) then
1042 #ifdef AIX
1043         open(istat,file=statname,position="append")
1044 #else
1045         open(istat,file=statname,access="append")
1046 #endif
1047         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1048      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1049      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1050      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1051      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1052      &     gsccorx_max,gsclocx_max
1053         close(istat)
1054         if (gvdwc_max.gt.1.0d4) then
1055           write (iout,*) "gvdwc gvdwx gradb gradbx"
1056           do i=nnt,nct
1057             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1058      &        gradb(j,i),gradbx(j,i),j=1,3)
1059           enddo
1060           call pdbout(0.0d0,'cipiszcze',iout)
1061           call flush(iout)
1062         endif
1063       endif
1064       endif
1065 #ifdef DEBUG
1066       write (iout,*) "gradc gradx gloc"
1067       do i=1,nres
1068         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1069      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1070       enddo
1071 #endif
1072 #ifdef TIMING
1073       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1074 #endif
1075       return
1076       end
1077 c-------------------------------------------------------------------------------
1078       subroutine rescale_weights(t_bath)
1079       implicit real*8 (a-h,o-z)
1080       include 'DIMENSIONS'
1081       include 'COMMON.IOUNITS'
1082       include 'COMMON.FFIELD'
1083       include 'COMMON.SBRIDGE'
1084       include 'COMMON.CONTROL'
1085       double precision kfac /2.4d0/
1086       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1087 c      facT=temp0/t_bath
1088 c      facT=2*temp0/(t_bath+temp0)
1089       if (rescale_mode.eq.0) then
1090         facT=1.0d0
1091         facT2=1.0d0
1092         facT3=1.0d0
1093         facT4=1.0d0
1094         facT5=1.0d0
1095       else if (rescale_mode.eq.1) then
1096         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1097         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1098         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1099         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1100         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1101       else if (rescale_mode.eq.2) then
1102         x=t_bath/temp0
1103         x2=x*x
1104         x3=x2*x
1105         x4=x3*x
1106         x5=x4*x
1107         facT=licznik/dlog(dexp(x)+dexp(-x))
1108         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1109         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1110         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1111         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1112       else
1113         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1114         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1115 #ifdef MPI
1116        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1117 #endif
1118        stop 555
1119       endif
1120       if (shield_mode.gt.0) then
1121        wscp=weights(2)*fact
1122        wsc=weights(1)*fact
1123        wvdwpp=weights(16)*fact
1124       endif
1125       welec=weights(3)*fact
1126       wcorr=weights(4)*fact3
1127       wcorr5=weights(5)*fact4
1128       wcorr6=weights(6)*fact5
1129       wel_loc=weights(7)*fact2
1130       wturn3=weights(8)*fact2
1131       wturn4=weights(9)*fact3
1132       wturn6=weights(10)*fact5
1133       wtor=weights(13)*fact
1134       wtor_d=weights(14)*fact2
1135       wsccor=weights(21)*fact
1136
1137       return
1138       end
1139 C------------------------------------------------------------------------
1140       subroutine enerprint(energia)
1141       implicit real*8 (a-h,o-z)
1142       include 'DIMENSIONS'
1143       include 'COMMON.IOUNITS'
1144       include 'COMMON.FFIELD'
1145       include 'COMMON.SBRIDGE'
1146       include 'COMMON.MD'
1147       double precision energia(0:n_ene)
1148       etot=energia(0)
1149       evdw=energia(1)
1150       evdw2=energia(2)
1151 #ifdef SCP14
1152       evdw2=energia(2)+energia(18)
1153 #else
1154       evdw2=energia(2)
1155 #endif
1156       ees=energia(3)
1157 #ifdef SPLITELE
1158       evdw1=energia(16)
1159 #endif
1160       ecorr=energia(4)
1161       ecorr5=energia(5)
1162       ecorr6=energia(6)
1163       eel_loc=energia(7)
1164       eello_turn3=energia(8)
1165       eello_turn4=energia(9)
1166       eello_turn6=energia(10)
1167       ebe=energia(11)
1168       escloc=energia(12)
1169       etors=energia(13)
1170       etors_d=energia(14)
1171       ehpb=energia(15)
1172       edihcnstr=energia(19)
1173       estr=energia(17)
1174       Uconst=energia(20)
1175       esccor=energia(21)
1176       eliptran=energia(22)
1177       Eafmforce=energia(23)
1178       ethetacnstr=energia(24)
1179       etube=energia(25)
1180 #ifdef SPLITELE
1181       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1182      &  estr,wbond,ebe,wang,
1183      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1184      &  ecorr,wcorr,
1185      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1186      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1187      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1188      &  etube,wtube,
1189      &  etot
1190    10 format (/'Virtual-chain energies:'//
1191      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1192      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1193      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1194      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1195      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1196      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1197      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1198      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1199      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1200      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1201      & ' (SS bridges & dist. cnstr.)'/
1202      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1204      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1205      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1206      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1207      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1208      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1209      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1210      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1211      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1212      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1213      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1214      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1215      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1216      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1217      & 'ETOT=  ',1pE16.6,' (total)')
1218
1219 #else
1220       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1221      &  estr,wbond,ebe,wang,
1222      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1223      &  ecorr,wcorr,
1224      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1225      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1226      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1227      &  etube,wtube,
1228      &  etot
1229    10 format (/'Virtual-chain energies:'//
1230      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1231      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1232      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1233      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1234      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1235      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1236      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1237      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1238      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1239      & ' (SS bridges & dist. cnstr.)'/
1240      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1241      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1242      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1243      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1244      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1245      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1246      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1247      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1248      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1249      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1250      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1251      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1252      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1253      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1254      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1255      & 'ETOT=  ',1pE16.6,' (total)')
1256 #endif
1257       return
1258       end
1259 C-----------------------------------------------------------------------
1260       subroutine elj(evdw)
1261 C
1262 C This subroutine calculates the interaction energy of nonbonded side chains
1263 C assuming the LJ potential of interaction.
1264 C
1265       implicit real*8 (a-h,o-z)
1266       include 'DIMENSIONS'
1267       parameter (accur=1.0d-10)
1268       include 'COMMON.GEO'
1269       include 'COMMON.VAR'
1270       include 'COMMON.LOCAL'
1271       include 'COMMON.CHAIN'
1272       include 'COMMON.DERIV'
1273       include 'COMMON.INTERACT'
1274       include 'COMMON.TORSION'
1275       include 'COMMON.SBRIDGE'
1276       include 'COMMON.NAMES'
1277       include 'COMMON.IOUNITS'
1278       include 'COMMON.CONTACTS'
1279       dimension gg(3)
1280 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1281       evdw=0.0D0
1282       do i=iatsc_s,iatsc_e
1283         itypi=iabs(itype(i))
1284         if (itypi.eq.ntyp1) cycle
1285         itypi1=iabs(itype(i+1))
1286         xi=c(1,nres+i)
1287         yi=c(2,nres+i)
1288         zi=c(3,nres+i)
1289 C Change 12/1/95
1290         num_conti=0
1291 C
1292 C Calculate SC interaction energy.
1293 C
1294         do iint=1,nint_gr(i)
1295 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1296 cd   &                  'iend=',iend(i,iint)
1297           do j=istart(i,iint),iend(i,iint)
1298             itypj=iabs(itype(j))
1299             if (itypj.eq.ntyp1) cycle
1300             xj=c(1,nres+j)-xi
1301             yj=c(2,nres+j)-yi
1302             zj=c(3,nres+j)-zi
1303 C Change 12/1/95 to calculate four-body interactions
1304             rij=xj*xj+yj*yj+zj*zj
1305             rrij=1.0D0/rij
1306 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1307             eps0ij=eps(itypi,itypj)
1308             fac=rrij**expon2
1309 C have you changed here?
1310             e1=fac*fac*aa
1311             e2=fac*bb
1312             evdwij=e1+e2
1313 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1314 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1315 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1316 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1317 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1318 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1319             evdw=evdw+evdwij
1320 C
1321 C Calculate the components of the gradient in DC and X
1322 C
1323             fac=-rrij*(e1+evdwij)
1324             gg(1)=xj*fac
1325             gg(2)=yj*fac
1326             gg(3)=zj*fac
1327             do k=1,3
1328               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1329               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1330               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1331               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1332             enddo
1333 cgrad            do k=i,j-1
1334 cgrad              do l=1,3
1335 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1336 cgrad              enddo
1337 cgrad            enddo
1338 C
1339 C 12/1/95, revised on 5/20/97
1340 C
1341 C Calculate the contact function. The ith column of the array JCONT will
1342 C contain the numbers of atoms that make contacts with the atom I (of numbers
1343 C greater than I). The arrays FACONT and GACONT will contain the values of
1344 C the contact function and its derivative.
1345 C
1346 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1347 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1348 C Uncomment next line, if the correlation interactions are contact function only
1349             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1350               rij=dsqrt(rij)
1351               sigij=sigma(itypi,itypj)
1352               r0ij=rs0(itypi,itypj)
1353 C
1354 C Check whether the SC's are not too far to make a contact.
1355 C
1356               rcut=1.5d0*r0ij
1357               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1358 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1359 C
1360               if (fcont.gt.0.0D0) then
1361 C If the SC-SC distance if close to sigma, apply spline.
1362 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1363 cAdam &             fcont1,fprimcont1)
1364 cAdam           fcont1=1.0d0-fcont1
1365 cAdam           if (fcont1.gt.0.0d0) then
1366 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1367 cAdam             fcont=fcont*fcont1
1368 cAdam           endif
1369 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1370 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1371 cga             do k=1,3
1372 cga               gg(k)=gg(k)*eps0ij
1373 cga             enddo
1374 cga             eps0ij=-evdwij*eps0ij
1375 C Uncomment for AL's type of SC correlation interactions.
1376 cadam           eps0ij=-evdwij
1377                 num_conti=num_conti+1
1378                 jcont(num_conti,i)=j
1379                 facont(num_conti,i)=fcont*eps0ij
1380                 fprimcont=eps0ij*fprimcont/rij
1381                 fcont=expon*fcont
1382 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1383 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1384 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1385 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1386                 gacont(1,num_conti,i)=-fprimcont*xj
1387                 gacont(2,num_conti,i)=-fprimcont*yj
1388                 gacont(3,num_conti,i)=-fprimcont*zj
1389 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1390 cd              write (iout,'(2i3,3f10.5)')
1391 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1392               endif
1393             endif
1394           enddo      ! j
1395         enddo        ! iint
1396 C Change 12/1/95
1397         num_cont(i)=num_conti
1398       enddo          ! i
1399       do i=1,nct
1400         do j=1,3
1401           gvdwc(j,i)=expon*gvdwc(j,i)
1402           gvdwx(j,i)=expon*gvdwx(j,i)
1403         enddo
1404       enddo
1405 C******************************************************************************
1406 C
1407 C                              N O T E !!!
1408 C
1409 C To save time, the factor of EXPON has been extracted from ALL components
1410 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1411 C use!
1412 C
1413 C******************************************************************************
1414       return
1415       end
1416 C-----------------------------------------------------------------------------
1417       subroutine eljk(evdw)
1418 C
1419 C This subroutine calculates the interaction energy of nonbonded side chains
1420 C assuming the LJK potential of interaction.
1421 C
1422       implicit real*8 (a-h,o-z)
1423       include 'DIMENSIONS'
1424       include 'COMMON.GEO'
1425       include 'COMMON.VAR'
1426       include 'COMMON.LOCAL'
1427       include 'COMMON.CHAIN'
1428       include 'COMMON.DERIV'
1429       include 'COMMON.INTERACT'
1430       include 'COMMON.IOUNITS'
1431       include 'COMMON.NAMES'
1432       dimension gg(3)
1433       logical scheck
1434 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1435       evdw=0.0D0
1436       do i=iatsc_s,iatsc_e
1437         itypi=iabs(itype(i))
1438         if (itypi.eq.ntyp1) cycle
1439         itypi1=iabs(itype(i+1))
1440         xi=c(1,nres+i)
1441         yi=c(2,nres+i)
1442         zi=c(3,nres+i)
1443 C
1444 C Calculate SC interaction energy.
1445 C
1446         do iint=1,nint_gr(i)
1447           do j=istart(i,iint),iend(i,iint)
1448             itypj=iabs(itype(j))
1449             if (itypj.eq.ntyp1) cycle
1450             xj=c(1,nres+j)-xi
1451             yj=c(2,nres+j)-yi
1452             zj=c(3,nres+j)-zi
1453             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1454             fac_augm=rrij**expon
1455             e_augm=augm(itypi,itypj)*fac_augm
1456             r_inv_ij=dsqrt(rrij)
1457             rij=1.0D0/r_inv_ij
1458             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1459             fac=r_shift_inv**expon
1460 C have you changed here?
1461             e1=fac*fac*aa
1462             e2=fac*bb
1463             evdwij=e_augm+e1+e2
1464 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1465 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1466 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1467 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1468 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1469 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1470 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1471             evdw=evdw+evdwij
1472 C
1473 C Calculate the components of the gradient in DC and X
1474 C
1475             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1476             gg(1)=xj*fac
1477             gg(2)=yj*fac
1478             gg(3)=zj*fac
1479             do k=1,3
1480               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1481               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1482               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1483               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1484             enddo
1485 cgrad            do k=i,j-1
1486 cgrad              do l=1,3
1487 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1488 cgrad              enddo
1489 cgrad            enddo
1490           enddo      ! j
1491         enddo        ! iint
1492       enddo          ! i
1493       do i=1,nct
1494         do j=1,3
1495           gvdwc(j,i)=expon*gvdwc(j,i)
1496           gvdwx(j,i)=expon*gvdwx(j,i)
1497         enddo
1498       enddo
1499       return
1500       end
1501 C-----------------------------------------------------------------------------
1502       subroutine ebp(evdw)
1503 C
1504 C This subroutine calculates the interaction energy of nonbonded side chains
1505 C assuming the Berne-Pechukas potential of interaction.
1506 C
1507       implicit real*8 (a-h,o-z)
1508       include 'DIMENSIONS'
1509       include 'COMMON.GEO'
1510       include 'COMMON.VAR'
1511       include 'COMMON.LOCAL'
1512       include 'COMMON.CHAIN'
1513       include 'COMMON.DERIV'
1514       include 'COMMON.NAMES'
1515       include 'COMMON.INTERACT'
1516       include 'COMMON.IOUNITS'
1517       include 'COMMON.CALC'
1518       common /srutu/ icall
1519 c     double precision rrsave(maxdim)
1520       logical lprn
1521       evdw=0.0D0
1522 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1523       evdw=0.0D0
1524 c     if (icall.eq.0) then
1525 c       lprn=.true.
1526 c     else
1527         lprn=.false.
1528 c     endif
1529       ind=0
1530       do i=iatsc_s,iatsc_e
1531         itypi=iabs(itype(i))
1532         if (itypi.eq.ntyp1) cycle
1533         itypi1=iabs(itype(i+1))
1534         xi=c(1,nres+i)
1535         yi=c(2,nres+i)
1536         zi=c(3,nres+i)
1537         dxi=dc_norm(1,nres+i)
1538         dyi=dc_norm(2,nres+i)
1539         dzi=dc_norm(3,nres+i)
1540 c        dsci_inv=dsc_inv(itypi)
1541         dsci_inv=vbld_inv(i+nres)
1542 C
1543 C Calculate SC interaction energy.
1544 C
1545         do iint=1,nint_gr(i)
1546           do j=istart(i,iint),iend(i,iint)
1547             ind=ind+1
1548             itypj=iabs(itype(j))
1549             if (itypj.eq.ntyp1) cycle
1550 c            dscj_inv=dsc_inv(itypj)
1551             dscj_inv=vbld_inv(j+nres)
1552             chi1=chi(itypi,itypj)
1553             chi2=chi(itypj,itypi)
1554             chi12=chi1*chi2
1555             chip1=chip(itypi)
1556             chip2=chip(itypj)
1557             chip12=chip1*chip2
1558             alf1=alp(itypi)
1559             alf2=alp(itypj)
1560             alf12=0.5D0*(alf1+alf2)
1561 C For diagnostics only!!!
1562 c           chi1=0.0D0
1563 c           chi2=0.0D0
1564 c           chi12=0.0D0
1565 c           chip1=0.0D0
1566 c           chip2=0.0D0
1567 c           chip12=0.0D0
1568 c           alf1=0.0D0
1569 c           alf2=0.0D0
1570 c           alf12=0.0D0
1571             xj=c(1,nres+j)-xi
1572             yj=c(2,nres+j)-yi
1573             zj=c(3,nres+j)-zi
1574             dxj=dc_norm(1,nres+j)
1575             dyj=dc_norm(2,nres+j)
1576             dzj=dc_norm(3,nres+j)
1577             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1578 cd          if (icall.eq.0) then
1579 cd            rrsave(ind)=rrij
1580 cd          else
1581 cd            rrij=rrsave(ind)
1582 cd          endif
1583             rij=dsqrt(rrij)
1584 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1585             call sc_angular
1586 C Calculate whole angle-dependent part of epsilon and contributions
1587 C to its derivatives
1588 C have you changed here?
1589             fac=(rrij*sigsq)**expon2
1590             e1=fac*fac*aa
1591             e2=fac*bb
1592             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1593             eps2der=evdwij*eps3rt
1594             eps3der=evdwij*eps2rt
1595             evdwij=evdwij*eps2rt*eps3rt
1596             evdw=evdw+evdwij
1597             if (lprn) then
1598             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1599             epsi=bb**2/aa
1600 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1601 cd     &        restyp(itypi),i,restyp(itypj),j,
1602 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1603 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1604 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1605 cd     &        evdwij
1606             endif
1607 C Calculate gradient components.
1608             e1=e1*eps1*eps2rt**2*eps3rt**2
1609             fac=-expon*(e1+evdwij)
1610             sigder=fac/sigsq
1611             fac=rrij*fac
1612 C Calculate radial part of the gradient
1613             gg(1)=xj*fac
1614             gg(2)=yj*fac
1615             gg(3)=zj*fac
1616 C Calculate the angular part of the gradient and sum add the contributions
1617 C to the appropriate components of the Cartesian gradient.
1618             call sc_grad
1619           enddo      ! j
1620         enddo        ! iint
1621       enddo          ! i
1622 c     stop
1623       return
1624       end
1625 C-----------------------------------------------------------------------------
1626       subroutine egb(evdw)
1627 C
1628 C This subroutine calculates the interaction energy of nonbonded side chains
1629 C assuming the Gay-Berne potential of interaction.
1630 C
1631       implicit real*8 (a-h,o-z)
1632       include 'DIMENSIONS'
1633       include 'COMMON.GEO'
1634       include 'COMMON.VAR'
1635       include 'COMMON.LOCAL'
1636       include 'COMMON.CHAIN'
1637       include 'COMMON.DERIV'
1638       include 'COMMON.NAMES'
1639       include 'COMMON.INTERACT'
1640       include 'COMMON.IOUNITS'
1641       include 'COMMON.CALC'
1642       include 'COMMON.CONTROL'
1643       include 'COMMON.SPLITELE'
1644       include 'COMMON.SBRIDGE'
1645       logical lprn
1646       integer xshift,yshift,zshift
1647
1648       evdw=0.0D0
1649 ccccc      energy_dec=.false.
1650 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1651       evdw=0.0D0
1652       lprn=.false.
1653 c     if (icall.eq.0) lprn=.false.
1654       ind=0
1655 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1656 C we have the original box)
1657 C      do xshift=-1,1
1658 C      do yshift=-1,1
1659 C      do zshift=-1,1
1660       do i=iatsc_s,iatsc_e
1661         itypi=iabs(itype(i))
1662         if (itypi.eq.ntyp1) cycle
1663         itypi1=iabs(itype(i+1))
1664         xi=c(1,nres+i)
1665         yi=c(2,nres+i)
1666         zi=c(3,nres+i)
1667 C Return atom into box, boxxsize is size of box in x dimension
1668 c  134   continue
1669 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1670 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1671 C Condition for being inside the proper box
1672 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1673 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1674 c        go to 134
1675 c        endif
1676 c  135   continue
1677 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1678 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1679 C Condition for being inside the proper box
1680 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1681 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1682 c        go to 135
1683 c        endif
1684 c  136   continue
1685 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1686 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1687 C Condition for being inside the proper box
1688 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1689 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1690 c        go to 136
1691 c        endif
1692           xi=mod(xi,boxxsize)
1693           if (xi.lt.0) xi=xi+boxxsize
1694           yi=mod(yi,boxysize)
1695           if (yi.lt.0) yi=yi+boxysize
1696           zi=mod(zi,boxzsize)
1697           if (zi.lt.0) zi=zi+boxzsize
1698 C define scaling factor for lipids
1699
1700 C        if (positi.le.0) positi=positi+boxzsize
1701 C        print *,i
1702 C first for peptide groups
1703 c for each residue check if it is in lipid or lipid water border area
1704        if ((zi.gt.bordlipbot)
1705      &.and.(zi.lt.bordliptop)) then
1706 C the energy transfer exist
1707         if (zi.lt.buflipbot) then
1708 C what fraction I am in
1709          fracinbuf=1.0d0-
1710      &        ((zi-bordlipbot)/lipbufthick)
1711 C lipbufthick is thickenes of lipid buffore
1712          sslipi=sscalelip(fracinbuf)
1713          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1714         elseif (zi.gt.bufliptop) then
1715          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1716          sslipi=sscalelip(fracinbuf)
1717          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1718         else
1719          sslipi=1.0d0
1720          ssgradlipi=0.0
1721         endif
1722        else
1723          sslipi=0.0d0
1724          ssgradlipi=0.0
1725        endif
1726
1727 C          xi=xi+xshift*boxxsize
1728 C          yi=yi+yshift*boxysize
1729 C          zi=zi+zshift*boxzsize
1730
1731         dxi=dc_norm(1,nres+i)
1732         dyi=dc_norm(2,nres+i)
1733         dzi=dc_norm(3,nres+i)
1734 c        dsci_inv=dsc_inv(itypi)
1735         dsci_inv=vbld_inv(i+nres)
1736 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1737 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1738 C
1739 C Calculate SC interaction energy.
1740 C
1741         do iint=1,nint_gr(i)
1742           do j=istart(i,iint),iend(i,iint)
1743             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1744
1745 c              write(iout,*) "PRZED ZWYKLE", evdwij
1746               call dyn_ssbond_ene(i,j,evdwij)
1747 c              write(iout,*) "PO ZWYKLE", evdwij
1748
1749               evdw=evdw+evdwij
1750               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1751      &                        'evdw',i,j,evdwij,' ss'
1752 C triple bond artifac removal
1753              do k=j+1,iend(i,iint)
1754 C search over all next residues
1755               if (dyn_ss_mask(k)) then
1756 C check if they are cysteins
1757 C              write(iout,*) 'k=',k
1758
1759 c              write(iout,*) "PRZED TRI", evdwij
1760                evdwij_przed_tri=evdwij
1761               call triple_ssbond_ene(i,j,k,evdwij)
1762 c               if(evdwij_przed_tri.ne.evdwij) then
1763 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1764 c               endif
1765
1766 c              write(iout,*) "PO TRI", evdwij
1767 C call the energy function that removes the artifical triple disulfide
1768 C bond the soubroutine is located in ssMD.F
1769               evdw=evdw+evdwij
1770               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1771      &                        'evdw',i,j,evdwij,'tss'
1772               endif!dyn_ss_mask(k)
1773              enddo! k
1774             ELSE
1775             ind=ind+1
1776             itypj=iabs(itype(j))
1777             if (itypj.eq.ntyp1) cycle
1778 c            dscj_inv=dsc_inv(itypj)
1779             dscj_inv=vbld_inv(j+nres)
1780 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1781 c     &       1.0d0/vbld(j+nres)
1782 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1783             sig0ij=sigma(itypi,itypj)
1784             chi1=chi(itypi,itypj)
1785             chi2=chi(itypj,itypi)
1786             chi12=chi1*chi2
1787             chip1=chip(itypi)
1788             chip2=chip(itypj)
1789             chip12=chip1*chip2
1790             alf1=alp(itypi)
1791             alf2=alp(itypj)
1792             alf12=0.5D0*(alf1+alf2)
1793 C For diagnostics only!!!
1794 c           chi1=0.0D0
1795 c           chi2=0.0D0
1796 c           chi12=0.0D0
1797 c           chip1=0.0D0
1798 c           chip2=0.0D0
1799 c           chip12=0.0D0
1800 c           alf1=0.0D0
1801 c           alf2=0.0D0
1802 c           alf12=0.0D0
1803             xj=c(1,nres+j)
1804             yj=c(2,nres+j)
1805             zj=c(3,nres+j)
1806 C Return atom J into box the original box
1807 c  137   continue
1808 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1809 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1810 C Condition for being inside the proper box
1811 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1812 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1813 c        go to 137
1814 c        endif
1815 c  138   continue
1816 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1817 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1818 C Condition for being inside the proper box
1819 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1820 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1821 c        go to 138
1822 c        endif
1823 c  139   continue
1824 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1825 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1826 C Condition for being inside the proper box
1827 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1828 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1829 c        go to 139
1830 c        endif
1831           xj=mod(xj,boxxsize)
1832           if (xj.lt.0) xj=xj+boxxsize
1833           yj=mod(yj,boxysize)
1834           if (yj.lt.0) yj=yj+boxysize
1835           zj=mod(zj,boxzsize)
1836           if (zj.lt.0) zj=zj+boxzsize
1837        if ((zj.gt.bordlipbot)
1838      &.and.(zj.lt.bordliptop)) then
1839 C the energy transfer exist
1840         if (zj.lt.buflipbot) then
1841 C what fraction I am in
1842          fracinbuf=1.0d0-
1843      &        ((zj-bordlipbot)/lipbufthick)
1844 C lipbufthick is thickenes of lipid buffore
1845          sslipj=sscalelip(fracinbuf)
1846          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1847         elseif (zj.gt.bufliptop) then
1848          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1849          sslipj=sscalelip(fracinbuf)
1850          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1851         else
1852          sslipj=1.0d0
1853          ssgradlipj=0.0
1854         endif
1855        else
1856          sslipj=0.0d0
1857          ssgradlipj=0.0
1858        endif
1859       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1860      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1861       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1862      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1863 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1864 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1865 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1866 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1867 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1868       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1869       xj_safe=xj
1870       yj_safe=yj
1871       zj_safe=zj
1872       subchap=0
1873       do xshift=-1,1
1874       do yshift=-1,1
1875       do zshift=-1,1
1876           xj=xj_safe+xshift*boxxsize
1877           yj=yj_safe+yshift*boxysize
1878           zj=zj_safe+zshift*boxzsize
1879           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1880           if(dist_temp.lt.dist_init) then
1881             dist_init=dist_temp
1882             xj_temp=xj
1883             yj_temp=yj
1884             zj_temp=zj
1885             subchap=1
1886           endif
1887        enddo
1888        enddo
1889        enddo
1890        if (subchap.eq.1) then
1891           xj=xj_temp-xi
1892           yj=yj_temp-yi
1893           zj=zj_temp-zi
1894        else
1895           xj=xj_safe-xi
1896           yj=yj_safe-yi
1897           zj=zj_safe-zi
1898        endif
1899             dxj=dc_norm(1,nres+j)
1900             dyj=dc_norm(2,nres+j)
1901             dzj=dc_norm(3,nres+j)
1902 C            xj=xj-xi
1903 C            yj=yj-yi
1904 C            zj=zj-zi
1905 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1906 c            write (iout,*) "j",j," dc_norm",
1907 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1908             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1909             rij=dsqrt(rrij)
1910             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1911             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1912
1913 c            write (iout,'(a7,4f8.3)')
1914 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1915             if (sss.gt.0.0d0) then
1916 C Calculate angle-dependent terms of energy and contributions to their
1917 C derivatives.
1918             call sc_angular
1919             sigsq=1.0D0/sigsq
1920             sig=sig0ij*dsqrt(sigsq)
1921             rij_shift=1.0D0/rij-sig+sig0ij
1922 c for diagnostics; uncomment
1923 c            rij_shift=1.2*sig0ij
1924 C I hate to put IF's in the loops, but here don't have another choice!!!!
1925             if (rij_shift.le.0.0D0) then
1926               evdw=1.0D20
1927 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1928 cd     &        restyp(itypi),i,restyp(itypj),j,
1929 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1930               return
1931             endif
1932             sigder=-sig*sigsq
1933 c---------------------------------------------------------------
1934             rij_shift=1.0D0/rij_shift
1935             fac=rij_shift**expon
1936 C here to start with
1937 C            if (c(i,3).gt.
1938             faclip=fac
1939             e1=fac*fac*aa
1940             e2=fac*bb
1941             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1942             eps2der=evdwij*eps3rt
1943             eps3der=evdwij*eps2rt
1944 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1945 C     &((sslipi+sslipj)/2.0d0+
1946 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1947 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1948 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1949             evdwij=evdwij*eps2rt*eps3rt
1950             evdw=evdw+evdwij*sss
1951             if (lprn) then
1952             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1953             epsi=bb**2/aa
1954             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1955      &        restyp(itypi),i,restyp(itypj),j,
1956      &        epsi,sigm,chi1,chi2,chip1,chip2,
1957      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1958      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1959      &        evdwij
1960             endif
1961
1962             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1963      &                        'evdw',i,j,evdwij
1964
1965 C Calculate gradient components.
1966             e1=e1*eps1*eps2rt**2*eps3rt**2
1967             fac=-expon*(e1+evdwij)*rij_shift
1968             sigder=fac*sigder
1969             fac=rij*fac
1970 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1971 c     &      evdwij,fac,sigma(itypi,itypj),expon
1972             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1973 c            fac=0.0d0
1974 C Calculate the radial part of the gradient
1975             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1976      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1977      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1978      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1979             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1980             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1981 C            gg_lipi(3)=0.0d0
1982 C            gg_lipj(3)=0.0d0
1983             gg(1)=xj*fac
1984             gg(2)=yj*fac
1985             gg(3)=zj*fac
1986 C Calculate angular part of the gradient.
1987             call sc_grad
1988             endif
1989             ENDIF    ! dyn_ss
1990           enddo      ! j
1991         enddo        ! iint
1992       enddo          ! i
1993 C      enddo          ! zshift
1994 C      enddo          ! yshift
1995 C      enddo          ! xshift
1996 c      write (iout,*) "Number of loop steps in EGB:",ind
1997 cccc      energy_dec=.false.
1998       return
1999       end
2000 C-----------------------------------------------------------------------------
2001       subroutine egbv(evdw)
2002 C
2003 C This subroutine calculates the interaction energy of nonbonded side chains
2004 C assuming the Gay-Berne-Vorobjev potential of interaction.
2005 C
2006       implicit real*8 (a-h,o-z)
2007       include 'DIMENSIONS'
2008       include 'COMMON.GEO'
2009       include 'COMMON.VAR'
2010       include 'COMMON.LOCAL'
2011       include 'COMMON.CHAIN'
2012       include 'COMMON.DERIV'
2013       include 'COMMON.NAMES'
2014       include 'COMMON.INTERACT'
2015       include 'COMMON.IOUNITS'
2016       include 'COMMON.CALC'
2017       common /srutu/ icall
2018       logical lprn
2019       evdw=0.0D0
2020 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2021       evdw=0.0D0
2022       lprn=.false.
2023 c     if (icall.eq.0) lprn=.true.
2024       ind=0
2025       do i=iatsc_s,iatsc_e
2026         itypi=iabs(itype(i))
2027         if (itypi.eq.ntyp1) cycle
2028         itypi1=iabs(itype(i+1))
2029         xi=c(1,nres+i)
2030         yi=c(2,nres+i)
2031         zi=c(3,nres+i)
2032           xi=mod(xi,boxxsize)
2033           if (xi.lt.0) xi=xi+boxxsize
2034           yi=mod(yi,boxysize)
2035           if (yi.lt.0) yi=yi+boxysize
2036           zi=mod(zi,boxzsize)
2037           if (zi.lt.0) zi=zi+boxzsize
2038 C define scaling factor for lipids
2039
2040 C        if (positi.le.0) positi=positi+boxzsize
2041 C        print *,i
2042 C first for peptide groups
2043 c for each residue check if it is in lipid or lipid water border area
2044        if ((zi.gt.bordlipbot)
2045      &.and.(zi.lt.bordliptop)) then
2046 C the energy transfer exist
2047         if (zi.lt.buflipbot) then
2048 C what fraction I am in
2049          fracinbuf=1.0d0-
2050      &        ((zi-bordlipbot)/lipbufthick)
2051 C lipbufthick is thickenes of lipid buffore
2052          sslipi=sscalelip(fracinbuf)
2053          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2054         elseif (zi.gt.bufliptop) then
2055          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2056          sslipi=sscalelip(fracinbuf)
2057          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2058         else
2059          sslipi=1.0d0
2060          ssgradlipi=0.0
2061         endif
2062        else
2063          sslipi=0.0d0
2064          ssgradlipi=0.0
2065        endif
2066
2067         dxi=dc_norm(1,nres+i)
2068         dyi=dc_norm(2,nres+i)
2069         dzi=dc_norm(3,nres+i)
2070 c        dsci_inv=dsc_inv(itypi)
2071         dsci_inv=vbld_inv(i+nres)
2072 C
2073 C Calculate SC interaction energy.
2074 C
2075         do iint=1,nint_gr(i)
2076           do j=istart(i,iint),iend(i,iint)
2077             ind=ind+1
2078             itypj=iabs(itype(j))
2079             if (itypj.eq.ntyp1) cycle
2080 c            dscj_inv=dsc_inv(itypj)
2081             dscj_inv=vbld_inv(j+nres)
2082             sig0ij=sigma(itypi,itypj)
2083             r0ij=r0(itypi,itypj)
2084             chi1=chi(itypi,itypj)
2085             chi2=chi(itypj,itypi)
2086             chi12=chi1*chi2
2087             chip1=chip(itypi)
2088             chip2=chip(itypj)
2089             chip12=chip1*chip2
2090             alf1=alp(itypi)
2091             alf2=alp(itypj)
2092             alf12=0.5D0*(alf1+alf2)
2093 C For diagnostics only!!!
2094 c           chi1=0.0D0
2095 c           chi2=0.0D0
2096 c           chi12=0.0D0
2097 c           chip1=0.0D0
2098 c           chip2=0.0D0
2099 c           chip12=0.0D0
2100 c           alf1=0.0D0
2101 c           alf2=0.0D0
2102 c           alf12=0.0D0
2103 C            xj=c(1,nres+j)-xi
2104 C            yj=c(2,nres+j)-yi
2105 C            zj=c(3,nres+j)-zi
2106           xj=mod(xj,boxxsize)
2107           if (xj.lt.0) xj=xj+boxxsize
2108           yj=mod(yj,boxysize)
2109           if (yj.lt.0) yj=yj+boxysize
2110           zj=mod(zj,boxzsize)
2111           if (zj.lt.0) zj=zj+boxzsize
2112        if ((zj.gt.bordlipbot)
2113      &.and.(zj.lt.bordliptop)) then
2114 C the energy transfer exist
2115         if (zj.lt.buflipbot) then
2116 C what fraction I am in
2117          fracinbuf=1.0d0-
2118      &        ((zj-bordlipbot)/lipbufthick)
2119 C lipbufthick is thickenes of lipid buffore
2120          sslipj=sscalelip(fracinbuf)
2121          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2122         elseif (zj.gt.bufliptop) then
2123          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2124          sslipj=sscalelip(fracinbuf)
2125          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2126         else
2127          sslipj=1.0d0
2128          ssgradlipj=0.0
2129         endif
2130        else
2131          sslipj=0.0d0
2132          ssgradlipj=0.0
2133        endif
2134       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2135      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2136       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2137      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2138 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2139 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2140 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2141       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2142       xj_safe=xj
2143       yj_safe=yj
2144       zj_safe=zj
2145       subchap=0
2146       do xshift=-1,1
2147       do yshift=-1,1
2148       do zshift=-1,1
2149           xj=xj_safe+xshift*boxxsize
2150           yj=yj_safe+yshift*boxysize
2151           zj=zj_safe+zshift*boxzsize
2152           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2153           if(dist_temp.lt.dist_init) then
2154             dist_init=dist_temp
2155             xj_temp=xj
2156             yj_temp=yj
2157             zj_temp=zj
2158             subchap=1
2159           endif
2160        enddo
2161        enddo
2162        enddo
2163        if (subchap.eq.1) then
2164           xj=xj_temp-xi
2165           yj=yj_temp-yi
2166           zj=zj_temp-zi
2167        else
2168           xj=xj_safe-xi
2169           yj=yj_safe-yi
2170           zj=zj_safe-zi
2171        endif
2172             dxj=dc_norm(1,nres+j)
2173             dyj=dc_norm(2,nres+j)
2174             dzj=dc_norm(3,nres+j)
2175             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2176             rij=dsqrt(rrij)
2177 C Calculate angle-dependent terms of energy and contributions to their
2178 C derivatives.
2179             call sc_angular
2180             sigsq=1.0D0/sigsq
2181             sig=sig0ij*dsqrt(sigsq)
2182             rij_shift=1.0D0/rij-sig+r0ij
2183 C I hate to put IF's in the loops, but here don't have another choice!!!!
2184             if (rij_shift.le.0.0D0) then
2185               evdw=1.0D20
2186               return
2187             endif
2188             sigder=-sig*sigsq
2189 c---------------------------------------------------------------
2190             rij_shift=1.0D0/rij_shift
2191             fac=rij_shift**expon
2192             e1=fac*fac*aa
2193             e2=fac*bb
2194             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2195             eps2der=evdwij*eps3rt
2196             eps3der=evdwij*eps2rt
2197             fac_augm=rrij**expon
2198             e_augm=augm(itypi,itypj)*fac_augm
2199             evdwij=evdwij*eps2rt*eps3rt
2200             evdw=evdw+evdwij+e_augm
2201             if (lprn) then
2202             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2203             epsi=bb**2/aa
2204             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2205      &        restyp(itypi),i,restyp(itypj),j,
2206      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2207      &        chi1,chi2,chip1,chip2,
2208      &        eps1,eps2rt**2,eps3rt**2,
2209      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2210      &        evdwij+e_augm
2211             endif
2212 C Calculate gradient components.
2213             e1=e1*eps1*eps2rt**2*eps3rt**2
2214             fac=-expon*(e1+evdwij)*rij_shift
2215             sigder=fac*sigder
2216             fac=rij*fac-2*expon*rrij*e_augm
2217             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2218 C Calculate the radial part of the gradient
2219             gg(1)=xj*fac
2220             gg(2)=yj*fac
2221             gg(3)=zj*fac
2222 C Calculate angular part of the gradient.
2223             call sc_grad
2224           enddo      ! j
2225         enddo        ! iint
2226       enddo          ! i
2227       end
2228 C-----------------------------------------------------------------------------
2229       subroutine sc_angular
2230 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2231 C om12. Called by ebp, egb, and egbv.
2232       implicit none
2233       include 'COMMON.CALC'
2234       include 'COMMON.IOUNITS'
2235       erij(1)=xj*rij
2236       erij(2)=yj*rij
2237       erij(3)=zj*rij
2238       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2239       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2240       om12=dxi*dxj+dyi*dyj+dzi*dzj
2241       chiom12=chi12*om12
2242 C Calculate eps1(om12) and its derivative in om12
2243       faceps1=1.0D0-om12*chiom12
2244       faceps1_inv=1.0D0/faceps1
2245       eps1=dsqrt(faceps1_inv)
2246 C Following variable is eps1*deps1/dom12
2247       eps1_om12=faceps1_inv*chiom12
2248 c diagnostics only
2249 c      faceps1_inv=om12
2250 c      eps1=om12
2251 c      eps1_om12=1.0d0
2252 c      write (iout,*) "om12",om12," eps1",eps1
2253 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2254 C and om12.
2255       om1om2=om1*om2
2256       chiom1=chi1*om1
2257       chiom2=chi2*om2
2258       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2259       sigsq=1.0D0-facsig*faceps1_inv
2260       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2261       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2262       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2263 c diagnostics only
2264 c      sigsq=1.0d0
2265 c      sigsq_om1=0.0d0
2266 c      sigsq_om2=0.0d0
2267 c      sigsq_om12=0.0d0
2268 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2269 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2270 c     &    " eps1",eps1
2271 C Calculate eps2 and its derivatives in om1, om2, and om12.
2272       chipom1=chip1*om1
2273       chipom2=chip2*om2
2274       chipom12=chip12*om12
2275       facp=1.0D0-om12*chipom12
2276       facp_inv=1.0D0/facp
2277       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2278 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2279 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2280 C Following variable is the square root of eps2
2281       eps2rt=1.0D0-facp1*facp_inv
2282 C Following three variables are the derivatives of the square root of eps
2283 C in om1, om2, and om12.
2284       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2285       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2286       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2287 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2288       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2289 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2290 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2291 c     &  " eps2rt_om12",eps2rt_om12
2292 C Calculate whole angle-dependent part of epsilon and contributions
2293 C to its derivatives
2294       return
2295       end
2296 C----------------------------------------------------------------------------
2297       subroutine sc_grad
2298       implicit real*8 (a-h,o-z)
2299       include 'DIMENSIONS'
2300       include 'COMMON.CHAIN'
2301       include 'COMMON.DERIV'
2302       include 'COMMON.CALC'
2303       include 'COMMON.IOUNITS'
2304       double precision dcosom1(3),dcosom2(3)
2305 cc      print *,'sss=',sss
2306       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2307       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2308       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2309      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2310 c diagnostics only
2311 c      eom1=0.0d0
2312 c      eom2=0.0d0
2313 c      eom12=evdwij*eps1_om12
2314 c end diagnostics
2315 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2316 c     &  " sigder",sigder
2317 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2318 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2319       do k=1,3
2320         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2321         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2322       enddo
2323       do k=1,3
2324         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2325       enddo
2326 c      write (iout,*) "gg",(gg(k),k=1,3)
2327       do k=1,3
2328         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2329      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2330      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2331         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2332      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2333      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2334 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2335 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2336 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2337 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2338       enddo
2339 C
2340 C Calculate the components of the gradient in DC and X
2341 C
2342 cgrad      do k=i,j-1
2343 cgrad        do l=1,3
2344 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2345 cgrad        enddo
2346 cgrad      enddo
2347       do l=1,3
2348         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2349         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2350       enddo
2351       return
2352       end
2353 C-----------------------------------------------------------------------
2354       subroutine e_softsphere(evdw)
2355 C
2356 C This subroutine calculates the interaction energy of nonbonded side chains
2357 C assuming the LJ potential of interaction.
2358 C
2359       implicit real*8 (a-h,o-z)
2360       include 'DIMENSIONS'
2361       parameter (accur=1.0d-10)
2362       include 'COMMON.GEO'
2363       include 'COMMON.VAR'
2364       include 'COMMON.LOCAL'
2365       include 'COMMON.CHAIN'
2366       include 'COMMON.DERIV'
2367       include 'COMMON.INTERACT'
2368       include 'COMMON.TORSION'
2369       include 'COMMON.SBRIDGE'
2370       include 'COMMON.NAMES'
2371       include 'COMMON.IOUNITS'
2372       include 'COMMON.CONTACTS'
2373       dimension gg(3)
2374 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2375       evdw=0.0D0
2376       do i=iatsc_s,iatsc_e
2377         itypi=iabs(itype(i))
2378         if (itypi.eq.ntyp1) cycle
2379         itypi1=iabs(itype(i+1))
2380         xi=c(1,nres+i)
2381         yi=c(2,nres+i)
2382         zi=c(3,nres+i)
2383 C
2384 C Calculate SC interaction energy.
2385 C
2386         do iint=1,nint_gr(i)
2387 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2388 cd   &                  'iend=',iend(i,iint)
2389           do j=istart(i,iint),iend(i,iint)
2390             itypj=iabs(itype(j))
2391             if (itypj.eq.ntyp1) cycle
2392             xj=c(1,nres+j)-xi
2393             yj=c(2,nres+j)-yi
2394             zj=c(3,nres+j)-zi
2395             rij=xj*xj+yj*yj+zj*zj
2396 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2397             r0ij=r0(itypi,itypj)
2398             r0ijsq=r0ij*r0ij
2399 c            print *,i,j,r0ij,dsqrt(rij)
2400             if (rij.lt.r0ijsq) then
2401               evdwij=0.25d0*(rij-r0ijsq)**2
2402               fac=rij-r0ijsq
2403             else
2404               evdwij=0.0d0
2405               fac=0.0d0
2406             endif
2407             evdw=evdw+evdwij
2408 C
2409 C Calculate the components of the gradient in DC and X
2410 C
2411             gg(1)=xj*fac
2412             gg(2)=yj*fac
2413             gg(3)=zj*fac
2414             do k=1,3
2415               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2416               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2417               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2418               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2419             enddo
2420 cgrad            do k=i,j-1
2421 cgrad              do l=1,3
2422 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2423 cgrad              enddo
2424 cgrad            enddo
2425           enddo ! j
2426         enddo ! iint
2427       enddo ! i
2428       return
2429       end
2430 C--------------------------------------------------------------------------
2431       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2432      &              eello_turn4)
2433 C
2434 C Soft-sphere potential of p-p interaction
2435 C
2436       implicit real*8 (a-h,o-z)
2437       include 'DIMENSIONS'
2438       include 'COMMON.CONTROL'
2439       include 'COMMON.IOUNITS'
2440       include 'COMMON.GEO'
2441       include 'COMMON.VAR'
2442       include 'COMMON.LOCAL'
2443       include 'COMMON.CHAIN'
2444       include 'COMMON.DERIV'
2445       include 'COMMON.INTERACT'
2446       include 'COMMON.CONTACTS'
2447       include 'COMMON.TORSION'
2448       include 'COMMON.VECTORS'
2449       include 'COMMON.FFIELD'
2450       dimension ggg(3)
2451 C      write(iout,*) 'In EELEC_soft_sphere'
2452       ees=0.0D0
2453       evdw1=0.0D0
2454       eel_loc=0.0d0
2455       eello_turn3=0.0d0
2456       eello_turn4=0.0d0
2457       ind=0
2458       do i=iatel_s,iatel_e
2459         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2460         dxi=dc(1,i)
2461         dyi=dc(2,i)
2462         dzi=dc(3,i)
2463         xmedi=c(1,i)+0.5d0*dxi
2464         ymedi=c(2,i)+0.5d0*dyi
2465         zmedi=c(3,i)+0.5d0*dzi
2466           xmedi=mod(xmedi,boxxsize)
2467           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2468           ymedi=mod(ymedi,boxysize)
2469           if (ymedi.lt.0) ymedi=ymedi+boxysize
2470           zmedi=mod(zmedi,boxzsize)
2471           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2472         num_conti=0
2473 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2474         do j=ielstart(i),ielend(i)
2475           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2476           ind=ind+1
2477           iteli=itel(i)
2478           itelj=itel(j)
2479           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2480           r0ij=rpp(iteli,itelj)
2481           r0ijsq=r0ij*r0ij
2482           dxj=dc(1,j)
2483           dyj=dc(2,j)
2484           dzj=dc(3,j)
2485           xj=c(1,j)+0.5D0*dxj
2486           yj=c(2,j)+0.5D0*dyj
2487           zj=c(3,j)+0.5D0*dzj
2488           xj=mod(xj,boxxsize)
2489           if (xj.lt.0) xj=xj+boxxsize
2490           yj=mod(yj,boxysize)
2491           if (yj.lt.0) yj=yj+boxysize
2492           zj=mod(zj,boxzsize)
2493           if (zj.lt.0) zj=zj+boxzsize
2494       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2495       xj_safe=xj
2496       yj_safe=yj
2497       zj_safe=zj
2498       isubchap=0
2499       do xshift=-1,1
2500       do yshift=-1,1
2501       do zshift=-1,1
2502           xj=xj_safe+xshift*boxxsize
2503           yj=yj_safe+yshift*boxysize
2504           zj=zj_safe+zshift*boxzsize
2505           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2506           if(dist_temp.lt.dist_init) then
2507             dist_init=dist_temp
2508             xj_temp=xj
2509             yj_temp=yj
2510             zj_temp=zj
2511             isubchap=1
2512           endif
2513        enddo
2514        enddo
2515        enddo
2516        if (isubchap.eq.1) then
2517           xj=xj_temp-xmedi
2518           yj=yj_temp-ymedi
2519           zj=zj_temp-zmedi
2520        else
2521           xj=xj_safe-xmedi
2522           yj=yj_safe-ymedi
2523           zj=zj_safe-zmedi
2524        endif
2525           rij=xj*xj+yj*yj+zj*zj
2526             sss=sscale(sqrt(rij))
2527             sssgrad=sscagrad(sqrt(rij))
2528           if (rij.lt.r0ijsq) then
2529             evdw1ij=0.25d0*(rij-r0ijsq)**2
2530             fac=rij-r0ijsq
2531           else
2532             evdw1ij=0.0d0
2533             fac=0.0d0
2534           endif
2535           evdw1=evdw1+evdw1ij*sss
2536 C
2537 C Calculate contributions to the Cartesian gradient.
2538 C
2539           ggg(1)=fac*xj*sssgrad
2540           ggg(2)=fac*yj*sssgrad
2541           ggg(3)=fac*zj*sssgrad
2542           do k=1,3
2543             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2544             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2545           enddo
2546 *
2547 * Loop over residues i+1 thru j-1.
2548 *
2549 cgrad          do k=i+1,j-1
2550 cgrad            do l=1,3
2551 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2552 cgrad            enddo
2553 cgrad          enddo
2554         enddo ! j
2555       enddo   ! i
2556 cgrad      do i=nnt,nct-1
2557 cgrad        do k=1,3
2558 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2559 cgrad        enddo
2560 cgrad        do j=i+1,nct-1
2561 cgrad          do k=1,3
2562 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2563 cgrad          enddo
2564 cgrad        enddo
2565 cgrad      enddo
2566       return
2567       end
2568 c------------------------------------------------------------------------------
2569       subroutine vec_and_deriv
2570       implicit real*8 (a-h,o-z)
2571       include 'DIMENSIONS'
2572 #ifdef MPI
2573       include 'mpif.h'
2574 #endif
2575       include 'COMMON.IOUNITS'
2576       include 'COMMON.GEO'
2577       include 'COMMON.VAR'
2578       include 'COMMON.LOCAL'
2579       include 'COMMON.CHAIN'
2580       include 'COMMON.VECTORS'
2581       include 'COMMON.SETUP'
2582       include 'COMMON.TIME1'
2583       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2584 C Compute the local reference systems. For reference system (i), the
2585 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2586 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2587 #ifdef PARVEC
2588       do i=ivec_start,ivec_end
2589 #else
2590       do i=1,nres-1
2591 #endif
2592           if (i.eq.nres-1) then
2593 C Case of the last full residue
2594 C Compute the Z-axis
2595             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2596             costh=dcos(pi-theta(nres))
2597             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2598             do k=1,3
2599               uz(k,i)=fac*uz(k,i)
2600             enddo
2601 C Compute the derivatives of uz
2602             uzder(1,1,1)= 0.0d0
2603             uzder(2,1,1)=-dc_norm(3,i-1)
2604             uzder(3,1,1)= dc_norm(2,i-1)
2605             uzder(1,2,1)= dc_norm(3,i-1)
2606             uzder(2,2,1)= 0.0d0
2607             uzder(3,2,1)=-dc_norm(1,i-1)
2608             uzder(1,3,1)=-dc_norm(2,i-1)
2609             uzder(2,3,1)= dc_norm(1,i-1)
2610             uzder(3,3,1)= 0.0d0
2611             uzder(1,1,2)= 0.0d0
2612             uzder(2,1,2)= dc_norm(3,i)
2613             uzder(3,1,2)=-dc_norm(2,i)
2614             uzder(1,2,2)=-dc_norm(3,i)
2615             uzder(2,2,2)= 0.0d0
2616             uzder(3,2,2)= dc_norm(1,i)
2617             uzder(1,3,2)= dc_norm(2,i)
2618             uzder(2,3,2)=-dc_norm(1,i)
2619             uzder(3,3,2)= 0.0d0
2620 C Compute the Y-axis
2621             facy=fac
2622             do k=1,3
2623               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2624             enddo
2625 C Compute the derivatives of uy
2626             do j=1,3
2627               do k=1,3
2628                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2629      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2630                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2631               enddo
2632               uyder(j,j,1)=uyder(j,j,1)-costh
2633               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2634             enddo
2635             do j=1,2
2636               do k=1,3
2637                 do l=1,3
2638                   uygrad(l,k,j,i)=uyder(l,k,j)
2639                   uzgrad(l,k,j,i)=uzder(l,k,j)
2640                 enddo
2641               enddo
2642             enddo
2643             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2644             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2645             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2646             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2647           else
2648 C Other residues
2649 C Compute the Z-axis
2650             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2651             costh=dcos(pi-theta(i+2))
2652             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2653             do k=1,3
2654               uz(k,i)=fac*uz(k,i)
2655             enddo
2656 C Compute the derivatives of uz
2657             uzder(1,1,1)= 0.0d0
2658             uzder(2,1,1)=-dc_norm(3,i+1)
2659             uzder(3,1,1)= dc_norm(2,i+1)
2660             uzder(1,2,1)= dc_norm(3,i+1)
2661             uzder(2,2,1)= 0.0d0
2662             uzder(3,2,1)=-dc_norm(1,i+1)
2663             uzder(1,3,1)=-dc_norm(2,i+1)
2664             uzder(2,3,1)= dc_norm(1,i+1)
2665             uzder(3,3,1)= 0.0d0
2666             uzder(1,1,2)= 0.0d0
2667             uzder(2,1,2)= dc_norm(3,i)
2668             uzder(3,1,2)=-dc_norm(2,i)
2669             uzder(1,2,2)=-dc_norm(3,i)
2670             uzder(2,2,2)= 0.0d0
2671             uzder(3,2,2)= dc_norm(1,i)
2672             uzder(1,3,2)= dc_norm(2,i)
2673             uzder(2,3,2)=-dc_norm(1,i)
2674             uzder(3,3,2)= 0.0d0
2675 C Compute the Y-axis
2676             facy=fac
2677             do k=1,3
2678               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2679             enddo
2680 C Compute the derivatives of uy
2681             do j=1,3
2682               do k=1,3
2683                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2684      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2685                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2686               enddo
2687               uyder(j,j,1)=uyder(j,j,1)-costh
2688               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2689             enddo
2690             do j=1,2
2691               do k=1,3
2692                 do l=1,3
2693                   uygrad(l,k,j,i)=uyder(l,k,j)
2694                   uzgrad(l,k,j,i)=uzder(l,k,j)
2695                 enddo
2696               enddo
2697             enddo
2698             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2699             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2700             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2701             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2702           endif
2703       enddo
2704       do i=1,nres-1
2705         vbld_inv_temp(1)=vbld_inv(i+1)
2706         if (i.lt.nres-1) then
2707           vbld_inv_temp(2)=vbld_inv(i+2)
2708           else
2709           vbld_inv_temp(2)=vbld_inv(i)
2710           endif
2711         do j=1,2
2712           do k=1,3
2713             do l=1,3
2714               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2715               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2716             enddo
2717           enddo
2718         enddo
2719       enddo
2720 #if defined(PARVEC) && defined(MPI)
2721       if (nfgtasks1.gt.1) then
2722         time00=MPI_Wtime()
2723 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2724 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2725 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2726         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2730      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2731      &   FG_COMM1,IERR)
2732         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2733      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2734      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2735         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2736      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2737      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2738         time_gather=time_gather+MPI_Wtime()-time00
2739       endif
2740 c      if (fg_rank.eq.0) then
2741 c        write (iout,*) "Arrays UY and UZ"
2742 c        do i=1,nres-1
2743 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2744 c     &     (uz(k,i),k=1,3)
2745 c        enddo
2746 c      endif
2747 #endif
2748       return
2749       end
2750 C-----------------------------------------------------------------------------
2751       subroutine check_vecgrad
2752       implicit real*8 (a-h,o-z)
2753       include 'DIMENSIONS'
2754       include 'COMMON.IOUNITS'
2755       include 'COMMON.GEO'
2756       include 'COMMON.VAR'
2757       include 'COMMON.LOCAL'
2758       include 'COMMON.CHAIN'
2759       include 'COMMON.VECTORS'
2760       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2761       dimension uyt(3,maxres),uzt(3,maxres)
2762       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2763       double precision delta /1.0d-7/
2764       call vec_and_deriv
2765 cd      do i=1,nres
2766 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2767 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2768 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2769 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2770 cd     &     (dc_norm(if90,i),if90=1,3)
2771 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2772 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2773 cd          write(iout,'(a)')
2774 cd      enddo
2775       do i=1,nres
2776         do j=1,2
2777           do k=1,3
2778             do l=1,3
2779               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2780               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2781             enddo
2782           enddo
2783         enddo
2784       enddo
2785       call vec_and_deriv
2786       do i=1,nres
2787         do j=1,3
2788           uyt(j,i)=uy(j,i)
2789           uzt(j,i)=uz(j,i)
2790         enddo
2791       enddo
2792       do i=1,nres
2793 cd        write (iout,*) 'i=',i
2794         do k=1,3
2795           erij(k)=dc_norm(k,i)
2796         enddo
2797         do j=1,3
2798           do k=1,3
2799             dc_norm(k,i)=erij(k)
2800           enddo
2801           dc_norm(j,i)=dc_norm(j,i)+delta
2802 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2803 c          do k=1,3
2804 c            dc_norm(k,i)=dc_norm(k,i)/fac
2805 c          enddo
2806 c          write (iout,*) (dc_norm(k,i),k=1,3)
2807 c          write (iout,*) (erij(k),k=1,3)
2808           call vec_and_deriv
2809           do k=1,3
2810             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2811             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2812             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2813             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2814           enddo
2815 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2816 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2817 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2818         enddo
2819         do k=1,3
2820           dc_norm(k,i)=erij(k)
2821         enddo
2822 cd        do k=1,3
2823 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2824 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2825 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2826 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2827 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2828 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2829 cd          write (iout,'(a)')
2830 cd        enddo
2831       enddo
2832       return
2833       end
2834 C--------------------------------------------------------------------------
2835       subroutine set_matrices
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838 #ifdef MPI
2839       include "mpif.h"
2840       include "COMMON.SETUP"
2841       integer IERR
2842       integer status(MPI_STATUS_SIZE)
2843 #endif
2844       include 'COMMON.IOUNITS'
2845       include 'COMMON.GEO'
2846       include 'COMMON.VAR'
2847       include 'COMMON.LOCAL'
2848       include 'COMMON.CHAIN'
2849       include 'COMMON.DERIV'
2850       include 'COMMON.INTERACT'
2851       include 'COMMON.CONTACTS'
2852       include 'COMMON.TORSION'
2853       include 'COMMON.VECTORS'
2854       include 'COMMON.FFIELD'
2855       double precision auxvec(2),auxmat(2,2)
2856 C
2857 C Compute the virtual-bond-torsional-angle dependent quantities needed
2858 C to calculate the el-loc multibody terms of various order.
2859 C
2860 c      write(iout,*) 'nphi=',nphi,nres
2861 #ifdef PARMAT
2862       do i=ivec_start+2,ivec_end+2
2863 #else
2864       do i=3,nres+1
2865 #endif
2866 #ifdef NEWCORR
2867         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2868           iti = itype2loc(itype(i-2))
2869         else
2870           iti=nloctyp
2871         endif
2872 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2873         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2874           iti1 = itype2loc(itype(i-1))
2875         else
2876           iti1=nloctyp
2877         endif
2878 c        write(iout,*),i
2879         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2880      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2881      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2882         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2883      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2884      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2885 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2886 c     &*(cos(theta(i)/2.0)
2887         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2888      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2889      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2890 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2891 c     &*(cos(theta(i)/2.0)
2892         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2893      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2894      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2895 c        if (ggb1(1,i).eq.0.0d0) then
2896 c        write(iout,*) 'i=',i,ggb1(1,i),
2897 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2898 c     &bnew1(2,1,iti)*cos(theta(i)),
2899 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2900 c        endif
2901         b1(2,i-2)=bnew1(1,2,iti)
2902         gtb1(2,i-2)=0.0
2903         b2(2,i-2)=bnew2(1,2,iti)
2904         gtb2(2,i-2)=0.0
2905         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2906         EE(1,2,i-2)=eeold(1,2,iti)
2907         EE(2,1,i-2)=eeold(2,1,iti)
2908         EE(2,2,i-2)=eeold(2,2,iti)
2909         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2910         gtEE(1,2,i-2)=0.0d0
2911         gtEE(2,2,i-2)=0.0d0
2912         gtEE(2,1,i-2)=0.0d0
2913 c        EE(2,2,iti)=0.0d0
2914 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2915 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2916 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2917 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2918        b1tilde(1,i-2)=b1(1,i-2)
2919        b1tilde(2,i-2)=-b1(2,i-2)
2920        b2tilde(1,i-2)=b2(1,i-2)
2921        b2tilde(2,i-2)=-b2(2,i-2)
2922 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2923 c       write(iout,*)  'b1=',b1(1,i-2)
2924 c       write (iout,*) 'theta=', theta(i-1)
2925        enddo
2926 #else
2927         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2928           iti = itype2loc(itype(i-2))
2929         else
2930           iti=nloctyp
2931         endif
2932 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2933         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2934           iti1 = itype2loc(itype(i-1))
2935         else
2936           iti1=nloctyp
2937         endif
2938         b1(1,i-2)=b(3,iti)
2939         b1(2,i-2)=b(5,iti)
2940         b2(1,i-2)=b(2,iti)
2941         b2(2,i-2)=b(4,iti)
2942        b1tilde(1,i-2)=b1(1,i-2)
2943        b1tilde(2,i-2)=-b1(2,i-2)
2944        b2tilde(1,i-2)=b2(1,i-2)
2945        b2tilde(2,i-2)=-b2(2,i-2)
2946         EE(1,2,i-2)=eeold(1,2,iti)
2947         EE(2,1,i-2)=eeold(2,1,iti)
2948         EE(2,2,i-2)=eeold(2,2,iti)
2949         EE(1,1,i-2)=eeold(1,1,iti)
2950       enddo
2951 #endif
2952 #ifdef PARMAT
2953       do i=ivec_start+2,ivec_end+2
2954 #else
2955       do i=3,nres+1
2956 #endif
2957         if (i .lt. nres+1) then
2958           sin1=dsin(phi(i))
2959           cos1=dcos(phi(i))
2960           sintab(i-2)=sin1
2961           costab(i-2)=cos1
2962           obrot(1,i-2)=cos1
2963           obrot(2,i-2)=sin1
2964           sin2=dsin(2*phi(i))
2965           cos2=dcos(2*phi(i))
2966           sintab2(i-2)=sin2
2967           costab2(i-2)=cos2
2968           obrot2(1,i-2)=cos2
2969           obrot2(2,i-2)=sin2
2970           Ug(1,1,i-2)=-cos1
2971           Ug(1,2,i-2)=-sin1
2972           Ug(2,1,i-2)=-sin1
2973           Ug(2,2,i-2)= cos1
2974           Ug2(1,1,i-2)=-cos2
2975           Ug2(1,2,i-2)=-sin2
2976           Ug2(2,1,i-2)=-sin2
2977           Ug2(2,2,i-2)= cos2
2978         else
2979           costab(i-2)=1.0d0
2980           sintab(i-2)=0.0d0
2981           obrot(1,i-2)=1.0d0
2982           obrot(2,i-2)=0.0d0
2983           obrot2(1,i-2)=0.0d0
2984           obrot2(2,i-2)=0.0d0
2985           Ug(1,1,i-2)=1.0d0
2986           Ug(1,2,i-2)=0.0d0
2987           Ug(2,1,i-2)=0.0d0
2988           Ug(2,2,i-2)=1.0d0
2989           Ug2(1,1,i-2)=0.0d0
2990           Ug2(1,2,i-2)=0.0d0
2991           Ug2(2,1,i-2)=0.0d0
2992           Ug2(2,2,i-2)=0.0d0
2993         endif
2994         if (i .gt. 3 .and. i .lt. nres+1) then
2995           obrot_der(1,i-2)=-sin1
2996           obrot_der(2,i-2)= cos1
2997           Ugder(1,1,i-2)= sin1
2998           Ugder(1,2,i-2)=-cos1
2999           Ugder(2,1,i-2)=-cos1
3000           Ugder(2,2,i-2)=-sin1
3001           dwacos2=cos2+cos2
3002           dwasin2=sin2+sin2
3003           obrot2_der(1,i-2)=-dwasin2
3004           obrot2_der(2,i-2)= dwacos2
3005           Ug2der(1,1,i-2)= dwasin2
3006           Ug2der(1,2,i-2)=-dwacos2
3007           Ug2der(2,1,i-2)=-dwacos2
3008           Ug2der(2,2,i-2)=-dwasin2
3009         else
3010           obrot_der(1,i-2)=0.0d0
3011           obrot_der(2,i-2)=0.0d0
3012           Ugder(1,1,i-2)=0.0d0
3013           Ugder(1,2,i-2)=0.0d0
3014           Ugder(2,1,i-2)=0.0d0
3015           Ugder(2,2,i-2)=0.0d0
3016           obrot2_der(1,i-2)=0.0d0
3017           obrot2_der(2,i-2)=0.0d0
3018           Ug2der(1,1,i-2)=0.0d0
3019           Ug2der(1,2,i-2)=0.0d0
3020           Ug2der(2,1,i-2)=0.0d0
3021           Ug2der(2,2,i-2)=0.0d0
3022         endif
3023 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3024         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3025           iti = itype2loc(itype(i-2))
3026         else
3027           iti=nloctyp
3028         endif
3029 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3030         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3031           iti1 = itype2loc(itype(i-1))
3032         else
3033           iti1=nloctyp
3034         endif
3035 cd        write (iout,*) '*******i',i,' iti1',iti
3036 cd        write (iout,*) 'b1',b1(:,iti)
3037 cd        write (iout,*) 'b2',b2(:,iti)
3038 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3039 c        if (i .gt. iatel_s+2) then
3040         if (i .gt. nnt+2) then
3041           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3042 #ifdef NEWCORR
3043           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3044 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3045 #endif
3046 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3047 c     &    EE(1,2,iti),EE(2,2,i)
3048           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3049           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3050 c          write(iout,*) "Macierz EUG",
3051 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3052 c     &    eug(2,2,i-2)
3053           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3054      &    then
3055           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3056           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3057           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3058           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3059           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3060           endif
3061         else
3062           do k=1,2
3063             Ub2(k,i-2)=0.0d0
3064             Ctobr(k,i-2)=0.0d0
3065             Dtobr2(k,i-2)=0.0d0
3066             do l=1,2
3067               EUg(l,k,i-2)=0.0d0
3068               CUg(l,k,i-2)=0.0d0
3069               DUg(l,k,i-2)=0.0d0
3070               DtUg2(l,k,i-2)=0.0d0
3071             enddo
3072           enddo
3073         endif
3074         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3075         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3076         do k=1,2
3077           muder(k,i-2)=Ub2der(k,i-2)
3078         enddo
3079 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3080         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3081           if (itype(i-1).le.ntyp) then
3082             iti1 = itype2loc(itype(i-1))
3083           else
3084             iti1=nloctyp
3085           endif
3086         else
3087           iti1=nloctyp
3088         endif
3089         do k=1,2
3090           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3091         enddo
3092 #ifdef MUOUT
3093         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3094      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3095      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3096      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3097      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3098      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3099 #endif
3100 cd        write (iout,*) 'mu1',mu1(:,i-2)
3101 cd        write (iout,*) 'mu2',mu2(:,i-2)
3102         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3103      &  then
3104         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3105         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3106         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3107         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3108         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3109 C Vectors and matrices dependent on a single virtual-bond dihedral.
3110         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3111         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3112         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3113         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3114         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3115         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3116         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3117         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3118         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3119         endif
3120       enddo
3121 C Matrices dependent on two consecutive virtual-bond dihedrals.
3122 C The order of matrices is from left to right.
3123       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3124      &then
3125 c      do i=max0(ivec_start,2),ivec_end
3126       do i=2,nres-1
3127         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3128         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3129         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3130         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3131         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3132         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3133         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3134         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3135       enddo
3136       endif
3137 #if defined(MPI) && defined(PARMAT)
3138 #ifdef DEBUG
3139 c      if (fg_rank.eq.0) then
3140         write (iout,*) "Arrays UG and UGDER before GATHER"
3141         do i=1,nres-1
3142           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3143      &     ((ug(l,k,i),l=1,2),k=1,2),
3144      &     ((ugder(l,k,i),l=1,2),k=1,2)
3145         enddo
3146         write (iout,*) "Arrays UG2 and UG2DER"
3147         do i=1,nres-1
3148           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3149      &     ((ug2(l,k,i),l=1,2),k=1,2),
3150      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3151         enddo
3152         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3153         do i=1,nres-1
3154           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3155      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3156      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3157         enddo
3158         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3159         do i=1,nres-1
3160           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3161      &     costab(i),sintab(i),costab2(i),sintab2(i)
3162         enddo
3163         write (iout,*) "Array MUDER"
3164         do i=1,nres-1
3165           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3166         enddo
3167 c      endif
3168 #endif
3169       if (nfgtasks.gt.1) then
3170         time00=MPI_Wtime()
3171 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3172 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3173 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3174 #ifdef MATGATHER
3175         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3176      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3177      &   FG_COMM1,IERR)
3178         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3179      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3180      &   FG_COMM1,IERR)
3181         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3182      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3183      &   FG_COMM1,IERR)
3184         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3185      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3186      &   FG_COMM1,IERR)
3187         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3188      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3189      &   FG_COMM1,IERR)
3190         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3191      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3192      &   FG_COMM1,IERR)
3193         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3194      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3195      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3196         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3197      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3198      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3199         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3200      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3201      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3202         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3203      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3204      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3205         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3206      &  then
3207         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3208      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3209      &   FG_COMM1,IERR)
3210         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3211      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3212      &   FG_COMM1,IERR)
3213         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3214      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3215      &   FG_COMM1,IERR)
3216        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3217      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3218      &   FG_COMM1,IERR)
3219         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3220      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3221      &   FG_COMM1,IERR)
3222         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3223      &   ivec_count(fg_rank1),
3224      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3225      &   FG_COMM1,IERR)
3226         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3227      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3228      &   FG_COMM1,IERR)
3229         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3230      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3231      &   FG_COMM1,IERR)
3232         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3233      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3234      &   FG_COMM1,IERR)
3235         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3236      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3237      &   FG_COMM1,IERR)
3238         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3239      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3240      &   FG_COMM1,IERR)
3241         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3242      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3243      &   FG_COMM1,IERR)
3244         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3245      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3246      &   FG_COMM1,IERR)
3247         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3248      &   ivec_count(fg_rank1),
3249      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3250      &   FG_COMM1,IERR)
3251         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3253      &   FG_COMM1,IERR)
3254        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3259      &   FG_COMM1,IERR)
3260        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3261      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3262      &   FG_COMM1,IERR)
3263         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3264      &   ivec_count(fg_rank1),
3265      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3266      &   FG_COMM1,IERR)
3267         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3268      &   ivec_count(fg_rank1),
3269      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3270      &   FG_COMM1,IERR)
3271         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3272      &   ivec_count(fg_rank1),
3273      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3274      &   MPI_MAT2,FG_COMM1,IERR)
3275         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3276      &   ivec_count(fg_rank1),
3277      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3278      &   MPI_MAT2,FG_COMM1,IERR)
3279         endif
3280 #else
3281 c Passes matrix info through the ring
3282       isend=fg_rank1
3283       irecv=fg_rank1-1
3284       if (irecv.lt.0) irecv=nfgtasks1-1
3285       iprev=irecv
3286       inext=fg_rank1+1
3287       if (inext.ge.nfgtasks1) inext=0
3288       do i=1,nfgtasks1-1
3289 c        write (iout,*) "isend",isend," irecv",irecv
3290 c        call flush(iout)
3291         lensend=lentyp(isend)
3292         lenrecv=lentyp(irecv)
3293 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3294 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3295 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3296 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3297 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3298 c        write (iout,*) "Gather ROTAT1"
3299 c        call flush(iout)
3300 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3301 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3302 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3303 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3304 c        write (iout,*) "Gather ROTAT2"
3305 c        call flush(iout)
3306         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3307      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3308      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3309      &   iprev,4400+irecv,FG_COMM,status,IERR)
3310 c        write (iout,*) "Gather ROTAT_OLD"
3311 c        call flush(iout)
3312         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3313      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3314      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3315      &   iprev,5500+irecv,FG_COMM,status,IERR)
3316 c        write (iout,*) "Gather PRECOMP11"
3317 c        call flush(iout)
3318         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3319      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3320      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3321      &   iprev,6600+irecv,FG_COMM,status,IERR)
3322 c        write (iout,*) "Gather PRECOMP12"
3323 c        call flush(iout)
3324         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3325      &  then
3326         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3327      &   MPI_ROTAT2(lensend),inext,7700+isend,
3328      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3329      &   iprev,7700+irecv,FG_COMM,status,IERR)
3330 c        write (iout,*) "Gather PRECOMP21"
3331 c        call flush(iout)
3332         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3333      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3334      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3335      &   iprev,8800+irecv,FG_COMM,status,IERR)
3336 c        write (iout,*) "Gather PRECOMP22"
3337 c        call flush(iout)
3338         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3339      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3340      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3341      &   MPI_PRECOMP23(lenrecv),
3342      &   iprev,9900+irecv,FG_COMM,status,IERR)
3343 c        write (iout,*) "Gather PRECOMP23"
3344 c        call flush(iout)
3345         endif
3346         isend=irecv
3347         irecv=irecv-1
3348         if (irecv.lt.0) irecv=nfgtasks1-1
3349       enddo
3350 #endif
3351         time_gather=time_gather+MPI_Wtime()-time00
3352       endif
3353 #ifdef DEBUG
3354 c      if (fg_rank.eq.0) then
3355         write (iout,*) "Arrays UG and UGDER"
3356         do i=1,nres-1
3357           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3358      &     ((ug(l,k,i),l=1,2),k=1,2),
3359      &     ((ugder(l,k,i),l=1,2),k=1,2)
3360         enddo
3361         write (iout,*) "Arrays UG2 and UG2DER"
3362         do i=1,nres-1
3363           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3364      &     ((ug2(l,k,i),l=1,2),k=1,2),
3365      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3366         enddo
3367         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3368         do i=1,nres-1
3369           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3370      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3371      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3372         enddo
3373         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3374         do i=1,nres-1
3375           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376      &     costab(i),sintab(i),costab2(i),sintab2(i)
3377         enddo
3378         write (iout,*) "Array MUDER"
3379         do i=1,nres-1
3380           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3381         enddo
3382 c      endif
3383 #endif
3384 #endif
3385 cd      do i=1,nres
3386 cd        iti = itype2loc(itype(i))
3387 cd        write (iout,*) i
3388 cd        do j=1,2
3389 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3390 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3391 cd        enddo
3392 cd      enddo
3393       return
3394       end
3395 C--------------------------------------------------------------------------
3396       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3397 C
3398 C This subroutine calculates the average interaction energy and its gradient
3399 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3400 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3401 C The potential depends both on the distance of peptide-group centers and on
3402 C the orientation of the CA-CA virtual bonds.
3403 C
3404       implicit real*8 (a-h,o-z)
3405 #ifdef MPI
3406       include 'mpif.h'
3407 #endif
3408       include 'DIMENSIONS'
3409       include 'COMMON.CONTROL'
3410       include 'COMMON.SETUP'
3411       include 'COMMON.IOUNITS'
3412       include 'COMMON.GEO'
3413       include 'COMMON.VAR'
3414       include 'COMMON.LOCAL'
3415       include 'COMMON.CHAIN'
3416       include 'COMMON.DERIV'
3417       include 'COMMON.INTERACT'
3418       include 'COMMON.CONTACTS'
3419       include 'COMMON.TORSION'
3420       include 'COMMON.VECTORS'
3421       include 'COMMON.FFIELD'
3422       include 'COMMON.TIME1'
3423       include 'COMMON.SPLITELE'
3424       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3425      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3426       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3427      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3428       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3429      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3430      &    num_conti,j1,j2
3431 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3432 #ifdef MOMENT
3433       double precision scal_el /1.0d0/
3434 #else
3435       double precision scal_el /0.5d0/
3436 #endif
3437 C 12/13/98
3438 C 13-go grudnia roku pamietnego...
3439       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3440      &                   0.0d0,1.0d0,0.0d0,
3441      &                   0.0d0,0.0d0,1.0d0/
3442 cd      write(iout,*) 'In EELEC'
3443 cd      do i=1,nloctyp
3444 cd        write(iout,*) 'Type',i
3445 cd        write(iout,*) 'B1',B1(:,i)
3446 cd        write(iout,*) 'B2',B2(:,i)
3447 cd        write(iout,*) 'CC',CC(:,:,i)
3448 cd        write(iout,*) 'DD',DD(:,:,i)
3449 cd        write(iout,*) 'EE',EE(:,:,i)
3450 cd      enddo
3451 cd      call check_vecgrad
3452 cd      stop
3453       if (icheckgrad.eq.1) then
3454         do i=1,nres-1
3455           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3456           do k=1,3
3457             dc_norm(k,i)=dc(k,i)*fac
3458           enddo
3459 c          write (iout,*) 'i',i,' fac',fac
3460         enddo
3461       endif
3462       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3463      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3464      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3465 c        call vec_and_deriv
3466 #ifdef TIMING
3467         time01=MPI_Wtime()
3468 #endif
3469         call set_matrices
3470 #ifdef TIMING
3471         time_mat=time_mat+MPI_Wtime()-time01
3472 #endif
3473       endif
3474 cd      do i=1,nres-1
3475 cd        write (iout,*) 'i=',i
3476 cd        do k=1,3
3477 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3478 cd        enddo
3479 cd        do k=1,3
3480 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3481 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3482 cd        enddo
3483 cd      enddo
3484       t_eelecij=0.0d0
3485       ees=0.0D0
3486       evdw1=0.0D0
3487       eel_loc=0.0d0
3488       eello_turn3=0.0d0
3489       eello_turn4=0.0d0
3490       ind=0
3491       do i=1,nres
3492         num_cont_hb(i)=0
3493       enddo
3494 cd      print '(a)','Enter EELEC'
3495 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3496       do i=1,nres
3497         gel_loc_loc(i)=0.0d0
3498         gcorr_loc(i)=0.0d0
3499       enddo
3500 c
3501 c
3502 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3503 C
3504 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3505 C
3506 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3507       do i=iturn3_start,iturn3_end
3508 c        if (i.le.1) cycle
3509 C        write(iout,*) "tu jest i",i
3510         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3511 C changes suggested by Ana to avoid out of bounds
3512 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3513 c     & .or.((i+4).gt.nres)
3514 c     & .or.((i-1).le.0)
3515 C end of changes by Ana
3516      &  .or. itype(i+2).eq.ntyp1
3517      &  .or. itype(i+3).eq.ntyp1) cycle
3518 C Adam: Instructions below will switch off existing interactions
3519 c        if(i.gt.1)then
3520 c          if(itype(i-1).eq.ntyp1)cycle
3521 c        end if
3522 c        if(i.LT.nres-3)then
3523 c          if (itype(i+4).eq.ntyp1) cycle
3524 c        end if
3525         dxi=dc(1,i)
3526         dyi=dc(2,i)
3527         dzi=dc(3,i)
3528         dx_normi=dc_norm(1,i)
3529         dy_normi=dc_norm(2,i)
3530         dz_normi=dc_norm(3,i)
3531         xmedi=c(1,i)+0.5d0*dxi
3532         ymedi=c(2,i)+0.5d0*dyi
3533         zmedi=c(3,i)+0.5d0*dzi
3534           xmedi=mod(xmedi,boxxsize)
3535           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3536           ymedi=mod(ymedi,boxysize)
3537           if (ymedi.lt.0) ymedi=ymedi+boxysize
3538           zmedi=mod(zmedi,boxzsize)
3539           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3540         num_conti=0
3541         call eelecij(i,i+2,ees,evdw1,eel_loc)
3542         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3543         num_cont_hb(i)=num_conti
3544       enddo
3545       do i=iturn4_start,iturn4_end
3546         if (i.lt.1) cycle
3547         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3548 C changes suggested by Ana to avoid out of bounds
3549 c     & .or.((i+5).gt.nres)
3550 c     & .or.((i-1).le.0)
3551 C end of changes suggested by Ana
3552      &    .or. itype(i+3).eq.ntyp1
3553      &    .or. itype(i+4).eq.ntyp1
3554 c     &    .or. itype(i+5).eq.ntyp1
3555 c     &    .or. itype(i).eq.ntyp1
3556 c     &    .or. itype(i-1).eq.ntyp1
3557      &                             ) cycle
3558         dxi=dc(1,i)
3559         dyi=dc(2,i)
3560         dzi=dc(3,i)
3561         dx_normi=dc_norm(1,i)
3562         dy_normi=dc_norm(2,i)
3563         dz_normi=dc_norm(3,i)
3564         xmedi=c(1,i)+0.5d0*dxi
3565         ymedi=c(2,i)+0.5d0*dyi
3566         zmedi=c(3,i)+0.5d0*dzi
3567 C Return atom into box, boxxsize is size of box in x dimension
3568 c  194   continue
3569 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3570 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3571 C Condition for being inside the proper box
3572 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3573 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3574 c        go to 194
3575 c        endif
3576 c  195   continue
3577 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3578 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3579 C Condition for being inside the proper box
3580 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3581 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3582 c        go to 195
3583 c        endif
3584 c  196   continue
3585 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3586 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3587 C Condition for being inside the proper box
3588 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3589 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3590 c        go to 196
3591 c        endif
3592           xmedi=mod(xmedi,boxxsize)
3593           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3594           ymedi=mod(ymedi,boxysize)
3595           if (ymedi.lt.0) ymedi=ymedi+boxysize
3596           zmedi=mod(zmedi,boxzsize)
3597           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3598
3599         num_conti=num_cont_hb(i)
3600 c        write(iout,*) "JESTEM W PETLI"
3601         call eelecij(i,i+3,ees,evdw1,eel_loc)
3602         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3603      &   call eturn4(i,eello_turn4)
3604         num_cont_hb(i)=num_conti
3605       enddo   ! i
3606 C Loop over all neighbouring boxes
3607 C      do xshift=-1,1
3608 C      do yshift=-1,1
3609 C      do zshift=-1,1
3610 c
3611 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3612 c
3613 CTU KURWA
3614       do i=iatel_s,iatel_e
3615 C        do i=75,75
3616 c        if (i.le.1) cycle
3617         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3618 C changes suggested by Ana to avoid out of bounds
3619 c     & .or.((i+2).gt.nres)
3620 c     & .or.((i-1).le.0)
3621 C end of changes by Ana
3622 c     &  .or. itype(i+2).eq.ntyp1
3623 c     &  .or. itype(i-1).eq.ntyp1
3624      &                ) cycle
3625         dxi=dc(1,i)
3626         dyi=dc(2,i)
3627         dzi=dc(3,i)
3628         dx_normi=dc_norm(1,i)
3629         dy_normi=dc_norm(2,i)
3630         dz_normi=dc_norm(3,i)
3631         xmedi=c(1,i)+0.5d0*dxi
3632         ymedi=c(2,i)+0.5d0*dyi
3633         zmedi=c(3,i)+0.5d0*dzi
3634           xmedi=mod(xmedi,boxxsize)
3635           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3636           ymedi=mod(ymedi,boxysize)
3637           if (ymedi.lt.0) ymedi=ymedi+boxysize
3638           zmedi=mod(zmedi,boxzsize)
3639           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3640 C          xmedi=xmedi+xshift*boxxsize
3641 C          ymedi=ymedi+yshift*boxysize
3642 C          zmedi=zmedi+zshift*boxzsize
3643
3644 C Return tom into box, boxxsize is size of box in x dimension
3645 c  164   continue
3646 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3647 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3648 C Condition for being inside the proper box
3649 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3650 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3651 c        go to 164
3652 c        endif
3653 c  165   continue
3654 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3655 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3656 C Condition for being inside the proper box
3657 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3658 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3659 c        go to 165
3660 c        endif
3661 c  166   continue
3662 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3663 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3664 cC Condition for being inside the proper box
3665 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3666 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3667 c        go to 166
3668 c        endif
3669
3670 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3671         num_conti=num_cont_hb(i)
3672 C I TU KURWA
3673         do j=ielstart(i),ielend(i)
3674 C          do j=16,17
3675 C          write (iout,*) i,j
3676 C         if (j.le.1) cycle
3677           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3678 C changes suggested by Ana to avoid out of bounds
3679 c     & .or.((j+2).gt.nres)
3680 c     & .or.((j-1).le.0)
3681 C end of changes by Ana
3682 c     & .or.itype(j+2).eq.ntyp1
3683 c     & .or.itype(j-1).eq.ntyp1
3684      &) cycle
3685           call eelecij(i,j,ees,evdw1,eel_loc)
3686         enddo ! j
3687         num_cont_hb(i)=num_conti
3688       enddo   ! i
3689 C     enddo   ! zshift
3690 C      enddo   ! yshift
3691 C      enddo   ! xshift
3692
3693 c      write (iout,*) "Number of loop steps in EELEC:",ind
3694 cd      do i=1,nres
3695 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3696 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3697 cd      enddo
3698 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3699 ccc      eel_loc=eel_loc+eello_turn3
3700 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3701       return
3702       end
3703 C-------------------------------------------------------------------------------
3704       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3705       implicit real*8 (a-h,o-z)
3706       include 'DIMENSIONS'
3707 #ifdef MPI
3708       include "mpif.h"
3709 #endif
3710       include 'COMMON.CONTROL'
3711       include 'COMMON.IOUNITS'
3712       include 'COMMON.GEO'
3713       include 'COMMON.VAR'
3714       include 'COMMON.LOCAL'
3715       include 'COMMON.CHAIN'
3716       include 'COMMON.DERIV'
3717       include 'COMMON.INTERACT'
3718       include 'COMMON.CONTACTS'
3719       include 'COMMON.TORSION'
3720       include 'COMMON.VECTORS'
3721       include 'COMMON.FFIELD'
3722       include 'COMMON.TIME1'
3723       include 'COMMON.SPLITELE'
3724       include 'COMMON.SHIELD'
3725       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3726      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3727       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3728      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3729      &    gmuij2(4),gmuji2(4)
3730       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3731      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3732      &    num_conti,j1,j2
3733 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3734 #ifdef MOMENT
3735       double precision scal_el /1.0d0/
3736 #else
3737       double precision scal_el /0.5d0/
3738 #endif
3739 C 12/13/98
3740 C 13-go grudnia roku pamietnego...
3741       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3742      &                   0.0d0,1.0d0,0.0d0,
3743      &                   0.0d0,0.0d0,1.0d0/
3744        integer xshift,yshift,zshift
3745 c          time00=MPI_Wtime()
3746 cd      write (iout,*) "eelecij",i,j
3747 c          ind=ind+1
3748           iteli=itel(i)
3749           itelj=itel(j)
3750           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3751           aaa=app(iteli,itelj)
3752           bbb=bpp(iteli,itelj)
3753           ael6i=ael6(iteli,itelj)
3754           ael3i=ael3(iteli,itelj)
3755           dxj=dc(1,j)
3756           dyj=dc(2,j)
3757           dzj=dc(3,j)
3758           dx_normj=dc_norm(1,j)
3759           dy_normj=dc_norm(2,j)
3760           dz_normj=dc_norm(3,j)
3761 C          xj=c(1,j)+0.5D0*dxj-xmedi
3762 C          yj=c(2,j)+0.5D0*dyj-ymedi
3763 C          zj=c(3,j)+0.5D0*dzj-zmedi
3764           xj=c(1,j)+0.5D0*dxj
3765           yj=c(2,j)+0.5D0*dyj
3766           zj=c(3,j)+0.5D0*dzj
3767           xj=mod(xj,boxxsize)
3768           if (xj.lt.0) xj=xj+boxxsize
3769           yj=mod(yj,boxysize)
3770           if (yj.lt.0) yj=yj+boxysize
3771           zj=mod(zj,boxzsize)
3772           if (zj.lt.0) zj=zj+boxzsize
3773           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3774       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3775       xj_safe=xj
3776       yj_safe=yj
3777       zj_safe=zj
3778       isubchap=0
3779       do xshift=-1,1
3780       do yshift=-1,1
3781       do zshift=-1,1
3782           xj=xj_safe+xshift*boxxsize
3783           yj=yj_safe+yshift*boxysize
3784           zj=zj_safe+zshift*boxzsize
3785           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3786           if(dist_temp.lt.dist_init) then
3787             dist_init=dist_temp
3788             xj_temp=xj
3789             yj_temp=yj
3790             zj_temp=zj
3791             isubchap=1
3792           endif
3793        enddo
3794        enddo
3795        enddo
3796        if (isubchap.eq.1) then
3797           xj=xj_temp-xmedi
3798           yj=yj_temp-ymedi
3799           zj=zj_temp-zmedi
3800        else
3801           xj=xj_safe-xmedi
3802           yj=yj_safe-ymedi
3803           zj=zj_safe-zmedi
3804        endif
3805 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3806 c  174   continue
3807 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3808 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3809 C Condition for being inside the proper box
3810 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3811 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3812 c        go to 174
3813 c        endif
3814 c  175   continue
3815 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3816 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3817 C Condition for being inside the proper box
3818 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3819 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3820 c        go to 175
3821 c        endif
3822 c  176   continue
3823 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3824 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3825 C Condition for being inside the proper box
3826 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3827 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3828 c        go to 176
3829 c        endif
3830 C        endif !endPBC condintion
3831 C        xj=xj-xmedi
3832 C        yj=yj-ymedi
3833 C        zj=zj-zmedi
3834           rij=xj*xj+yj*yj+zj*zj
3835
3836             sss=sscale(sqrt(rij))
3837             sssgrad=sscagrad(sqrt(rij))
3838 c            if (sss.gt.0.0d0) then
3839           rrmij=1.0D0/rij
3840           rij=dsqrt(rij)
3841           rmij=1.0D0/rij
3842           r3ij=rrmij*rmij
3843           r6ij=r3ij*r3ij
3844           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3845           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3846           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3847           fac=cosa-3.0D0*cosb*cosg
3848           ev1=aaa*r6ij*r6ij
3849 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3850           if (j.eq.i+2) ev1=scal_el*ev1
3851           ev2=bbb*r6ij
3852           fac3=ael6i*r6ij
3853           fac4=ael3i*r3ij
3854           evdwij=(ev1+ev2)
3855           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3856           el2=fac4*fac
3857 C MARYSIA
3858 C          eesij=(el1+el2)
3859 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3860           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3861           if (shield_mode.gt.0) then
3862 C          fac_shield(i)=0.4
3863 C          fac_shield(j)=0.6
3864           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3865           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3866           eesij=(el1+el2)
3867           ees=ees+eesij
3868           else
3869           fac_shield(i)=1.0
3870           fac_shield(j)=1.0
3871           eesij=(el1+el2)
3872           ees=ees+eesij
3873           endif
3874           evdw1=evdw1+evdwij*sss
3875 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3876 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3877 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3878 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3879
3880           if (energy_dec) then
3881               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3882      &'evdw1',i,j,evdwij
3883      &,iteli,itelj,aaa,evdw1
3884               write (iout,*) sss
3885               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3886      &fac_shield(i),fac_shield(j)
3887           endif
3888
3889 C
3890 C Calculate contributions to the Cartesian gradient.
3891 C
3892 #ifdef SPLITELE
3893           facvdw=-6*rrmij*(ev1+evdwij)*sss
3894           facel=-3*rrmij*(el1+eesij)
3895           fac1=fac
3896           erij(1)=xj*rmij
3897           erij(2)=yj*rmij
3898           erij(3)=zj*rmij
3899
3900 *
3901 * Radial derivatives. First process both termini of the fragment (i,j)
3902 *
3903           ggg(1)=facel*xj
3904           ggg(2)=facel*yj
3905           ggg(3)=facel*zj
3906           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3907      &  (shield_mode.gt.0)) then
3908 C          print *,i,j
3909           do ilist=1,ishield_list(i)
3910            iresshield=shield_list(ilist,i)
3911            do k=1,3
3912            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3913      &      *2.0
3914            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3915      &              rlocshield
3916      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3917             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3918 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3919 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3920 C             if (iresshield.gt.i) then
3921 C               do ishi=i+1,iresshield-1
3922 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3923 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3924 C
3925 C              enddo
3926 C             else
3927 C               do ishi=iresshield,i
3928 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3929 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3930 C
3931 C               enddo
3932 C              endif
3933            enddo
3934           enddo
3935           do ilist=1,ishield_list(j)
3936            iresshield=shield_list(ilist,j)
3937            do k=1,3
3938            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3939      &     *2.0
3940            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3941      &              rlocshield
3942      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3943            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3944
3945 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3946 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3947 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3948 C             if (iresshield.gt.j) then
3949 C               do ishi=j+1,iresshield-1
3950 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3951 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3952 C
3953 C               enddo
3954 C            else
3955 C               do ishi=iresshield,j
3956 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3957 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3958 C               enddo
3959 C              endif
3960            enddo
3961           enddo
3962
3963           do k=1,3
3964             gshieldc(k,i)=gshieldc(k,i)+
3965      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3966             gshieldc(k,j)=gshieldc(k,j)+
3967      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3968             gshieldc(k,i-1)=gshieldc(k,i-1)+
3969      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3970             gshieldc(k,j-1)=gshieldc(k,j-1)+
3971      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3972
3973            enddo
3974            endif
3975 c          do k=1,3
3976 c            ghalf=0.5D0*ggg(k)
3977 c            gelc(k,i)=gelc(k,i)+ghalf
3978 c            gelc(k,j)=gelc(k,j)+ghalf
3979 c          enddo
3980 c 9/28/08 AL Gradient compotents will be summed only at the end
3981 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3982           do k=1,3
3983             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3984 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3985             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3986 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3987 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3988 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3989 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3990 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3991           enddo
3992 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3993
3994 *
3995 * Loop over residues i+1 thru j-1.
3996 *
3997 cgrad          do k=i+1,j-1
3998 cgrad            do l=1,3
3999 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4000 cgrad            enddo
4001 cgrad          enddo
4002           if (sss.gt.0.0) then
4003           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4004           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4005           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4006           else
4007           ggg(1)=0.0
4008           ggg(2)=0.0
4009           ggg(3)=0.0
4010           endif
4011 c          do k=1,3
4012 c            ghalf=0.5D0*ggg(k)
4013 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4014 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4015 c          enddo
4016 c 9/28/08 AL Gradient compotents will be summed only at the end
4017           do k=1,3
4018             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4019             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4020           enddo
4021 *
4022 * Loop over residues i+1 thru j-1.
4023 *
4024 cgrad          do k=i+1,j-1
4025 cgrad            do l=1,3
4026 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4027 cgrad            enddo
4028 cgrad          enddo
4029 #else
4030 C MARYSIA
4031           facvdw=(ev1+evdwij)*sss
4032           facel=(el1+eesij)
4033           fac1=fac
4034           fac=-3*rrmij*(facvdw+facvdw+facel)
4035           erij(1)=xj*rmij
4036           erij(2)=yj*rmij
4037           erij(3)=zj*rmij
4038 *
4039 * Radial derivatives. First process both termini of the fragment (i,j)
4040 *
4041           ggg(1)=fac*xj
4042 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4043           ggg(2)=fac*yj
4044 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4045           ggg(3)=fac*zj
4046 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4047 c          do k=1,3
4048 c            ghalf=0.5D0*ggg(k)
4049 c            gelc(k,i)=gelc(k,i)+ghalf
4050 c            gelc(k,j)=gelc(k,j)+ghalf
4051 c          enddo
4052 c 9/28/08 AL Gradient compotents will be summed only at the end
4053           do k=1,3
4054             gelc_long(k,j)=gelc(k,j)+ggg(k)
4055             gelc_long(k,i)=gelc(k,i)-ggg(k)
4056           enddo
4057 *
4058 * Loop over residues i+1 thru j-1.
4059 *
4060 cgrad          do k=i+1,j-1
4061 cgrad            do l=1,3
4062 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4063 cgrad            enddo
4064 cgrad          enddo
4065 c 9/28/08 AL Gradient compotents will be summed only at the end
4066           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4067           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4068           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4069           do k=1,3
4070             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4071             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4072           enddo
4073 #endif
4074 *
4075 * Angular part
4076 *
4077           ecosa=2.0D0*fac3*fac1+fac4
4078           fac4=-3.0D0*fac4
4079           fac3=-6.0D0*fac3
4080           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4081           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4082           do k=1,3
4083             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4084             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4085           enddo
4086 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4087 cd   &          (dcosg(k),k=1,3)
4088           do k=1,3
4089             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4090      &      fac_shield(i)**2*fac_shield(j)**2
4091           enddo
4092 c          do k=1,3
4093 c            ghalf=0.5D0*ggg(k)
4094 c            gelc(k,i)=gelc(k,i)+ghalf
4095 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4096 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4097 c            gelc(k,j)=gelc(k,j)+ghalf
4098 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4099 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4100 c          enddo
4101 cgrad          do k=i+1,j-1
4102 cgrad            do l=1,3
4103 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4104 cgrad            enddo
4105 cgrad          enddo
4106 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4107           do k=1,3
4108             gelc(k,i)=gelc(k,i)
4109      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4110      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4111      &           *fac_shield(i)**2*fac_shield(j)**2
4112             gelc(k,j)=gelc(k,j)
4113      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4114      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4115      &           *fac_shield(i)**2*fac_shield(j)**2
4116             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4117             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4118           enddo
4119 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4120
4121 C MARYSIA
4122 c          endif !sscale
4123           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4124      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4125      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4126 C
4127 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4128 C   energy of a peptide unit is assumed in the form of a second-order
4129 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4130 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4131 C   are computed for EVERY pair of non-contiguous peptide groups.
4132 C
4133
4134           if (j.lt.nres-1) then
4135             j1=j+1
4136             j2=j-1
4137           else
4138             j1=j-1
4139             j2=j-2
4140           endif
4141           kkk=0
4142           lll=0
4143           do k=1,2
4144             do l=1,2
4145               kkk=kkk+1
4146               muij(kkk)=mu(k,i)*mu(l,j)
4147 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4148 #ifdef NEWCORR
4149              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4150 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4151              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4152              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4153 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4154              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4155 #endif
4156             enddo
4157           enddo
4158 cd         write (iout,*) 'EELEC: i',i,' j',j
4159 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4160 cd          write(iout,*) 'muij',muij
4161           ury=scalar(uy(1,i),erij)
4162           urz=scalar(uz(1,i),erij)
4163           vry=scalar(uy(1,j),erij)
4164           vrz=scalar(uz(1,j),erij)
4165           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4166           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4167           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4168           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4169           fac=dsqrt(-ael6i)*r3ij
4170           a22=a22*fac
4171           a23=a23*fac
4172           a32=a32*fac
4173           a33=a33*fac
4174 cd          write (iout,'(4i5,4f10.5)')
4175 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4176 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4177 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4178 cd     &      uy(:,j),uz(:,j)
4179 cd          write (iout,'(4f10.5)')
4180 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4181 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4182 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4183 cd           write (iout,'(9f10.5/)')
4184 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4185 C Derivatives of the elements of A in virtual-bond vectors
4186           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4187           do k=1,3
4188             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4189             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4190             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4191             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4192             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4193             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4194             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4195             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4196             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4197             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4198             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4199             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4200           enddo
4201 C Compute radial contributions to the gradient
4202           facr=-3.0d0*rrmij
4203           a22der=a22*facr
4204           a23der=a23*facr
4205           a32der=a32*facr
4206           a33der=a33*facr
4207           agg(1,1)=a22der*xj
4208           agg(2,1)=a22der*yj
4209           agg(3,1)=a22der*zj
4210           agg(1,2)=a23der*xj
4211           agg(2,2)=a23der*yj
4212           agg(3,2)=a23der*zj
4213           agg(1,3)=a32der*xj
4214           agg(2,3)=a32der*yj
4215           agg(3,3)=a32der*zj
4216           agg(1,4)=a33der*xj
4217           agg(2,4)=a33der*yj
4218           agg(3,4)=a33der*zj
4219 C Add the contributions coming from er
4220           fac3=-3.0d0*fac
4221           do k=1,3
4222             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4223             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4224             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4225             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4226           enddo
4227           do k=1,3
4228 C Derivatives in DC(i)
4229 cgrad            ghalf1=0.5d0*agg(k,1)
4230 cgrad            ghalf2=0.5d0*agg(k,2)
4231 cgrad            ghalf3=0.5d0*agg(k,3)
4232 cgrad            ghalf4=0.5d0*agg(k,4)
4233             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4234      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4235             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4236      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4237             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4238      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4239             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4240      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4241 C Derivatives in DC(i+1)
4242             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4243      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4244             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4245      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4246             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4247      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4248             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4249      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4250 C Derivatives in DC(j)
4251             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4252      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4253             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4254      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4255             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4256      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4257             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4258      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4259 C Derivatives in DC(j+1) or DC(nres-1)
4260             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4261      &      -3.0d0*vryg(k,3)*ury)
4262             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4263      &      -3.0d0*vrzg(k,3)*ury)
4264             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4265      &      -3.0d0*vryg(k,3)*urz)
4266             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4267      &      -3.0d0*vrzg(k,3)*urz)
4268 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4269 cgrad              do l=1,4
4270 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4271 cgrad              enddo
4272 cgrad            endif
4273           enddo
4274           acipa(1,1)=a22
4275           acipa(1,2)=a23
4276           acipa(2,1)=a32
4277           acipa(2,2)=a33
4278           a22=-a22
4279           a23=-a23
4280           do l=1,2
4281             do k=1,3
4282               agg(k,l)=-agg(k,l)
4283               aggi(k,l)=-aggi(k,l)
4284               aggi1(k,l)=-aggi1(k,l)
4285               aggj(k,l)=-aggj(k,l)
4286               aggj1(k,l)=-aggj1(k,l)
4287             enddo
4288           enddo
4289           if (j.lt.nres-1) then
4290             a22=-a22
4291             a32=-a32
4292             do l=1,3,2
4293               do k=1,3
4294                 agg(k,l)=-agg(k,l)
4295                 aggi(k,l)=-aggi(k,l)
4296                 aggi1(k,l)=-aggi1(k,l)
4297                 aggj(k,l)=-aggj(k,l)
4298                 aggj1(k,l)=-aggj1(k,l)
4299               enddo
4300             enddo
4301           else
4302             a22=-a22
4303             a23=-a23
4304             a32=-a32
4305             a33=-a33
4306             do l=1,4
4307               do k=1,3
4308                 agg(k,l)=-agg(k,l)
4309                 aggi(k,l)=-aggi(k,l)
4310                 aggi1(k,l)=-aggi1(k,l)
4311                 aggj(k,l)=-aggj(k,l)
4312                 aggj1(k,l)=-aggj1(k,l)
4313               enddo
4314             enddo
4315           endif
4316           ENDIF ! WCORR
4317           IF (wel_loc.gt.0.0d0) THEN
4318 C Contribution to the local-electrostatic energy coming from the i-j pair
4319           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4320      &     +a33*muij(4)
4321           if (shield_mode.eq.0) then
4322            fac_shield(i)=1.0
4323            fac_shield(j)=1.0
4324 C          else
4325 C           fac_shield(i)=0.4
4326 C           fac_shield(j)=0.6
4327           endif
4328           eel_loc_ij=eel_loc_ij
4329      &    *fac_shield(i)*fac_shield(j)
4330 C Now derivative over eel_loc
4331           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4332      &  (shield_mode.gt.0)) then
4333 C          print *,i,j
4334
4335           do ilist=1,ishield_list(i)
4336            iresshield=shield_list(ilist,i)
4337            do k=1,3
4338            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4339      &                                          /fac_shield(i)
4340 C     &      *2.0
4341            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4342      &              rlocshield
4343      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4344             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4345      &      +rlocshield
4346            enddo
4347           enddo
4348           do ilist=1,ishield_list(j)
4349            iresshield=shield_list(ilist,j)
4350            do k=1,3
4351            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4352      &                                       /fac_shield(j)
4353 C     &     *2.0
4354            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4355      &              rlocshield
4356      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4357            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4358      &             +rlocshield
4359
4360            enddo
4361           enddo
4362
4363           do k=1,3
4364             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4365      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4366             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4367      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4368             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4369      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4370             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4371      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4372            enddo
4373            endif
4374
4375
4376 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4377 c     &                     ' eel_loc_ij',eel_loc_ij
4378 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4379 C Calculate patrial derivative for theta angle
4380 #ifdef NEWCORR
4381          geel_loc_ij=(a22*gmuij1(1)
4382      &     +a23*gmuij1(2)
4383      &     +a32*gmuij1(3)
4384      &     +a33*gmuij1(4))
4385      &    *fac_shield(i)*fac_shield(j)
4386 c         write(iout,*) "derivative over thatai"
4387 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4388 c     &   a33*gmuij1(4)
4389          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4390      &      geel_loc_ij*wel_loc
4391 c         write(iout,*) "derivative over thatai-1"
4392 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4393 c     &   a33*gmuij2(4)
4394          geel_loc_ij=
4395      &     a22*gmuij2(1)
4396      &     +a23*gmuij2(2)
4397      &     +a32*gmuij2(3)
4398      &     +a33*gmuij2(4)
4399          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4400      &      geel_loc_ij*wel_loc
4401      &    *fac_shield(i)*fac_shield(j)
4402
4403 c  Derivative over j residue
4404          geel_loc_ji=a22*gmuji1(1)
4405      &     +a23*gmuji1(2)
4406      &     +a32*gmuji1(3)
4407      &     +a33*gmuji1(4)
4408 c         write(iout,*) "derivative over thataj"
4409 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4410 c     &   a33*gmuji1(4)
4411
4412         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4413      &      geel_loc_ji*wel_loc
4414      &    *fac_shield(i)*fac_shield(j)
4415
4416          geel_loc_ji=
4417      &     +a22*gmuji2(1)
4418      &     +a23*gmuji2(2)
4419      &     +a32*gmuji2(3)
4420      &     +a33*gmuji2(4)
4421 c         write(iout,*) "derivative over thataj-1"
4422 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4423 c     &   a33*gmuji2(4)
4424          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4425      &      geel_loc_ji*wel_loc
4426      &    *fac_shield(i)*fac_shield(j)
4427 #endif
4428 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4429
4430           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4431      &            'eelloc',i,j,eel_loc_ij
4432 c           if (eel_loc_ij.ne.0)
4433 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4434 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4435
4436           eel_loc=eel_loc+eel_loc_ij
4437 C Partial derivatives in virtual-bond dihedral angles gamma
4438           if (i.gt.1)
4439      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4440      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4441      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4442      &    *fac_shield(i)*fac_shield(j)
4443
4444           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4445      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4446      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4447      &    *fac_shield(i)*fac_shield(j)
4448 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4449           do l=1,3
4450             ggg(l)=(agg(l,1)*muij(1)+
4451      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4452      &    *fac_shield(i)*fac_shield(j)
4453             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4454             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4455 cgrad            ghalf=0.5d0*ggg(l)
4456 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4457 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4458           enddo
4459 cgrad          do k=i+1,j2
4460 cgrad            do l=1,3
4461 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4462 cgrad            enddo
4463 cgrad          enddo
4464 C Remaining derivatives of eello
4465           do l=1,3
4466             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4467      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4468      &    *fac_shield(i)*fac_shield(j)
4469
4470             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4471      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4472      &    *fac_shield(i)*fac_shield(j)
4473
4474             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4475      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4476      &    *fac_shield(i)*fac_shield(j)
4477
4478             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4479      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4480      &    *fac_shield(i)*fac_shield(j)
4481
4482           enddo
4483           ENDIF
4484 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4485 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4486           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4487      &       .and. num_conti.le.maxconts) then
4488 c            write (iout,*) i,j," entered corr"
4489 C
4490 C Calculate the contact function. The ith column of the array JCONT will
4491 C contain the numbers of atoms that make contacts with the atom I (of numbers
4492 C greater than I). The arrays FACONT and GACONT will contain the values of
4493 C the contact function and its derivative.
4494 c           r0ij=1.02D0*rpp(iteli,itelj)
4495 c           r0ij=1.11D0*rpp(iteli,itelj)
4496             r0ij=2.20D0*rpp(iteli,itelj)
4497 c           r0ij=1.55D0*rpp(iteli,itelj)
4498             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4499             if (fcont.gt.0.0D0) then
4500               num_conti=num_conti+1
4501               if (num_conti.gt.maxconts) then
4502                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4503      &                         ' will skip next contacts for this conf.'
4504               else
4505                 jcont_hb(num_conti,i)=j
4506 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4507 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4508                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4509      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4510 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4511 C  terms.
4512                 d_cont(num_conti,i)=rij
4513 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4514 C     --- Electrostatic-interaction matrix ---
4515                 a_chuj(1,1,num_conti,i)=a22
4516                 a_chuj(1,2,num_conti,i)=a23
4517                 a_chuj(2,1,num_conti,i)=a32
4518                 a_chuj(2,2,num_conti,i)=a33
4519 C     --- Gradient of rij
4520                 do kkk=1,3
4521                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4522                 enddo
4523                 kkll=0
4524                 do k=1,2
4525                   do l=1,2
4526                     kkll=kkll+1
4527                     do m=1,3
4528                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4529                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4530                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4531                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4532                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4533                     enddo
4534                   enddo
4535                 enddo
4536                 ENDIF
4537                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4538 C Calculate contact energies
4539                 cosa4=4.0D0*cosa
4540                 wij=cosa-3.0D0*cosb*cosg
4541                 cosbg1=cosb+cosg
4542                 cosbg2=cosb-cosg
4543 c               fac3=dsqrt(-ael6i)/r0ij**3
4544                 fac3=dsqrt(-ael6i)*r3ij
4545 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4546                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4547                 if (ees0tmp.gt.0) then
4548                   ees0pij=dsqrt(ees0tmp)
4549                 else
4550                   ees0pij=0
4551                 endif
4552 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4553                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4554                 if (ees0tmp.gt.0) then
4555                   ees0mij=dsqrt(ees0tmp)
4556                 else
4557                   ees0mij=0
4558                 endif
4559 c               ees0mij=0.0D0
4560                 if (shield_mode.eq.0) then
4561                 fac_shield(i)=1.0d0
4562                 fac_shield(j)=1.0d0
4563                 else
4564                 ees0plist(num_conti,i)=j
4565 C                fac_shield(i)=0.4d0
4566 C                fac_shield(j)=0.6d0
4567                 endif
4568                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4569      &          *fac_shield(i)*fac_shield(j)
4570                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4571      &          *fac_shield(i)*fac_shield(j)
4572 C Diagnostics. Comment out or remove after debugging!
4573 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4574 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4575 c               ees0m(num_conti,i)=0.0D0
4576 C End diagnostics.
4577 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4578 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4579 C Angular derivatives of the contact function
4580                 ees0pij1=fac3/ees0pij
4581                 ees0mij1=fac3/ees0mij
4582                 fac3p=-3.0D0*fac3*rrmij
4583                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4584                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4585 c               ees0mij1=0.0D0
4586                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4587                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4588                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4589                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4590                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4591                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4592                 ecosap=ecosa1+ecosa2
4593                 ecosbp=ecosb1+ecosb2
4594                 ecosgp=ecosg1+ecosg2
4595                 ecosam=ecosa1-ecosa2
4596                 ecosbm=ecosb1-ecosb2
4597                 ecosgm=ecosg1-ecosg2
4598 C Diagnostics
4599 c               ecosap=ecosa1
4600 c               ecosbp=ecosb1
4601 c               ecosgp=ecosg1
4602 c               ecosam=0.0D0
4603 c               ecosbm=0.0D0
4604 c               ecosgm=0.0D0
4605 C End diagnostics
4606                 facont_hb(num_conti,i)=fcont
4607                 fprimcont=fprimcont/rij
4608 cd              facont_hb(num_conti,i)=1.0D0
4609 C Following line is for diagnostics.
4610 cd              fprimcont=0.0D0
4611                 do k=1,3
4612                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4613                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4614                 enddo
4615                 do k=1,3
4616                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4617                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4618                 enddo
4619                 gggp(1)=gggp(1)+ees0pijp*xj
4620                 gggp(2)=gggp(2)+ees0pijp*yj
4621                 gggp(3)=gggp(3)+ees0pijp*zj
4622                 gggm(1)=gggm(1)+ees0mijp*xj
4623                 gggm(2)=gggm(2)+ees0mijp*yj
4624                 gggm(3)=gggm(3)+ees0mijp*zj
4625 C Derivatives due to the contact function
4626                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4627                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4628                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4629                 do k=1,3
4630 c
4631 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4632 c          following the change of gradient-summation algorithm.
4633 c
4634 cgrad                  ghalfp=0.5D0*gggp(k)
4635 cgrad                  ghalfm=0.5D0*gggm(k)
4636                   gacontp_hb1(k,num_conti,i)=!ghalfp
4637      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4638      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4639      &          *fac_shield(i)*fac_shield(j)
4640
4641                   gacontp_hb2(k,num_conti,i)=!ghalfp
4642      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4643      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4644      &          *fac_shield(i)*fac_shield(j)
4645
4646                   gacontp_hb3(k,num_conti,i)=gggp(k)
4647      &          *fac_shield(i)*fac_shield(j)
4648
4649                   gacontm_hb1(k,num_conti,i)=!ghalfm
4650      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4651      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4652      &          *fac_shield(i)*fac_shield(j)
4653
4654                   gacontm_hb2(k,num_conti,i)=!ghalfm
4655      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4656      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4657      &          *fac_shield(i)*fac_shield(j)
4658
4659                   gacontm_hb3(k,num_conti,i)=gggm(k)
4660      &          *fac_shield(i)*fac_shield(j)
4661
4662                 enddo
4663 C Diagnostics. Comment out or remove after debugging!
4664 cdiag           do k=1,3
4665 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4666 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4667 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4668 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4669 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4670 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4671 cdiag           enddo
4672               ENDIF ! wcorr
4673               endif  ! num_conti.le.maxconts
4674             endif  ! fcont.gt.0
4675           endif    ! j.gt.i+1
4676           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4677             do k=1,4
4678               do l=1,3
4679                 ghalf=0.5d0*agg(l,k)
4680                 aggi(l,k)=aggi(l,k)+ghalf
4681                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4682                 aggj(l,k)=aggj(l,k)+ghalf
4683               enddo
4684             enddo
4685             if (j.eq.nres-1 .and. i.lt.j-2) then
4686               do k=1,4
4687                 do l=1,3
4688                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4689                 enddo
4690               enddo
4691             endif
4692           endif
4693 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4694       return
4695       end
4696 C-----------------------------------------------------------------------------
4697       subroutine eturn3(i,eello_turn3)
4698 C Third- and fourth-order contributions from turns
4699       implicit real*8 (a-h,o-z)
4700       include 'DIMENSIONS'
4701       include 'COMMON.IOUNITS'
4702       include 'COMMON.GEO'
4703       include 'COMMON.VAR'
4704       include 'COMMON.LOCAL'
4705       include 'COMMON.CHAIN'
4706       include 'COMMON.DERIV'
4707       include 'COMMON.INTERACT'
4708       include 'COMMON.CONTACTS'
4709       include 'COMMON.TORSION'
4710       include 'COMMON.VECTORS'
4711       include 'COMMON.FFIELD'
4712       include 'COMMON.CONTROL'
4713       include 'COMMON.SHIELD'
4714       dimension ggg(3)
4715       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4716      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4717      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4718      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4719      &  auxgmat2(2,2),auxgmatt2(2,2)
4720       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4721      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4722       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4723      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4724      &    num_conti,j1,j2
4725       j=i+2
4726 c      write (iout,*) "eturn3",i,j,j1,j2
4727       a_temp(1,1)=a22
4728       a_temp(1,2)=a23
4729       a_temp(2,1)=a32
4730       a_temp(2,2)=a33
4731 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4732 C
4733 C               Third-order contributions
4734 C
4735 C                 (i+2)o----(i+3)
4736 C                      | |
4737 C                      | |
4738 C                 (i+1)o----i
4739 C
4740 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4741 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4742         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4743 c auxalary matices for theta gradient
4744 c auxalary matrix for i+1 and constant i+2
4745         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4746 c auxalary matrix for i+2 and constant i+1
4747         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4748         call transpose2(auxmat(1,1),auxmat1(1,1))
4749         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4750         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4751         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4752         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4753         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4754         if (shield_mode.eq.0) then
4755         fac_shield(i)=1.0
4756         fac_shield(j)=1.0
4757 C        else
4758 C        fac_shield(i)=0.4
4759 C        fac_shield(j)=0.6
4760         endif
4761 C         if (j.eq.78)
4762 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
4763         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4764      &  *fac_shield(i)*fac_shield(j)
4765         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4766      &  *fac_shield(i)*fac_shield(j)
4767 #ifdef NEWCORR
4768 C Derivatives in theta
4769         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4770      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4771      &   *fac_shield(i)*fac_shield(j)
4772         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4773      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4774      &   *fac_shield(i)*fac_shield(j)
4775 #endif
4776
4777 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4778 C Derivatives in shield mode
4779           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4780      &  (shield_mode.gt.0)) then
4781 C          print *,i,j
4782
4783           do ilist=1,ishield_list(i)
4784            iresshield=shield_list(ilist,i)
4785            do k=1,3
4786            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4787 C     &      *2.0
4788            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4789      &              rlocshield
4790      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4791             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4792      &      +rlocshield
4793            enddo
4794           enddo
4795           do ilist=1,ishield_list(j)
4796            iresshield=shield_list(ilist,j)
4797            do k=1,3
4798            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4799 C     &     *2.0
4800            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4801      &              rlocshield
4802      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4803            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4804      &             +rlocshield
4805
4806            enddo
4807           enddo
4808
4809           do k=1,3
4810             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4811      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4812             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4813      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4814             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4815      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4816             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4817      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4818            enddo
4819            endif
4820
4821 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4822 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4823 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4824 cd     &    ' eello_turn3_num',4*eello_turn3_num
4825 C Derivatives in gamma(i)
4826         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4827         call transpose2(auxmat2(1,1),auxmat3(1,1))
4828         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4829         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4830      &   *fac_shield(i)*fac_shield(j)
4831 C Derivatives in gamma(i+1)
4832         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4833         call transpose2(auxmat2(1,1),auxmat3(1,1))
4834         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4835         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4836      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4837      &   *fac_shield(i)*fac_shield(j)
4838 C Cartesian derivatives
4839         do l=1,3
4840 c            ghalf1=0.5d0*agg(l,1)
4841 c            ghalf2=0.5d0*agg(l,2)
4842 c            ghalf3=0.5d0*agg(l,3)
4843 c            ghalf4=0.5d0*agg(l,4)
4844           a_temp(1,1)=aggi(l,1)!+ghalf1
4845           a_temp(1,2)=aggi(l,2)!+ghalf2
4846           a_temp(2,1)=aggi(l,3)!+ghalf3
4847           a_temp(2,2)=aggi(l,4)!+ghalf4
4848           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4849           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4850      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4851      &   *fac_shield(i)*fac_shield(j)
4852
4853           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4854           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4855           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4856           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4857           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4858           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4859      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4860      &   *fac_shield(i)*fac_shield(j)
4861           a_temp(1,1)=aggj(l,1)!+ghalf1
4862           a_temp(1,2)=aggj(l,2)!+ghalf2
4863           a_temp(2,1)=aggj(l,3)!+ghalf3
4864           a_temp(2,2)=aggj(l,4)!+ghalf4
4865           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4866           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4867      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4868      &   *fac_shield(i)*fac_shield(j)
4869           a_temp(1,1)=aggj1(l,1)
4870           a_temp(1,2)=aggj1(l,2)
4871           a_temp(2,1)=aggj1(l,3)
4872           a_temp(2,2)=aggj1(l,4)
4873           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4874           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4875      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4876      &   *fac_shield(i)*fac_shield(j)
4877         enddo
4878       return
4879       end
4880 C-------------------------------------------------------------------------------
4881       subroutine eturn4(i,eello_turn4)
4882 C Third- and fourth-order contributions from turns
4883       implicit real*8 (a-h,o-z)
4884       include 'DIMENSIONS'
4885       include 'COMMON.IOUNITS'
4886       include 'COMMON.GEO'
4887       include 'COMMON.VAR'
4888       include 'COMMON.LOCAL'
4889       include 'COMMON.CHAIN'
4890       include 'COMMON.DERIV'
4891       include 'COMMON.INTERACT'
4892       include 'COMMON.CONTACTS'
4893       include 'COMMON.TORSION'
4894       include 'COMMON.VECTORS'
4895       include 'COMMON.FFIELD'
4896       include 'COMMON.CONTROL'
4897       include 'COMMON.SHIELD'
4898       dimension ggg(3)
4899       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4900      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4901      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4902      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4903      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4904      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4905      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4906       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4907      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4908       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4909      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4910      &    num_conti,j1,j2
4911       j=i+3
4912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4913 C
4914 C               Fourth-order contributions
4915 C
4916 C                 (i+3)o----(i+4)
4917 C                     /  |
4918 C               (i+2)o   |
4919 C                     \  |
4920 C                 (i+1)o----i
4921 C
4922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4923 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4924 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4925 c        write(iout,*)"WCHODZE W PROGRAM"
4926         a_temp(1,1)=a22
4927         a_temp(1,2)=a23
4928         a_temp(2,1)=a32
4929         a_temp(2,2)=a33
4930         iti1=itype2loc(itype(i+1))
4931         iti2=itype2loc(itype(i+2))
4932         iti3=itype2loc(itype(i+3))
4933 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4934         call transpose2(EUg(1,1,i+1),e1t(1,1))
4935         call transpose2(Eug(1,1,i+2),e2t(1,1))
4936         call transpose2(Eug(1,1,i+3),e3t(1,1))
4937 C Ematrix derivative in theta
4938         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4939         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4940         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4941         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4942 c       eta1 in derivative theta
4943         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4944         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4945 c       auxgvec is derivative of Ub2 so i+3 theta
4946         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4947 c       auxalary matrix of E i+1
4948         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4949 c        s1=0.0
4950 c        gs1=0.0
4951         s1=scalar2(b1(1,i+2),auxvec(1))
4952 c derivative of theta i+2 with constant i+3
4953         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4954 c derivative of theta i+2 with constant i+2
4955         gs32=scalar2(b1(1,i+2),auxgvec(1))
4956 c derivative of E matix in theta of i+1
4957         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4958
4959         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4960 c       ea31 in derivative theta
4961         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4962         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4963 c auxilary matrix auxgvec of Ub2 with constant E matirx
4964         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4965 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4966         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4967
4968 c        s2=0.0
4969 c        gs2=0.0
4970         s2=scalar2(b1(1,i+1),auxvec(1))
4971 c derivative of theta i+1 with constant i+3
4972         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4973 c derivative of theta i+2 with constant i+1
4974         gs21=scalar2(b1(1,i+1),auxgvec(1))
4975 c derivative of theta i+3 with constant i+1
4976         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4977 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4978 c     &  gtb1(1,i+1)
4979         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4980 c two derivatives over diffetent matrices
4981 c gtae3e2 is derivative over i+3
4982         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4983 c ae3gte2 is derivative over i+2
4984         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4985         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4986 c three possible derivative over theta E matices
4987 c i+1
4988         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4989 c i+2
4990         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4991 c i+3
4992         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4993         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4994
4995         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4996         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4997         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4998         if (shield_mode.eq.0) then
4999         fac_shield(i)=1.0
5000         fac_shield(j)=1.0
5001 C        else
5002 C        fac_shield(i)=0.6
5003 C        fac_shield(j)=0.4
5004         endif
5005         eello_turn4=eello_turn4-(s1+s2+s3)
5006      &  *fac_shield(i)*fac_shield(j)
5007         eello_t4=-(s1+s2+s3)
5008      &  *fac_shield(i)*fac_shield(j)
5009 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5010         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5011      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5012 C Now derivative over shield:
5013           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5014      &  (shield_mode.gt.0)) then
5015 C          print *,i,j
5016
5017           do ilist=1,ishield_list(i)
5018            iresshield=shield_list(ilist,i)
5019            do k=1,3
5020            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5021 C     &      *2.0
5022            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5023      &              rlocshield
5024      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5025             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5026      &      +rlocshield
5027            enddo
5028           enddo
5029           do ilist=1,ishield_list(j)
5030            iresshield=shield_list(ilist,j)
5031            do k=1,3
5032            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5033 C     &     *2.0
5034            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5035      &              rlocshield
5036      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5037            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5038      &             +rlocshield
5039
5040            enddo
5041           enddo
5042
5043           do k=1,3
5044             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5045      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5046             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5047      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5048             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5049      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5050             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5051      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5052            enddo
5053            endif
5054
5055
5056
5057
5058
5059
5060 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5061 cd     &    ' eello_turn4_num',8*eello_turn4_num
5062 #ifdef NEWCORR
5063         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5064      &                  -(gs13+gsE13+gsEE1)*wturn4
5065      &  *fac_shield(i)*fac_shield(j)
5066         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5067      &                    -(gs23+gs21+gsEE2)*wturn4
5068      &  *fac_shield(i)*fac_shield(j)
5069
5070         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5071      &                    -(gs32+gsE31+gsEE3)*wturn4
5072      &  *fac_shield(i)*fac_shield(j)
5073
5074 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5075 c     &   gs2
5076 #endif
5077         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5078      &      'eturn4',i,j,-(s1+s2+s3)
5079 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5080 c     &    ' eello_turn4_num',8*eello_turn4_num
5081 C Derivatives in gamma(i)
5082         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5083         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5084         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5085         s1=scalar2(b1(1,i+2),auxvec(1))
5086         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5087         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5088         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5089      &  *fac_shield(i)*fac_shield(j)
5090 C Derivatives in gamma(i+1)
5091         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5092         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5093         s2=scalar2(b1(1,i+1),auxvec(1))
5094         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5095         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5096         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5097         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5098      &  *fac_shield(i)*fac_shield(j)
5099 C Derivatives in gamma(i+2)
5100         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5101         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5102         s1=scalar2(b1(1,i+2),auxvec(1))
5103         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5104         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5105         s2=scalar2(b1(1,i+1),auxvec(1))
5106         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5107         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5108         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5109         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5110      &  *fac_shield(i)*fac_shield(j)
5111 C Cartesian derivatives
5112 C Derivatives of this turn contributions in DC(i+2)
5113         if (j.lt.nres-1) then
5114           do l=1,3
5115             a_temp(1,1)=agg(l,1)
5116             a_temp(1,2)=agg(l,2)
5117             a_temp(2,1)=agg(l,3)
5118             a_temp(2,2)=agg(l,4)
5119             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5120             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5121             s1=scalar2(b1(1,i+2),auxvec(1))
5122             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5123             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5124             s2=scalar2(b1(1,i+1),auxvec(1))
5125             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5126             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5127             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5128             ggg(l)=-(s1+s2+s3)
5129             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5130      &  *fac_shield(i)*fac_shield(j)
5131           enddo
5132         endif
5133 C Remaining derivatives of this turn contribution
5134         do l=1,3
5135           a_temp(1,1)=aggi(l,1)
5136           a_temp(1,2)=aggi(l,2)
5137           a_temp(2,1)=aggi(l,3)
5138           a_temp(2,2)=aggi(l,4)
5139           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5140           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5141           s1=scalar2(b1(1,i+2),auxvec(1))
5142           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5143           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5144           s2=scalar2(b1(1,i+1),auxvec(1))
5145           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5146           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5147           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5148           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5149      &  *fac_shield(i)*fac_shield(j)
5150           a_temp(1,1)=aggi1(l,1)
5151           a_temp(1,2)=aggi1(l,2)
5152           a_temp(2,1)=aggi1(l,3)
5153           a_temp(2,2)=aggi1(l,4)
5154           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5155           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5156           s1=scalar2(b1(1,i+2),auxvec(1))
5157           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5158           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5159           s2=scalar2(b1(1,i+1),auxvec(1))
5160           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5161           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5162           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5163           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5164      &  *fac_shield(i)*fac_shield(j)
5165           a_temp(1,1)=aggj(l,1)
5166           a_temp(1,2)=aggj(l,2)
5167           a_temp(2,1)=aggj(l,3)
5168           a_temp(2,2)=aggj(l,4)
5169           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5170           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5171           s1=scalar2(b1(1,i+2),auxvec(1))
5172           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5173           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5174           s2=scalar2(b1(1,i+1),auxvec(1))
5175           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5176           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5177           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5178           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5179      &  *fac_shield(i)*fac_shield(j)
5180           a_temp(1,1)=aggj1(l,1)
5181           a_temp(1,2)=aggj1(l,2)
5182           a_temp(2,1)=aggj1(l,3)
5183           a_temp(2,2)=aggj1(l,4)
5184           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5185           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5186           s1=scalar2(b1(1,i+2),auxvec(1))
5187           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5188           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5189           s2=scalar2(b1(1,i+1),auxvec(1))
5190           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5191           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5192           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5193 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5194           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5195      &  *fac_shield(i)*fac_shield(j)
5196         enddo
5197       return
5198       end
5199 C-----------------------------------------------------------------------------
5200       subroutine vecpr(u,v,w)
5201       implicit real*8(a-h,o-z)
5202       dimension u(3),v(3),w(3)
5203       w(1)=u(2)*v(3)-u(3)*v(2)
5204       w(2)=-u(1)*v(3)+u(3)*v(1)
5205       w(3)=u(1)*v(2)-u(2)*v(1)
5206       return
5207       end
5208 C-----------------------------------------------------------------------------
5209       subroutine unormderiv(u,ugrad,unorm,ungrad)
5210 C This subroutine computes the derivatives of a normalized vector u, given
5211 C the derivatives computed without normalization conditions, ugrad. Returns
5212 C ungrad.
5213       implicit none
5214       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5215       double precision vec(3)
5216       double precision scalar
5217       integer i,j
5218 c      write (2,*) 'ugrad',ugrad
5219 c      write (2,*) 'u',u
5220       do i=1,3
5221         vec(i)=scalar(ugrad(1,i),u(1))
5222       enddo
5223 c      write (2,*) 'vec',vec
5224       do i=1,3
5225         do j=1,3
5226           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5227         enddo
5228       enddo
5229 c      write (2,*) 'ungrad',ungrad
5230       return
5231       end
5232 C-----------------------------------------------------------------------------
5233       subroutine escp_soft_sphere(evdw2,evdw2_14)
5234 C
5235 C This subroutine calculates the excluded-volume interaction energy between
5236 C peptide-group centers and side chains and its gradient in virtual-bond and
5237 C side-chain vectors.
5238 C
5239       implicit real*8 (a-h,o-z)
5240       include 'DIMENSIONS'
5241       include 'COMMON.GEO'
5242       include 'COMMON.VAR'
5243       include 'COMMON.LOCAL'
5244       include 'COMMON.CHAIN'
5245       include 'COMMON.DERIV'
5246       include 'COMMON.INTERACT'
5247       include 'COMMON.FFIELD'
5248       include 'COMMON.IOUNITS'
5249       include 'COMMON.CONTROL'
5250       dimension ggg(3)
5251       evdw2=0.0D0
5252       evdw2_14=0.0d0
5253       r0_scp=4.5d0
5254 cd    print '(a)','Enter ESCP'
5255 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5256 C      do xshift=-1,1
5257 C      do yshift=-1,1
5258 C      do zshift=-1,1
5259       do i=iatscp_s,iatscp_e
5260         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5261         iteli=itel(i)
5262         xi=0.5D0*(c(1,i)+c(1,i+1))
5263         yi=0.5D0*(c(2,i)+c(2,i+1))
5264         zi=0.5D0*(c(3,i)+c(3,i+1))
5265 C Return atom into box, boxxsize is size of box in x dimension
5266 c  134   continue
5267 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5268 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5269 C Condition for being inside the proper box
5270 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5271 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5272 c        go to 134
5273 c        endif
5274 c  135   continue
5275 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5276 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5277 C Condition for being inside the proper box
5278 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5279 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5280 c        go to 135
5281 c c       endif
5282 c  136   continue
5283 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5284 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5285 cC Condition for being inside the proper box
5286 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5287 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5288 c        go to 136
5289 c        endif
5290           xi=mod(xi,boxxsize)
5291           if (xi.lt.0) xi=xi+boxxsize
5292           yi=mod(yi,boxysize)
5293           if (yi.lt.0) yi=yi+boxysize
5294           zi=mod(zi,boxzsize)
5295           if (zi.lt.0) zi=zi+boxzsize
5296 C          xi=xi+xshift*boxxsize
5297 C          yi=yi+yshift*boxysize
5298 C          zi=zi+zshift*boxzsize
5299         do iint=1,nscp_gr(i)
5300
5301         do j=iscpstart(i,iint),iscpend(i,iint)
5302           if (itype(j).eq.ntyp1) cycle
5303           itypj=iabs(itype(j))
5304 C Uncomment following three lines for SC-p interactions
5305 c         xj=c(1,nres+j)-xi
5306 c         yj=c(2,nres+j)-yi
5307 c         zj=c(3,nres+j)-zi
5308 C Uncomment following three lines for Ca-p interactions
5309           xj=c(1,j)
5310           yj=c(2,j)
5311           zj=c(3,j)
5312 c  174   continue
5313 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5314 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5315 C Condition for being inside the proper box
5316 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5317 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5318 c        go to 174
5319 c        endif
5320 c  175   continue
5321 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5322 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5323 cC Condition for being inside the proper box
5324 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5325 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5326 c        go to 175
5327 c        endif
5328 c  176   continue
5329 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5330 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5331 C Condition for being inside the proper box
5332 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5333 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5334 c        go to 176
5335           xj=mod(xj,boxxsize)
5336           if (xj.lt.0) xj=xj+boxxsize
5337           yj=mod(yj,boxysize)
5338           if (yj.lt.0) yj=yj+boxysize
5339           zj=mod(zj,boxzsize)
5340           if (zj.lt.0) zj=zj+boxzsize
5341       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5342       xj_safe=xj
5343       yj_safe=yj
5344       zj_safe=zj
5345       subchap=0
5346       do xshift=-1,1
5347       do yshift=-1,1
5348       do zshift=-1,1
5349           xj=xj_safe+xshift*boxxsize
5350           yj=yj_safe+yshift*boxysize
5351           zj=zj_safe+zshift*boxzsize
5352           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5353           if(dist_temp.lt.dist_init) then
5354             dist_init=dist_temp
5355             xj_temp=xj
5356             yj_temp=yj
5357             zj_temp=zj
5358             subchap=1
5359           endif
5360        enddo
5361        enddo
5362        enddo
5363        if (subchap.eq.1) then
5364           xj=xj_temp-xi
5365           yj=yj_temp-yi
5366           zj=zj_temp-zi
5367        else
5368           xj=xj_safe-xi
5369           yj=yj_safe-yi
5370           zj=zj_safe-zi
5371        endif
5372 c c       endif
5373 C          xj=xj-xi
5374 C          yj=yj-yi
5375 C          zj=zj-zi
5376           rij=xj*xj+yj*yj+zj*zj
5377
5378           r0ij=r0_scp
5379           r0ijsq=r0ij*r0ij
5380           if (rij.lt.r0ijsq) then
5381             evdwij=0.25d0*(rij-r0ijsq)**2
5382             fac=rij-r0ijsq
5383           else
5384             evdwij=0.0d0
5385             fac=0.0d0
5386           endif
5387           evdw2=evdw2+evdwij
5388 C
5389 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5390 C
5391           ggg(1)=xj*fac
5392           ggg(2)=yj*fac
5393           ggg(3)=zj*fac
5394 cgrad          if (j.lt.i) then
5395 cd          write (iout,*) 'j<i'
5396 C Uncomment following three lines for SC-p interactions
5397 c           do k=1,3
5398 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5399 c           enddo
5400 cgrad          else
5401 cd          write (iout,*) 'j>i'
5402 cgrad            do k=1,3
5403 cgrad              ggg(k)=-ggg(k)
5404 C Uncomment following line for SC-p interactions
5405 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5406 cgrad            enddo
5407 cgrad          endif
5408 cgrad          do k=1,3
5409 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5410 cgrad          enddo
5411 cgrad          kstart=min0(i+1,j)
5412 cgrad          kend=max0(i-1,j-1)
5413 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5414 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5415 cgrad          do k=kstart,kend
5416 cgrad            do l=1,3
5417 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5418 cgrad            enddo
5419 cgrad          enddo
5420           do k=1,3
5421             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5422             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5423           enddo
5424         enddo
5425
5426         enddo ! iint
5427       enddo ! i
5428 C      enddo !zshift
5429 C      enddo !yshift
5430 C      enddo !xshift
5431       return
5432       end
5433 C-----------------------------------------------------------------------------
5434       subroutine escp(evdw2,evdw2_14)
5435 C
5436 C This subroutine calculates the excluded-volume interaction energy between
5437 C peptide-group centers and side chains and its gradient in virtual-bond and
5438 C side-chain vectors.
5439 C
5440       implicit real*8 (a-h,o-z)
5441       include 'DIMENSIONS'
5442       include 'COMMON.GEO'
5443       include 'COMMON.VAR'
5444       include 'COMMON.LOCAL'
5445       include 'COMMON.CHAIN'
5446       include 'COMMON.DERIV'
5447       include 'COMMON.INTERACT'
5448       include 'COMMON.FFIELD'
5449       include 'COMMON.IOUNITS'
5450       include 'COMMON.CONTROL'
5451       include 'COMMON.SPLITELE'
5452       dimension ggg(3)
5453       evdw2=0.0D0
5454       evdw2_14=0.0d0
5455 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5456 cd    print '(a)','Enter ESCP'
5457 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5458 C      do xshift=-1,1
5459 C      do yshift=-1,1
5460 C      do zshift=-1,1
5461       do i=iatscp_s,iatscp_e
5462         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5463         iteli=itel(i)
5464         xi=0.5D0*(c(1,i)+c(1,i+1))
5465         yi=0.5D0*(c(2,i)+c(2,i+1))
5466         zi=0.5D0*(c(3,i)+c(3,i+1))
5467           xi=mod(xi,boxxsize)
5468           if (xi.lt.0) xi=xi+boxxsize
5469           yi=mod(yi,boxysize)
5470           if (yi.lt.0) yi=yi+boxysize
5471           zi=mod(zi,boxzsize)
5472           if (zi.lt.0) zi=zi+boxzsize
5473 c          xi=xi+xshift*boxxsize
5474 c          yi=yi+yshift*boxysize
5475 c          zi=zi+zshift*boxzsize
5476 c        print *,xi,yi,zi,'polozenie i'
5477 C Return atom into box, boxxsize is size of box in x dimension
5478 c  134   continue
5479 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5480 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5481 C Condition for being inside the proper box
5482 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5483 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5484 c        go to 134
5485 c        endif
5486 c  135   continue
5487 c          print *,xi,boxxsize,"pierwszy"
5488
5489 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5490 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5491 C Condition for being inside the proper box
5492 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5493 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5494 c        go to 135
5495 c        endif
5496 c  136   continue
5497 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5498 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5499 C Condition for being inside the proper box
5500 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5501 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5502 c        go to 136
5503 c        endif
5504         do iint=1,nscp_gr(i)
5505
5506         do j=iscpstart(i,iint),iscpend(i,iint)
5507           itypj=iabs(itype(j))
5508           if (itypj.eq.ntyp1) cycle
5509 C Uncomment following three lines for SC-p interactions
5510 c         xj=c(1,nres+j)-xi
5511 c         yj=c(2,nres+j)-yi
5512 c         zj=c(3,nres+j)-zi
5513 C Uncomment following three lines for Ca-p interactions
5514           xj=c(1,j)
5515           yj=c(2,j)
5516           zj=c(3,j)
5517           xj=mod(xj,boxxsize)
5518           if (xj.lt.0) xj=xj+boxxsize
5519           yj=mod(yj,boxysize)
5520           if (yj.lt.0) yj=yj+boxysize
5521           zj=mod(zj,boxzsize)
5522           if (zj.lt.0) zj=zj+boxzsize
5523 c  174   continue
5524 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5525 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5526 C Condition for being inside the proper box
5527 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5528 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5529 c        go to 174
5530 c        endif
5531 c  175   continue
5532 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5533 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5534 cC Condition for being inside the proper box
5535 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5536 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5537 c        go to 175
5538 c        endif
5539 c  176   continue
5540 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5541 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5542 C Condition for being inside the proper box
5543 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5544 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5545 c        go to 176
5546 c        endif
5547 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5548       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5549       xj_safe=xj
5550       yj_safe=yj
5551       zj_safe=zj
5552       subchap=0
5553       do xshift=-1,1
5554       do yshift=-1,1
5555       do zshift=-1,1
5556           xj=xj_safe+xshift*boxxsize
5557           yj=yj_safe+yshift*boxysize
5558           zj=zj_safe+zshift*boxzsize
5559           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5560           if(dist_temp.lt.dist_init) then
5561             dist_init=dist_temp
5562             xj_temp=xj
5563             yj_temp=yj
5564             zj_temp=zj
5565             subchap=1
5566           endif
5567        enddo
5568        enddo
5569        enddo
5570        if (subchap.eq.1) then
5571           xj=xj_temp-xi
5572           yj=yj_temp-yi
5573           zj=zj_temp-zi
5574        else
5575           xj=xj_safe-xi
5576           yj=yj_safe-yi
5577           zj=zj_safe-zi
5578        endif
5579 c          print *,xj,yj,zj,'polozenie j'
5580           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5581 c          print *,rrij
5582           sss=sscale(1.0d0/(dsqrt(rrij)))
5583 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5584 c          if (sss.eq.0) print *,'czasem jest OK'
5585           if (sss.le.0.0d0) cycle
5586           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5587           fac=rrij**expon2
5588           e1=fac*fac*aad(itypj,iteli)
5589           e2=fac*bad(itypj,iteli)
5590           if (iabs(j-i) .le. 2) then
5591             e1=scal14*e1
5592             e2=scal14*e2
5593             evdw2_14=evdw2_14+(e1+e2)*sss
5594           endif
5595           evdwij=e1+e2
5596           evdw2=evdw2+evdwij*sss
5597           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5598      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5599      &       bad(itypj,iteli)
5600 C
5601 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5602 C
5603           fac=-(evdwij+e1)*rrij*sss
5604           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5605           ggg(1)=xj*fac
5606           ggg(2)=yj*fac
5607           ggg(3)=zj*fac
5608 cgrad          if (j.lt.i) then
5609 cd          write (iout,*) 'j<i'
5610 C Uncomment following three lines for SC-p interactions
5611 c           do k=1,3
5612 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5613 c           enddo
5614 cgrad          else
5615 cd          write (iout,*) 'j>i'
5616 cgrad            do k=1,3
5617 cgrad              ggg(k)=-ggg(k)
5618 C Uncomment following line for SC-p interactions
5619 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5620 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5621 cgrad            enddo
5622 cgrad          endif
5623 cgrad          do k=1,3
5624 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5625 cgrad          enddo
5626 cgrad          kstart=min0(i+1,j)
5627 cgrad          kend=max0(i-1,j-1)
5628 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5629 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5630 cgrad          do k=kstart,kend
5631 cgrad            do l=1,3
5632 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5633 cgrad            enddo
5634 cgrad          enddo
5635           do k=1,3
5636             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5637             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5638           enddo
5639 c        endif !endif for sscale cutoff
5640         enddo ! j
5641
5642         enddo ! iint
5643       enddo ! i
5644 c      enddo !zshift
5645 c      enddo !yshift
5646 c      enddo !xshift
5647       do i=1,nct
5648         do j=1,3
5649           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5650           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5651           gradx_scp(j,i)=expon*gradx_scp(j,i)
5652         enddo
5653       enddo
5654 C******************************************************************************
5655 C
5656 C                              N O T E !!!
5657 C
5658 C To save time the factor EXPON has been extracted from ALL components
5659 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5660 C use!
5661 C
5662 C******************************************************************************
5663       return
5664       end
5665 C--------------------------------------------------------------------------
5666       subroutine edis(ehpb)
5667 C
5668 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5669 C
5670       implicit real*8 (a-h,o-z)
5671       include 'DIMENSIONS'
5672       include 'COMMON.SBRIDGE'
5673       include 'COMMON.CHAIN'
5674       include 'COMMON.DERIV'
5675       include 'COMMON.VAR'
5676       include 'COMMON.INTERACT'
5677       include 'COMMON.IOUNITS'
5678       include 'COMMON.CONTROL'
5679       dimension ggg(3)
5680       ehpb=0.0D0
5681       do i=1,3
5682        ggg(i)=0.0d0
5683       enddo
5684 C      write (iout,*) ,"link_end",link_end,constr_dist
5685 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5686 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5687       if (link_end.eq.0) return
5688       do i=link_start,link_end
5689 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5690 C CA-CA distance used in regularization of structure.
5691         ii=ihpb(i)
5692         jj=jhpb(i)
5693 C iii and jjj point to the residues for which the distance is assigned.
5694         if (ii.gt.nres) then
5695           iii=ii-nres
5696           jjj=jj-nres
5697         else
5698           iii=ii
5699           jjj=jj
5700         endif
5701 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5702 c     &    dhpb(i),dhpb1(i),forcon(i)
5703 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5704 C    distance and angle dependent SS bond potential.
5705 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5706 C     & iabs(itype(jjj)).eq.1) then
5707 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5708 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5709         if (.not.dyn_ss .and. i.le.nss) then
5710 C 15/02/13 CC dynamic SSbond - additional check
5711          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5712      & iabs(itype(jjj)).eq.1) then
5713           call ssbond_ene(iii,jjj,eij)
5714           ehpb=ehpb+2*eij
5715          endif
5716 cd          write (iout,*) "eij",eij
5717 cd   &   ' waga=',waga,' fac=',fac
5718         else if (ii.gt.nres .and. jj.gt.nres) then
5719 c Restraints from contact prediction
5720           dd=dist(ii,jj)
5721           if (constr_dist.eq.11) then
5722             ehpb=ehpb+fordepth(i)**4.0d0
5723      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5724             fac=fordepth(i)**4.0d0
5725      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5726           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5727      &    ehpb,fordepth(i),dd
5728            else
5729           if (dhpb1(i).gt.0.0d0) then
5730             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5731             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5732 c            write (iout,*) "beta nmr",
5733 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5734           else
5735             dd=dist(ii,jj)
5736             rdis=dd-dhpb(i)
5737 C Get the force constant corresponding to this distance.
5738             waga=forcon(i)
5739 C Calculate the contribution to energy.
5740             ehpb=ehpb+waga*rdis*rdis
5741 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5742 C
5743 C Evaluate gradient.
5744 C
5745             fac=waga*rdis/dd
5746           endif
5747           endif
5748           do j=1,3
5749             ggg(j)=fac*(c(j,jj)-c(j,ii))
5750           enddo
5751           do j=1,3
5752             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5753             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5754           enddo
5755           do k=1,3
5756             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5757             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5758           enddo
5759         else
5760 C Calculate the distance between the two points and its difference from the
5761 C target distance.
5762           dd=dist(ii,jj)
5763           if (constr_dist.eq.11) then
5764             ehpb=ehpb+fordepth(i)**4.0d0
5765      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5766             fac=fordepth(i)**4.0d0
5767      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5768           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5769      &    ehpb,fordepth(i),dd
5770            else
5771           if (dhpb1(i).gt.0.0d0) then
5772             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5773             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5774 c            write (iout,*) "alph nmr",
5775 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5776           else
5777             rdis=dd-dhpb(i)
5778 C Get the force constant corresponding to this distance.
5779             waga=forcon(i)
5780 C Calculate the contribution to energy.
5781             ehpb=ehpb+waga*rdis*rdis
5782 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5783 C
5784 C Evaluate gradient.
5785 C
5786             fac=waga*rdis/dd
5787           endif
5788           endif
5789             do j=1,3
5790               ggg(j)=fac*(c(j,jj)-c(j,ii))
5791             enddo
5792 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5793 C If this is a SC-SC distance, we need to calculate the contributions to the
5794 C Cartesian gradient in the SC vectors (ghpbx).
5795           if (iii.lt.ii) then
5796           do j=1,3
5797             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5798             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5799           enddo
5800           endif
5801 cgrad        do j=iii,jjj-1
5802 cgrad          do k=1,3
5803 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5804 cgrad          enddo
5805 cgrad        enddo
5806           do k=1,3
5807             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5808             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5809           enddo
5810         endif
5811       enddo
5812       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5813       return
5814       end
5815 C--------------------------------------------------------------------------
5816       subroutine ssbond_ene(i,j,eij)
5817 C
5818 C Calculate the distance and angle dependent SS-bond potential energy
5819 C using a free-energy function derived based on RHF/6-31G** ab initio
5820 C calculations of diethyl disulfide.
5821 C
5822 C A. Liwo and U. Kozlowska, 11/24/03
5823 C
5824       implicit real*8 (a-h,o-z)
5825       include 'DIMENSIONS'
5826       include 'COMMON.SBRIDGE'
5827       include 'COMMON.CHAIN'
5828       include 'COMMON.DERIV'
5829       include 'COMMON.LOCAL'
5830       include 'COMMON.INTERACT'
5831       include 'COMMON.VAR'
5832       include 'COMMON.IOUNITS'
5833       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5834       itypi=iabs(itype(i))
5835       xi=c(1,nres+i)
5836       yi=c(2,nres+i)
5837       zi=c(3,nres+i)
5838       dxi=dc_norm(1,nres+i)
5839       dyi=dc_norm(2,nres+i)
5840       dzi=dc_norm(3,nres+i)
5841 c      dsci_inv=dsc_inv(itypi)
5842       dsci_inv=vbld_inv(nres+i)
5843       itypj=iabs(itype(j))
5844 c      dscj_inv=dsc_inv(itypj)
5845       dscj_inv=vbld_inv(nres+j)
5846       xj=c(1,nres+j)-xi
5847       yj=c(2,nres+j)-yi
5848       zj=c(3,nres+j)-zi
5849       dxj=dc_norm(1,nres+j)
5850       dyj=dc_norm(2,nres+j)
5851       dzj=dc_norm(3,nres+j)
5852       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5853       rij=dsqrt(rrij)
5854       erij(1)=xj*rij
5855       erij(2)=yj*rij
5856       erij(3)=zj*rij
5857       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5858       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5859       om12=dxi*dxj+dyi*dyj+dzi*dzj
5860       do k=1,3
5861         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5862         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5863       enddo
5864       rij=1.0d0/rij
5865       deltad=rij-d0cm
5866       deltat1=1.0d0-om1
5867       deltat2=1.0d0+om2
5868       deltat12=om2-om1+2.0d0
5869       cosphi=om12-om1*om2
5870       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5871      &  +akct*deltad*deltat12
5872      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5873 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5874 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5875 c     &  " deltat12",deltat12," eij",eij
5876       ed=2*akcm*deltad+akct*deltat12
5877       pom1=akct*deltad
5878       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5879       eom1=-2*akth*deltat1-pom1-om2*pom2
5880       eom2= 2*akth*deltat2+pom1-om1*pom2
5881       eom12=pom2
5882       do k=1,3
5883         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5884         ghpbx(k,i)=ghpbx(k,i)-ggk
5885      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5886      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5887         ghpbx(k,j)=ghpbx(k,j)+ggk
5888      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5889      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5890         ghpbc(k,i)=ghpbc(k,i)-ggk
5891         ghpbc(k,j)=ghpbc(k,j)+ggk
5892       enddo
5893 C
5894 C Calculate the components of the gradient in DC and X
5895 C
5896 cgrad      do k=i,j-1
5897 cgrad        do l=1,3
5898 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5899 cgrad        enddo
5900 cgrad      enddo
5901       return
5902       end
5903 C--------------------------------------------------------------------------
5904       subroutine ebond(estr)
5905 c
5906 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5907 c
5908       implicit real*8 (a-h,o-z)
5909       include 'DIMENSIONS'
5910       include 'COMMON.LOCAL'
5911       include 'COMMON.GEO'
5912       include 'COMMON.INTERACT'
5913       include 'COMMON.DERIV'
5914       include 'COMMON.VAR'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.IOUNITS'
5917       include 'COMMON.NAMES'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.CONTROL'
5920       include 'COMMON.SETUP'
5921       double precision u(3),ud(3)
5922       estr=0.0d0
5923       estr1=0.0d0
5924       do i=ibondp_start,ibondp_end
5925         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5926 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5927 c          do j=1,3
5928 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5929 c     &      *dc(j,i-1)/vbld(i)
5930 c          enddo
5931 c          if (energy_dec) write(iout,*)
5932 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5933 c        else
5934 C       Checking if it involves dummy (NH3+ or COO-) group
5935          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5936 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5937         diff = vbld(i)-vbldpDUM
5938         if (energy_dec) write(iout,*) "dum_bond",i,diff
5939          else
5940 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5941         diff = vbld(i)-vbldp0
5942          endif
5943         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5944      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5945         estr=estr+diff*diff
5946         do j=1,3
5947           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5948         enddo
5949 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5950 c        endif
5951       enddo
5952
5953       estr=0.5d0*AKP*estr+estr1
5954 c
5955 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5956 c
5957       do i=ibond_start,ibond_end
5958         iti=iabs(itype(i))
5959         if (iti.ne.10 .and. iti.ne.ntyp1) then
5960           nbi=nbondterm(iti)
5961           if (nbi.eq.1) then
5962             diff=vbld(i+nres)-vbldsc0(1,iti)
5963             if (energy_dec)  write (iout,*)
5964      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5965      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5966             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5967             do j=1,3
5968               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5969             enddo
5970           else
5971             do j=1,nbi
5972               diff=vbld(i+nres)-vbldsc0(j,iti)
5973               ud(j)=aksc(j,iti)*diff
5974               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5975             enddo
5976             uprod=u(1)
5977             do j=2,nbi
5978               uprod=uprod*u(j)
5979             enddo
5980             usum=0.0d0
5981             usumsqder=0.0d0
5982             do j=1,nbi
5983               uprod1=1.0d0
5984               uprod2=1.0d0
5985               do k=1,nbi
5986                 if (k.ne.j) then
5987                   uprod1=uprod1*u(k)
5988                   uprod2=uprod2*u(k)*u(k)
5989                 endif
5990               enddo
5991               usum=usum+uprod1
5992               usumsqder=usumsqder+ud(j)*uprod2
5993             enddo
5994             estr=estr+uprod/usum
5995             do j=1,3
5996              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5997             enddo
5998           endif
5999         endif
6000       enddo
6001       return
6002       end
6003 #ifdef CRYST_THETA
6004 C--------------------------------------------------------------------------
6005       subroutine ebend(etheta,ethetacnstr)
6006 C
6007 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6008 C angles gamma and its derivatives in consecutive thetas and gammas.
6009 C
6010       implicit real*8 (a-h,o-z)
6011       include 'DIMENSIONS'
6012       include 'COMMON.LOCAL'
6013       include 'COMMON.GEO'
6014       include 'COMMON.INTERACT'
6015       include 'COMMON.DERIV'
6016       include 'COMMON.VAR'
6017       include 'COMMON.CHAIN'
6018       include 'COMMON.IOUNITS'
6019       include 'COMMON.NAMES'
6020       include 'COMMON.FFIELD'
6021       include 'COMMON.CONTROL'
6022       include 'COMMON.TORCNSTR'
6023       common /calcthet/ term1,term2,termm,diffak,ratak,
6024      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6025      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6026       double precision y(2),z(2)
6027       delta=0.02d0*pi
6028 c      time11=dexp(-2*time)
6029 c      time12=1.0d0
6030       etheta=0.0D0
6031 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6032       do i=ithet_start,ithet_end
6033         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6034      &  .or.itype(i).eq.ntyp1) cycle
6035 C Zero the energy function and its derivative at 0 or pi.
6036         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6037         it=itype(i-1)
6038         ichir1=isign(1,itype(i-2))
6039         ichir2=isign(1,itype(i))
6040          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6041          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6042          if (itype(i-1).eq.10) then
6043           itype1=isign(10,itype(i-2))
6044           ichir11=isign(1,itype(i-2))
6045           ichir12=isign(1,itype(i-2))
6046           itype2=isign(10,itype(i))
6047           ichir21=isign(1,itype(i))
6048           ichir22=isign(1,itype(i))
6049          endif
6050
6051         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6052 #ifdef OSF
6053           phii=phi(i)
6054           if (phii.ne.phii) phii=150.0
6055 #else
6056           phii=phi(i)
6057 #endif
6058           y(1)=dcos(phii)
6059           y(2)=dsin(phii)
6060         else
6061           y(1)=0.0D0
6062           y(2)=0.0D0
6063         endif
6064         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6065 #ifdef OSF
6066           phii1=phi(i+1)
6067           if (phii1.ne.phii1) phii1=150.0
6068           phii1=pinorm(phii1)
6069           z(1)=cos(phii1)
6070 #else
6071           phii1=phi(i+1)
6072 #endif
6073           z(1)=dcos(phii1)
6074           z(2)=dsin(phii1)
6075         else
6076           z(1)=0.0D0
6077           z(2)=0.0D0
6078         endif
6079 C Calculate the "mean" value of theta from the part of the distribution
6080 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6081 C In following comments this theta will be referred to as t_c.
6082         thet_pred_mean=0.0d0
6083         do k=1,2
6084             athetk=athet(k,it,ichir1,ichir2)
6085             bthetk=bthet(k,it,ichir1,ichir2)
6086           if (it.eq.10) then
6087              athetk=athet(k,itype1,ichir11,ichir12)
6088              bthetk=bthet(k,itype2,ichir21,ichir22)
6089           endif
6090          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6091 c         write(iout,*) 'chuj tu', y(k),z(k)
6092         enddo
6093         dthett=thet_pred_mean*ssd
6094         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6095 C Derivatives of the "mean" values in gamma1 and gamma2.
6096         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6097      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6098          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6099      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6100          if (it.eq.10) then
6101       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6102      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6103         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6104      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6105          endif
6106         if (theta(i).gt.pi-delta) then
6107           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6108      &         E_tc0)
6109           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6110           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6111           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6112      &        E_theta)
6113           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6114      &        E_tc)
6115         else if (theta(i).lt.delta) then
6116           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6117           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6118           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6119      &        E_theta)
6120           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6121           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6122      &        E_tc)
6123         else
6124           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6125      &        E_theta,E_tc)
6126         endif
6127         etheta=etheta+ethetai
6128         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6129      &      'ebend',i,ethetai,theta(i),itype(i)
6130         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6131         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6132         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6133       enddo
6134       ethetacnstr=0.0d0
6135 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6136       do i=ithetaconstr_start,ithetaconstr_end
6137         itheta=itheta_constr(i)
6138         thetiii=theta(itheta)
6139         difi=pinorm(thetiii-theta_constr0(i))
6140         if (difi.gt.theta_drange(i)) then
6141           difi=difi-theta_drange(i)
6142           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6143           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6144      &    +for_thet_constr(i)*difi**3
6145         else if (difi.lt.-drange(i)) then
6146           difi=difi+drange(i)
6147           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6148           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6149      &    +for_thet_constr(i)*difi**3
6150         else
6151           difi=0.0
6152         endif
6153        if (energy_dec) then
6154         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6155      &    i,itheta,rad2deg*thetiii,
6156      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6157      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6158      &    gloc(itheta+nphi-2,icg)
6159         endif
6160       enddo
6161
6162 C Ufff.... We've done all this!!!
6163       return
6164       end
6165 C---------------------------------------------------------------------------
6166       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6167      &     E_tc)
6168       implicit real*8 (a-h,o-z)
6169       include 'DIMENSIONS'
6170       include 'COMMON.LOCAL'
6171       include 'COMMON.IOUNITS'
6172       common /calcthet/ term1,term2,termm,diffak,ratak,
6173      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6174      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6175 C Calculate the contributions to both Gaussian lobes.
6176 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6177 C The "polynomial part" of the "standard deviation" of this part of
6178 C the distributioni.
6179 ccc        write (iout,*) thetai,thet_pred_mean
6180         sig=polthet(3,it)
6181         do j=2,0,-1
6182           sig=sig*thet_pred_mean+polthet(j,it)
6183         enddo
6184 C Derivative of the "interior part" of the "standard deviation of the"
6185 C gamma-dependent Gaussian lobe in t_c.
6186         sigtc=3*polthet(3,it)
6187         do j=2,1,-1
6188           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6189         enddo
6190         sigtc=sig*sigtc
6191 C Set the parameters of both Gaussian lobes of the distribution.
6192 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6193         fac=sig*sig+sigc0(it)
6194         sigcsq=fac+fac
6195         sigc=1.0D0/sigcsq
6196 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6197         sigsqtc=-4.0D0*sigcsq*sigtc
6198 c       print *,i,sig,sigtc,sigsqtc
6199 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6200         sigtc=-sigtc/(fac*fac)
6201 C Following variable is sigma(t_c)**(-2)
6202         sigcsq=sigcsq*sigcsq
6203         sig0i=sig0(it)
6204         sig0inv=1.0D0/sig0i**2
6205         delthec=thetai-thet_pred_mean
6206         delthe0=thetai-theta0i
6207         term1=-0.5D0*sigcsq*delthec*delthec
6208         term2=-0.5D0*sig0inv*delthe0*delthe0
6209 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6210 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6211 C NaNs in taking the logarithm. We extract the largest exponent which is added
6212 C to the energy (this being the log of the distribution) at the end of energy
6213 C term evaluation for this virtual-bond angle.
6214         if (term1.gt.term2) then
6215           termm=term1
6216           term2=dexp(term2-termm)
6217           term1=1.0d0
6218         else
6219           termm=term2
6220           term1=dexp(term1-termm)
6221           term2=1.0d0
6222         endif
6223 C The ratio between the gamma-independent and gamma-dependent lobes of
6224 C the distribution is a Gaussian function of thet_pred_mean too.
6225         diffak=gthet(2,it)-thet_pred_mean
6226         ratak=diffak/gthet(3,it)**2
6227         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6228 C Let's differentiate it in thet_pred_mean NOW.
6229         aktc=ak*ratak
6230 C Now put together the distribution terms to make complete distribution.
6231         termexp=term1+ak*term2
6232         termpre=sigc+ak*sig0i
6233 C Contribution of the bending energy from this theta is just the -log of
6234 C the sum of the contributions from the two lobes and the pre-exponential
6235 C factor. Simple enough, isn't it?
6236         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6237 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6238 C NOW the derivatives!!!
6239 C 6/6/97 Take into account the deformation.
6240         E_theta=(delthec*sigcsq*term1
6241      &       +ak*delthe0*sig0inv*term2)/termexp
6242         E_tc=((sigtc+aktc*sig0i)/termpre
6243      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6244      &       aktc*term2)/termexp)
6245       return
6246       end
6247 c-----------------------------------------------------------------------------
6248       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6249       implicit real*8 (a-h,o-z)
6250       include 'DIMENSIONS'
6251       include 'COMMON.LOCAL'
6252       include 'COMMON.IOUNITS'
6253       common /calcthet/ term1,term2,termm,diffak,ratak,
6254      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6255      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6256       delthec=thetai-thet_pred_mean
6257       delthe0=thetai-theta0i
6258 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6259       t3 = thetai-thet_pred_mean
6260       t6 = t3**2
6261       t9 = term1
6262       t12 = t3*sigcsq
6263       t14 = t12+t6*sigsqtc
6264       t16 = 1.0d0
6265       t21 = thetai-theta0i
6266       t23 = t21**2
6267       t26 = term2
6268       t27 = t21*t26
6269       t32 = termexp
6270       t40 = t32**2
6271       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6272      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6273      & *(-t12*t9-ak*sig0inv*t27)
6274       return
6275       end
6276 #else
6277 C--------------------------------------------------------------------------
6278       subroutine ebend(etheta,ethetacnstr)
6279 C
6280 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6281 C angles gamma and its derivatives in consecutive thetas and gammas.
6282 C ab initio-derived potentials from
6283 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6284 C
6285       implicit real*8 (a-h,o-z)
6286       include 'DIMENSIONS'
6287       include 'COMMON.LOCAL'
6288       include 'COMMON.GEO'
6289       include 'COMMON.INTERACT'
6290       include 'COMMON.DERIV'
6291       include 'COMMON.VAR'
6292       include 'COMMON.CHAIN'
6293       include 'COMMON.IOUNITS'
6294       include 'COMMON.NAMES'
6295       include 'COMMON.FFIELD'
6296       include 'COMMON.CONTROL'
6297       include 'COMMON.TORCNSTR'
6298       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6299      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6300      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6301      & sinph1ph2(maxdouble,maxdouble)
6302       logical lprn /.false./, lprn1 /.false./
6303       etheta=0.0D0
6304       do i=ithet_start,ithet_end
6305 c        print *,i,itype(i-1),itype(i),itype(i-2)
6306         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6307      &  .or.itype(i).eq.ntyp1) cycle
6308 C        print *,i,theta(i)
6309         if (iabs(itype(i+1)).eq.20) iblock=2
6310         if (iabs(itype(i+1)).ne.20) iblock=1
6311         dethetai=0.0d0
6312         dephii=0.0d0
6313         dephii1=0.0d0
6314         theti2=0.5d0*theta(i)
6315         ityp2=ithetyp((itype(i-1)))
6316         do k=1,nntheterm
6317           coskt(k)=dcos(k*theti2)
6318           sinkt(k)=dsin(k*theti2)
6319         enddo
6320 C        print *,ethetai
6321         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6322 #ifdef OSF
6323           phii=phi(i)
6324           if (phii.ne.phii) phii=150.0
6325 #else
6326           phii=phi(i)
6327 #endif
6328           ityp1=ithetyp((itype(i-2)))
6329 C propagation of chirality for glycine type
6330           do k=1,nsingle
6331             cosph1(k)=dcos(k*phii)
6332             sinph1(k)=dsin(k*phii)
6333           enddo
6334         else
6335           phii=0.0d0
6336           do k=1,nsingle
6337           ityp1=ithetyp((itype(i-2)))
6338             cosph1(k)=0.0d0
6339             sinph1(k)=0.0d0
6340           enddo
6341         endif
6342         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6343 #ifdef OSF
6344           phii1=phi(i+1)
6345           if (phii1.ne.phii1) phii1=150.0
6346           phii1=pinorm(phii1)
6347 #else
6348           phii1=phi(i+1)
6349 #endif
6350           ityp3=ithetyp((itype(i)))
6351           do k=1,nsingle
6352             cosph2(k)=dcos(k*phii1)
6353             sinph2(k)=dsin(k*phii1)
6354           enddo
6355         else
6356           phii1=0.0d0
6357           ityp3=ithetyp((itype(i)))
6358           do k=1,nsingle
6359             cosph2(k)=0.0d0
6360             sinph2(k)=0.0d0
6361           enddo
6362         endif
6363         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6364         do k=1,ndouble
6365           do l=1,k-1
6366             ccl=cosph1(l)*cosph2(k-l)
6367             ssl=sinph1(l)*sinph2(k-l)
6368             scl=sinph1(l)*cosph2(k-l)
6369             csl=cosph1(l)*sinph2(k-l)
6370             cosph1ph2(l,k)=ccl-ssl
6371             cosph1ph2(k,l)=ccl+ssl
6372             sinph1ph2(l,k)=scl+csl
6373             sinph1ph2(k,l)=scl-csl
6374           enddo
6375         enddo
6376         if (lprn) then
6377         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6378      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6379         write (iout,*) "coskt and sinkt"
6380         do k=1,nntheterm
6381           write (iout,*) k,coskt(k),sinkt(k)
6382         enddo
6383         endif
6384         do k=1,ntheterm
6385           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6386           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6387      &      *coskt(k)
6388           if (lprn)
6389      &    write (iout,*) "k",k,"
6390      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6391      &     " ethetai",ethetai
6392         enddo
6393         if (lprn) then
6394         write (iout,*) "cosph and sinph"
6395         do k=1,nsingle
6396           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6397         enddo
6398         write (iout,*) "cosph1ph2 and sinph2ph2"
6399         do k=2,ndouble
6400           do l=1,k-1
6401             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6402      &         sinph1ph2(l,k),sinph1ph2(k,l)
6403           enddo
6404         enddo
6405         write(iout,*) "ethetai",ethetai
6406         endif
6407 C       print *,ethetai
6408         do m=1,ntheterm2
6409           do k=1,nsingle
6410             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6411      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6412      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6413      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6414             ethetai=ethetai+sinkt(m)*aux
6415             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6416             dephii=dephii+k*sinkt(m)*(
6417      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6418      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6419             dephii1=dephii1+k*sinkt(m)*(
6420      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6421      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6422             if (lprn)
6423      &      write (iout,*) "m",m," k",k," bbthet",
6424      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6425      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6426      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6427      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6428 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6429           enddo
6430         enddo
6431 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6432 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6433 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6434 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6435         if (lprn)
6436      &  write(iout,*) "ethetai",ethetai
6437 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6438         do m=1,ntheterm3
6439           do k=2,ndouble
6440             do l=1,k-1
6441               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6442      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6443      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6444      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6445               ethetai=ethetai+sinkt(m)*aux
6446               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6447               dephii=dephii+l*sinkt(m)*(
6448      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6449      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6450      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6451      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6452               dephii1=dephii1+(k-l)*sinkt(m)*(
6453      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6454      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6455      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6456      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6457               if (lprn) then
6458               write (iout,*) "m",m," k",k," l",l," ffthet",
6459      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6460      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6461      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6462      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6463      &            " ethetai",ethetai
6464               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6465      &            cosph1ph2(k,l)*sinkt(m),
6466      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6467               endif
6468             enddo
6469           enddo
6470         enddo
6471 10      continue
6472 c        lprn1=.true.
6473 C        print *,ethetai
6474         if (lprn1)
6475      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6476      &   i,theta(i)*rad2deg,phii*rad2deg,
6477      &   phii1*rad2deg,ethetai
6478 c        lprn1=.false.
6479         etheta=etheta+ethetai
6480         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6481         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6482         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6483       enddo
6484 C now constrains
6485       ethetacnstr=0.0d0
6486 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6487       do i=ithetaconstr_start,ithetaconstr_end
6488         itheta=itheta_constr(i)
6489         thetiii=theta(itheta)
6490         difi=pinorm(thetiii-theta_constr0(i))
6491         if (difi.gt.theta_drange(i)) then
6492           difi=difi-theta_drange(i)
6493           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6494           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6495      &    +for_thet_constr(i)*difi**3
6496         else if (difi.lt.-drange(i)) then
6497           difi=difi+drange(i)
6498           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6499           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6500      &    +for_thet_constr(i)*difi**3
6501         else
6502           difi=0.0
6503         endif
6504        if (energy_dec) then
6505         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6506      &    i,itheta,rad2deg*thetiii,
6507      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6508      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6509      &    gloc(itheta+nphi-2,icg)
6510         endif
6511       enddo
6512
6513       return
6514       end
6515 #endif
6516 #ifdef CRYST_SC
6517 c-----------------------------------------------------------------------------
6518       subroutine esc(escloc)
6519 C Calculate the local energy of a side chain and its derivatives in the
6520 C corresponding virtual-bond valence angles THETA and the spherical angles
6521 C ALPHA and OMEGA.
6522       implicit real*8 (a-h,o-z)
6523       include 'DIMENSIONS'
6524       include 'COMMON.GEO'
6525       include 'COMMON.LOCAL'
6526       include 'COMMON.VAR'
6527       include 'COMMON.INTERACT'
6528       include 'COMMON.DERIV'
6529       include 'COMMON.CHAIN'
6530       include 'COMMON.IOUNITS'
6531       include 'COMMON.NAMES'
6532       include 'COMMON.FFIELD'
6533       include 'COMMON.CONTROL'
6534       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6535      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6536       common /sccalc/ time11,time12,time112,theti,it,nlobit
6537       delta=0.02d0*pi
6538       escloc=0.0D0
6539 c     write (iout,'(a)') 'ESC'
6540       do i=loc_start,loc_end
6541         it=itype(i)
6542         if (it.eq.ntyp1) cycle
6543         if (it.eq.10) goto 1
6544         nlobit=nlob(iabs(it))
6545 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6546 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6547         theti=theta(i+1)-pipol
6548         x(1)=dtan(theti)
6549         x(2)=alph(i)
6550         x(3)=omeg(i)
6551
6552         if (x(2).gt.pi-delta) then
6553           xtemp(1)=x(1)
6554           xtemp(2)=pi-delta
6555           xtemp(3)=x(3)
6556           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6557           xtemp(2)=pi
6558           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6559           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6560      &        escloci,dersc(2))
6561           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6562      &        ddersc0(1),dersc(1))
6563           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6564      &        ddersc0(3),dersc(3))
6565           xtemp(2)=pi-delta
6566           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6567           xtemp(2)=pi
6568           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6569           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6570      &            dersc0(2),esclocbi,dersc02)
6571           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6572      &            dersc12,dersc01)
6573           call splinthet(x(2),0.5d0*delta,ss,ssd)
6574           dersc0(1)=dersc01
6575           dersc0(2)=dersc02
6576           dersc0(3)=0.0d0
6577           do k=1,3
6578             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6579           enddo
6580           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6581 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6582 c    &             esclocbi,ss,ssd
6583           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6584 c         escloci=esclocbi
6585 c         write (iout,*) escloci
6586         else if (x(2).lt.delta) then
6587           xtemp(1)=x(1)
6588           xtemp(2)=delta
6589           xtemp(3)=x(3)
6590           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6591           xtemp(2)=0.0d0
6592           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6593           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6594      &        escloci,dersc(2))
6595           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6596      &        ddersc0(1),dersc(1))
6597           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6598      &        ddersc0(3),dersc(3))
6599           xtemp(2)=delta
6600           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6601           xtemp(2)=0.0d0
6602           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6603           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6604      &            dersc0(2),esclocbi,dersc02)
6605           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6606      &            dersc12,dersc01)
6607           dersc0(1)=dersc01
6608           dersc0(2)=dersc02
6609           dersc0(3)=0.0d0
6610           call splinthet(x(2),0.5d0*delta,ss,ssd)
6611           do k=1,3
6612             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6613           enddo
6614           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6615 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6616 c    &             esclocbi,ss,ssd
6617           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6618 c         write (iout,*) escloci
6619         else
6620           call enesc(x,escloci,dersc,ddummy,.false.)
6621         endif
6622
6623         escloc=escloc+escloci
6624         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6625      &     'escloc',i,escloci
6626 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6627
6628         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6629      &   wscloc*dersc(1)
6630         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6631         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6632     1   continue
6633       enddo
6634       return
6635       end
6636 C---------------------------------------------------------------------------
6637       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6638       implicit real*8 (a-h,o-z)
6639       include 'DIMENSIONS'
6640       include 'COMMON.GEO'
6641       include 'COMMON.LOCAL'
6642       include 'COMMON.IOUNITS'
6643       common /sccalc/ time11,time12,time112,theti,it,nlobit
6644       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6645       double precision contr(maxlob,-1:1)
6646       logical mixed
6647 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6648         escloc_i=0.0D0
6649         do j=1,3
6650           dersc(j)=0.0D0
6651           if (mixed) ddersc(j)=0.0d0
6652         enddo
6653         x3=x(3)
6654
6655 C Because of periodicity of the dependence of the SC energy in omega we have
6656 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6657 C To avoid underflows, first compute & store the exponents.
6658
6659         do iii=-1,1
6660
6661           x(3)=x3+iii*dwapi
6662
6663           do j=1,nlobit
6664             do k=1,3
6665               z(k)=x(k)-censc(k,j,it)
6666             enddo
6667             do k=1,3
6668               Axk=0.0D0
6669               do l=1,3
6670                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6671               enddo
6672               Ax(k,j,iii)=Axk
6673             enddo
6674             expfac=0.0D0
6675             do k=1,3
6676               expfac=expfac+Ax(k,j,iii)*z(k)
6677             enddo
6678             contr(j,iii)=expfac
6679           enddo ! j
6680
6681         enddo ! iii
6682
6683         x(3)=x3
6684 C As in the case of ebend, we want to avoid underflows in exponentiation and
6685 C subsequent NaNs and INFs in energy calculation.
6686 C Find the largest exponent
6687         emin=contr(1,-1)
6688         do iii=-1,1
6689           do j=1,nlobit
6690             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6691           enddo
6692         enddo
6693         emin=0.5D0*emin
6694 cd      print *,'it=',it,' emin=',emin
6695
6696 C Compute the contribution to SC energy and derivatives
6697         do iii=-1,1
6698
6699           do j=1,nlobit
6700 #ifdef OSF
6701             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6702             if(adexp.ne.adexp) adexp=1.0
6703             expfac=dexp(adexp)
6704 #else
6705             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6706 #endif
6707 cd          print *,'j=',j,' expfac=',expfac
6708             escloc_i=escloc_i+expfac
6709             do k=1,3
6710               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6711             enddo
6712             if (mixed) then
6713               do k=1,3,2
6714                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6715      &            +gaussc(k,2,j,it))*expfac
6716               enddo
6717             endif
6718           enddo
6719
6720         enddo ! iii
6721
6722         dersc(1)=dersc(1)/cos(theti)**2
6723         ddersc(1)=ddersc(1)/cos(theti)**2
6724         ddersc(3)=ddersc(3)
6725
6726         escloci=-(dlog(escloc_i)-emin)
6727         do j=1,3
6728           dersc(j)=dersc(j)/escloc_i
6729         enddo
6730         if (mixed) then
6731           do j=1,3,2
6732             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6733           enddo
6734         endif
6735       return
6736       end
6737 C------------------------------------------------------------------------------
6738       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6739       implicit real*8 (a-h,o-z)
6740       include 'DIMENSIONS'
6741       include 'COMMON.GEO'
6742       include 'COMMON.LOCAL'
6743       include 'COMMON.IOUNITS'
6744       common /sccalc/ time11,time12,time112,theti,it,nlobit
6745       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6746       double precision contr(maxlob)
6747       logical mixed
6748
6749       escloc_i=0.0D0
6750
6751       do j=1,3
6752         dersc(j)=0.0D0
6753       enddo
6754
6755       do j=1,nlobit
6756         do k=1,2
6757           z(k)=x(k)-censc(k,j,it)
6758         enddo
6759         z(3)=dwapi
6760         do k=1,3
6761           Axk=0.0D0
6762           do l=1,3
6763             Axk=Axk+gaussc(l,k,j,it)*z(l)
6764           enddo
6765           Ax(k,j)=Axk
6766         enddo
6767         expfac=0.0D0
6768         do k=1,3
6769           expfac=expfac+Ax(k,j)*z(k)
6770         enddo
6771         contr(j)=expfac
6772       enddo ! j
6773
6774 C As in the case of ebend, we want to avoid underflows in exponentiation and
6775 C subsequent NaNs and INFs in energy calculation.
6776 C Find the largest exponent
6777       emin=contr(1)
6778       do j=1,nlobit
6779         if (emin.gt.contr(j)) emin=contr(j)
6780       enddo
6781       emin=0.5D0*emin
6782
6783 C Compute the contribution to SC energy and derivatives
6784
6785       dersc12=0.0d0
6786       do j=1,nlobit
6787         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6788         escloc_i=escloc_i+expfac
6789         do k=1,2
6790           dersc(k)=dersc(k)+Ax(k,j)*expfac
6791         enddo
6792         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6793      &            +gaussc(1,2,j,it))*expfac
6794         dersc(3)=0.0d0
6795       enddo
6796
6797       dersc(1)=dersc(1)/cos(theti)**2
6798       dersc12=dersc12/cos(theti)**2
6799       escloci=-(dlog(escloc_i)-emin)
6800       do j=1,2
6801         dersc(j)=dersc(j)/escloc_i
6802       enddo
6803       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6804       return
6805       end
6806 #else
6807 c----------------------------------------------------------------------------------
6808       subroutine esc(escloc)
6809 C Calculate the local energy of a side chain and its derivatives in the
6810 C corresponding virtual-bond valence angles THETA and the spherical angles
6811 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6812 C added by Urszula Kozlowska. 07/11/2007
6813 C
6814       implicit real*8 (a-h,o-z)
6815       include 'DIMENSIONS'
6816       include 'COMMON.GEO'
6817       include 'COMMON.LOCAL'
6818       include 'COMMON.VAR'
6819       include 'COMMON.SCROT'
6820       include 'COMMON.INTERACT'
6821       include 'COMMON.DERIV'
6822       include 'COMMON.CHAIN'
6823       include 'COMMON.IOUNITS'
6824       include 'COMMON.NAMES'
6825       include 'COMMON.FFIELD'
6826       include 'COMMON.CONTROL'
6827       include 'COMMON.VECTORS'
6828       double precision x_prime(3),y_prime(3),z_prime(3)
6829      &    , sumene,dsc_i,dp2_i,x(65),
6830      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6831      &    de_dxx,de_dyy,de_dzz,de_dt
6832       double precision s1_t,s1_6_t,s2_t,s2_6_t
6833       double precision
6834      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6835      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6836      & dt_dCi(3),dt_dCi1(3)
6837       common /sccalc/ time11,time12,time112,theti,it,nlobit
6838       delta=0.02d0*pi
6839       escloc=0.0D0
6840       do i=loc_start,loc_end
6841         if (itype(i).eq.ntyp1) cycle
6842         costtab(i+1) =dcos(theta(i+1))
6843         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6844         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6845         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6846         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6847         cosfac=dsqrt(cosfac2)
6848         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6849         sinfac=dsqrt(sinfac2)
6850         it=iabs(itype(i))
6851         if (it.eq.10) goto 1
6852 c
6853 C  Compute the axes of tghe local cartesian coordinates system; store in
6854 c   x_prime, y_prime and z_prime
6855 c
6856         do j=1,3
6857           x_prime(j) = 0.00
6858           y_prime(j) = 0.00
6859           z_prime(j) = 0.00
6860         enddo
6861 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6862 C     &   dc_norm(3,i+nres)
6863         do j = 1,3
6864           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6865           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6866         enddo
6867         do j = 1,3
6868           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6869         enddo
6870 c       write (2,*) "i",i
6871 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6872 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6873 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6874 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6875 c      & " xy",scalar(x_prime(1),y_prime(1)),
6876 c      & " xz",scalar(x_prime(1),z_prime(1)),
6877 c      & " yy",scalar(y_prime(1),y_prime(1)),
6878 c      & " yz",scalar(y_prime(1),z_prime(1)),
6879 c      & " zz",scalar(z_prime(1),z_prime(1))
6880 c
6881 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6882 C to local coordinate system. Store in xx, yy, zz.
6883 c
6884         xx=0.0d0
6885         yy=0.0d0
6886         zz=0.0d0
6887         do j = 1,3
6888           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6889           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6890           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6891         enddo
6892
6893         xxtab(i)=xx
6894         yytab(i)=yy
6895         zztab(i)=zz
6896 C
6897 C Compute the energy of the ith side cbain
6898 C
6899 c        write (2,*) "xx",xx," yy",yy," zz",zz
6900         it=iabs(itype(i))
6901         do j = 1,65
6902           x(j) = sc_parmin(j,it)
6903         enddo
6904 #ifdef CHECK_COORD
6905 Cc diagnostics - remove later
6906         xx1 = dcos(alph(2))
6907         yy1 = dsin(alph(2))*dcos(omeg(2))
6908         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6909         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6910      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6911      &    xx1,yy1,zz1
6912 C,"  --- ", xx_w,yy_w,zz_w
6913 c end diagnostics
6914 #endif
6915         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6916      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6917      &   + x(10)*yy*zz
6918         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6919      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6920      & + x(20)*yy*zz
6921         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6922      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6923      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6924      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6925      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6926      &  +x(40)*xx*yy*zz
6927         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6928      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6929      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6930      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6931      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6932      &  +x(60)*xx*yy*zz
6933         dsc_i   = 0.743d0+x(61)
6934         dp2_i   = 1.9d0+x(62)
6935         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6936      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6937         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6938      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6939         s1=(1+x(63))/(0.1d0 + dscp1)
6940         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6941         s2=(1+x(65))/(0.1d0 + dscp2)
6942         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6943         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6944      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6945 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6946 c     &   sumene4,
6947 c     &   dscp1,dscp2,sumene
6948 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6949         escloc = escloc + sumene
6950 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6951 c     & ,zz,xx,yy
6952 c#define DEBUG
6953 #ifdef DEBUG
6954 C
6955 C This section to check the numerical derivatives of the energy of ith side
6956 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6957 C #define DEBUG in the code to turn it on.
6958 C
6959         write (2,*) "sumene               =",sumene
6960         aincr=1.0d-7
6961         xxsave=xx
6962         xx=xx+aincr
6963         write (2,*) xx,yy,zz
6964         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6965         de_dxx_num=(sumenep-sumene)/aincr
6966         xx=xxsave
6967         write (2,*) "xx+ sumene from enesc=",sumenep
6968         yysave=yy
6969         yy=yy+aincr
6970         write (2,*) xx,yy,zz
6971         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6972         de_dyy_num=(sumenep-sumene)/aincr
6973         yy=yysave
6974         write (2,*) "yy+ sumene from enesc=",sumenep
6975         zzsave=zz
6976         zz=zz+aincr
6977         write (2,*) xx,yy,zz
6978         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6979         de_dzz_num=(sumenep-sumene)/aincr
6980         zz=zzsave
6981         write (2,*) "zz+ sumene from enesc=",sumenep
6982         costsave=cost2tab(i+1)
6983         sintsave=sint2tab(i+1)
6984         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6985         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6986         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6987         de_dt_num=(sumenep-sumene)/aincr
6988         write (2,*) " t+ sumene from enesc=",sumenep
6989         cost2tab(i+1)=costsave
6990         sint2tab(i+1)=sintsave
6991 C End of diagnostics section.
6992 #endif
6993 C
6994 C Compute the gradient of esc
6995 C
6996 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6997         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6998         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6999         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7000         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7001         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7002         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7003         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7004         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7005         pom1=(sumene3*sint2tab(i+1)+sumene1)
7006      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7007         pom2=(sumene4*cost2tab(i+1)+sumene2)
7008      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7009         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7010         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7011      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7012      &  +x(40)*yy*zz
7013         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7014         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7015      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7016      &  +x(60)*yy*zz
7017         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7018      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7019      &        +(pom1+pom2)*pom_dx
7020 #ifdef DEBUG
7021         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7022 #endif
7023 C
7024         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7025         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7026      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7027      &  +x(40)*xx*zz
7028         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7029         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7030      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7031      &  +x(59)*zz**2 +x(60)*xx*zz
7032         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7033      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7034      &        +(pom1-pom2)*pom_dy
7035 #ifdef DEBUG
7036         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7037 #endif
7038 C
7039         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7040      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7041      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7042      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7043      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7044      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7045      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7046      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7047 #ifdef DEBUG
7048         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7049 #endif
7050 C
7051         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7052      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7053      &  +pom1*pom_dt1+pom2*pom_dt2
7054 #ifdef DEBUG
7055         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7056 #endif
7057 c#undef DEBUG
7058 c
7059 C
7060        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7061        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7062        cosfac2xx=cosfac2*xx
7063        sinfac2yy=sinfac2*yy
7064        do k = 1,3
7065          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7066      &      vbld_inv(i+1)
7067          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7068      &      vbld_inv(i)
7069          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7070          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7071 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7072 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7073 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7074 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7075          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7076          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7077          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7078          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7079          dZZ_Ci1(k)=0.0d0
7080          dZZ_Ci(k)=0.0d0
7081          do j=1,3
7082            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7083      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7084            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7085      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7086          enddo
7087
7088          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7089          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7090          dZZ_XYZ(k)=vbld_inv(i+nres)*
7091      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7092 c
7093          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7094          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7095        enddo
7096
7097        do k=1,3
7098          dXX_Ctab(k,i)=dXX_Ci(k)
7099          dXX_C1tab(k,i)=dXX_Ci1(k)
7100          dYY_Ctab(k,i)=dYY_Ci(k)
7101          dYY_C1tab(k,i)=dYY_Ci1(k)
7102          dZZ_Ctab(k,i)=dZZ_Ci(k)
7103          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7104          dXX_XYZtab(k,i)=dXX_XYZ(k)
7105          dYY_XYZtab(k,i)=dYY_XYZ(k)
7106          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7107        enddo
7108
7109        do k = 1,3
7110 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7111 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7112 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7113 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7114 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7115 c     &    dt_dci(k)
7116 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7117 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7118          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7119      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7120          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7121      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7122          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7123      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7124        enddo
7125 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7126 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7127
7128 C to check gradient call subroutine check_grad
7129
7130     1 continue
7131       enddo
7132       return
7133       end
7134 c------------------------------------------------------------------------------
7135       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7136       implicit none
7137       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7138      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7139       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7140      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7141      &   + x(10)*yy*zz
7142       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7143      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7144      & + x(20)*yy*zz
7145       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7146      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7147      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7148      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7149      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7150      &  +x(40)*xx*yy*zz
7151       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7152      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7153      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7154      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7155      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7156      &  +x(60)*xx*yy*zz
7157       dsc_i   = 0.743d0+x(61)
7158       dp2_i   = 1.9d0+x(62)
7159       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7160      &          *(xx*cost2+yy*sint2))
7161       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7162      &          *(xx*cost2-yy*sint2))
7163       s1=(1+x(63))/(0.1d0 + dscp1)
7164       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7165       s2=(1+x(65))/(0.1d0 + dscp2)
7166       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7167       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7168      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7169       enesc=sumene
7170       return
7171       end
7172 #endif
7173 c------------------------------------------------------------------------------
7174       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7175 C
7176 C This procedure calculates two-body contact function g(rij) and its derivative:
7177 C
7178 C           eps0ij                                     !       x < -1
7179 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7180 C            0                                         !       x > 1
7181 C
7182 C where x=(rij-r0ij)/delta
7183 C
7184 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7185 C
7186       implicit none
7187       double precision rij,r0ij,eps0ij,fcont,fprimcont
7188       double precision x,x2,x4,delta
7189 c     delta=0.02D0*r0ij
7190 c      delta=0.2D0*r0ij
7191       x=(rij-r0ij)/delta
7192       if (x.lt.-1.0D0) then
7193         fcont=eps0ij
7194         fprimcont=0.0D0
7195       else if (x.le.1.0D0) then
7196         x2=x*x
7197         x4=x2*x2
7198         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7199         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7200       else
7201         fcont=0.0D0
7202         fprimcont=0.0D0
7203       endif
7204       return
7205       end
7206 c------------------------------------------------------------------------------
7207       subroutine splinthet(theti,delta,ss,ssder)
7208       implicit real*8 (a-h,o-z)
7209       include 'DIMENSIONS'
7210       include 'COMMON.VAR'
7211       include 'COMMON.GEO'
7212       thetup=pi-delta
7213       thetlow=delta
7214       if (theti.gt.pipol) then
7215         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7216       else
7217         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7218         ssder=-ssder
7219       endif
7220       return
7221       end
7222 c------------------------------------------------------------------------------
7223       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7224       implicit none
7225       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7226       double precision ksi,ksi2,ksi3,a1,a2,a3
7227       a1=fprim0*delta/(f1-f0)
7228       a2=3.0d0-2.0d0*a1
7229       a3=a1-2.0d0
7230       ksi=(x-x0)/delta
7231       ksi2=ksi*ksi
7232       ksi3=ksi2*ksi
7233       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7234       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7235       return
7236       end
7237 c------------------------------------------------------------------------------
7238       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7239       implicit none
7240       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7241       double precision ksi,ksi2,ksi3,a1,a2,a3
7242       ksi=(x-x0)/delta
7243       ksi2=ksi*ksi
7244       ksi3=ksi2*ksi
7245       a1=fprim0x*delta
7246       a2=3*(f1x-f0x)-2*fprim0x*delta
7247       a3=fprim0x*delta-2*(f1x-f0x)
7248       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7249       return
7250       end
7251 C-----------------------------------------------------------------------------
7252 #ifdef CRYST_TOR
7253 C-----------------------------------------------------------------------------
7254       subroutine etor(etors,edihcnstr)
7255       implicit real*8 (a-h,o-z)
7256       include 'DIMENSIONS'
7257       include 'COMMON.VAR'
7258       include 'COMMON.GEO'
7259       include 'COMMON.LOCAL'
7260       include 'COMMON.TORSION'
7261       include 'COMMON.INTERACT'
7262       include 'COMMON.DERIV'
7263       include 'COMMON.CHAIN'
7264       include 'COMMON.NAMES'
7265       include 'COMMON.IOUNITS'
7266       include 'COMMON.FFIELD'
7267       include 'COMMON.TORCNSTR'
7268       include 'COMMON.CONTROL'
7269       logical lprn
7270 C Set lprn=.true. for debugging
7271       lprn=.false.
7272 c      lprn=.true.
7273       etors=0.0D0
7274       do i=iphi_start,iphi_end
7275       etors_ii=0.0D0
7276         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7277      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7278         itori=itortyp(itype(i-2))
7279         itori1=itortyp(itype(i-1))
7280         phii=phi(i)
7281         gloci=0.0D0
7282 C Proline-Proline pair is a special case...
7283         if (itori.eq.3 .and. itori1.eq.3) then
7284           if (phii.gt.-dwapi3) then
7285             cosphi=dcos(3*phii)
7286             fac=1.0D0/(1.0D0-cosphi)
7287             etorsi=v1(1,3,3)*fac
7288             etorsi=etorsi+etorsi
7289             etors=etors+etorsi-v1(1,3,3)
7290             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7291             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7292           endif
7293           do j=1,3
7294             v1ij=v1(j+1,itori,itori1)
7295             v2ij=v2(j+1,itori,itori1)
7296             cosphi=dcos(j*phii)
7297             sinphi=dsin(j*phii)
7298             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7299             if (energy_dec) etors_ii=etors_ii+
7300      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7301             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7302           enddo
7303         else
7304           do j=1,nterm_old
7305             v1ij=v1(j,itori,itori1)
7306             v2ij=v2(j,itori,itori1)
7307             cosphi=dcos(j*phii)
7308             sinphi=dsin(j*phii)
7309             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7310             if (energy_dec) etors_ii=etors_ii+
7311      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7312             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7313           enddo
7314         endif
7315         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7316              'etor',i,etors_ii
7317         if (lprn)
7318      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7319      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7320      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7321         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7322 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7323       enddo
7324 ! 6/20/98 - dihedral angle constraints
7325       edihcnstr=0.0d0
7326       do i=1,ndih_constr
7327         itori=idih_constr(i)
7328         phii=phi(itori)
7329         difi=phii-phi0(i)
7330         if (difi.gt.drange(i)) then
7331           difi=difi-drange(i)
7332           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7333           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7334         else if (difi.lt.-drange(i)) then
7335           difi=difi+drange(i)
7336           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7337           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7338         endif
7339 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7340 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7341       enddo
7342 !      write (iout,*) 'edihcnstr',edihcnstr
7343       return
7344       end
7345 c------------------------------------------------------------------------------
7346       subroutine etor_d(etors_d)
7347       etors_d=0.0d0
7348       return
7349       end
7350 c----------------------------------------------------------------------------
7351 #else
7352       subroutine etor(etors,edihcnstr)
7353       implicit real*8 (a-h,o-z)
7354       include 'DIMENSIONS'
7355       include 'COMMON.VAR'
7356       include 'COMMON.GEO'
7357       include 'COMMON.LOCAL'
7358       include 'COMMON.TORSION'
7359       include 'COMMON.INTERACT'
7360       include 'COMMON.DERIV'
7361       include 'COMMON.CHAIN'
7362       include 'COMMON.NAMES'
7363       include 'COMMON.IOUNITS'
7364       include 'COMMON.FFIELD'
7365       include 'COMMON.TORCNSTR'
7366       include 'COMMON.CONTROL'
7367       logical lprn
7368 C Set lprn=.true. for debugging
7369       lprn=.false.
7370 c     lprn=.true.
7371       etors=0.0D0
7372       do i=iphi_start,iphi_end
7373 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7374 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7375 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7376 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7377         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7378      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7379 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7380 C For introducing the NH3+ and COO- group please check the etor_d for reference
7381 C and guidance
7382         etors_ii=0.0D0
7383          if (iabs(itype(i)).eq.20) then
7384          iblock=2
7385          else
7386          iblock=1
7387          endif
7388         itori=itortyp(itype(i-2))
7389         itori1=itortyp(itype(i-1))
7390         phii=phi(i)
7391         gloci=0.0D0
7392 C Regular cosine and sine terms
7393         do j=1,nterm(itori,itori1,iblock)
7394           v1ij=v1(j,itori,itori1,iblock)
7395           v2ij=v2(j,itori,itori1,iblock)
7396           cosphi=dcos(j*phii)
7397           sinphi=dsin(j*phii)
7398           etors=etors+v1ij*cosphi+v2ij*sinphi
7399           if (energy_dec) etors_ii=etors_ii+
7400      &                v1ij*cosphi+v2ij*sinphi
7401           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7402         enddo
7403 C Lorentz terms
7404 C                         v1
7405 C  E = SUM ----------------------------------- - v1
7406 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7407 C
7408         cosphi=dcos(0.5d0*phii)
7409         sinphi=dsin(0.5d0*phii)
7410         do j=1,nlor(itori,itori1,iblock)
7411           vl1ij=vlor1(j,itori,itori1)
7412           vl2ij=vlor2(j,itori,itori1)
7413           vl3ij=vlor3(j,itori,itori1)
7414           pom=vl2ij*cosphi+vl3ij*sinphi
7415           pom1=1.0d0/(pom*pom+1.0d0)
7416           etors=etors+vl1ij*pom1
7417           if (energy_dec) etors_ii=etors_ii+
7418      &                vl1ij*pom1
7419           pom=-pom*pom1*pom1
7420           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7421         enddo
7422 C Subtract the constant term
7423         etors=etors-v0(itori,itori1,iblock)
7424           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7425      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7426         if (lprn)
7427      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7428      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7429      &  (v1(j,itori,itori1,iblock),j=1,6),
7430      &  (v2(j,itori,itori1,iblock),j=1,6)
7431         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7432 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7433       enddo
7434 ! 6/20/98 - dihedral angle constraints
7435       edihcnstr=0.0d0
7436 c      do i=1,ndih_constr
7437       do i=idihconstr_start,idihconstr_end
7438         itori=idih_constr(i)
7439         phii=phi(itori)
7440         difi=pinorm(phii-phi0(i))
7441         if (difi.gt.drange(i)) then
7442           difi=difi-drange(i)
7443           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7444           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7445         else if (difi.lt.-drange(i)) then
7446           difi=difi+drange(i)
7447           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7448           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7449         else
7450           difi=0.0
7451         endif
7452        if (energy_dec) then
7453         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7454      &    i,itori,rad2deg*phii,
7455      &    rad2deg*phi0(i),  rad2deg*drange(i),
7456      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7457         endif
7458       enddo
7459 cd       write (iout,*) 'edihcnstr',edihcnstr
7460       return
7461       end
7462 c----------------------------------------------------------------------------
7463       subroutine etor_d(etors_d)
7464 C 6/23/01 Compute double torsional energy
7465       implicit real*8 (a-h,o-z)
7466       include 'DIMENSIONS'
7467       include 'COMMON.VAR'
7468       include 'COMMON.GEO'
7469       include 'COMMON.LOCAL'
7470       include 'COMMON.TORSION'
7471       include 'COMMON.INTERACT'
7472       include 'COMMON.DERIV'
7473       include 'COMMON.CHAIN'
7474       include 'COMMON.NAMES'
7475       include 'COMMON.IOUNITS'
7476       include 'COMMON.FFIELD'
7477       include 'COMMON.TORCNSTR'
7478       logical lprn
7479 C Set lprn=.true. for debugging
7480       lprn=.false.
7481 c     lprn=.true.
7482       etors_d=0.0D0
7483 c      write(iout,*) "a tu??"
7484       do i=iphid_start,iphid_end
7485 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7486 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7487 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7488 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7489 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7490          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7491      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7492      &  (itype(i+1).eq.ntyp1)) cycle
7493 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7494         itori=itortyp(itype(i-2))
7495         itori1=itortyp(itype(i-1))
7496         itori2=itortyp(itype(i))
7497         phii=phi(i)
7498         phii1=phi(i+1)
7499         gloci1=0.0D0
7500         gloci2=0.0D0
7501         iblock=1
7502         if (iabs(itype(i+1)).eq.20) iblock=2
7503 C Iblock=2 Proline type
7504 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7505 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7506 C        if (itype(i+1).eq.ntyp1) iblock=3
7507 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7508 C IS or IS NOT need for this
7509 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7510 C        is (itype(i-3).eq.ntyp1) ntblock=2
7511 C        ntblock is N-terminal blocking group
7512
7513 C Regular cosine and sine terms
7514         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7515 C Example of changes for NH3+ blocking group
7516 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7517 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7518           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7519           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7520           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7521           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7522           cosphi1=dcos(j*phii)
7523           sinphi1=dsin(j*phii)
7524           cosphi2=dcos(j*phii1)
7525           sinphi2=dsin(j*phii1)
7526           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7527      &     v2cij*cosphi2+v2sij*sinphi2
7528           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7529           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7530         enddo
7531         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7532           do l=1,k-1
7533             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7534             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7535             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7536             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7537             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7538             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7539             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7540             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7541             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7542      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7543             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7544      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7545             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7546      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7547           enddo
7548         enddo
7549         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7550         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7551       enddo
7552       return
7553       end
7554 #endif
7555 C----------------------------------------------------------------------------------
7556 C The rigorous attempt to derive energy function
7557       subroutine etor_kcc(etors,edihcnstr)
7558       implicit real*8 (a-h,o-z)
7559       include 'DIMENSIONS'
7560       include 'COMMON.VAR'
7561       include 'COMMON.GEO'
7562       include 'COMMON.LOCAL'
7563       include 'COMMON.TORSION'
7564       include 'COMMON.INTERACT'
7565       include 'COMMON.DERIV'
7566       include 'COMMON.CHAIN'
7567       include 'COMMON.NAMES'
7568       include 'COMMON.IOUNITS'
7569       include 'COMMON.FFIELD'
7570       include 'COMMON.TORCNSTR'
7571       include 'COMMON.CONTROL'
7572       logical lprn
7573 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7574 C Set lprn=.true. for debugging
7575       lprn=.false.
7576 c     lprn=.true.
7577 C      print *,"wchodze kcc"
7578       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7579       if (tor_mode.ne.2) then
7580       etors=0.0D0
7581       endif
7582       do i=iphi_start,iphi_end
7583 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7584 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7585 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7586 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7587         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7588      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7589         itori=itortyp_kcc(itype(i-2))
7590         itori1=itortyp_kcc(itype(i-1))
7591         phii=phi(i)
7592         glocig=0.0D0
7593         glocit1=0.0d0
7594         glocit2=0.0d0
7595         sumnonchebyshev=0.0d0
7596         sumchebyshev=0.0d0
7597 C to avoid multiple devision by 2
7598 c        theti22=0.5d0*theta(i)
7599 C theta 12 is the theta_1 /2
7600 C theta 22 is theta_2 /2
7601 c        theti12=0.5d0*theta(i-1)
7602 C and appropriate sinus function
7603         sinthet1=dsin(theta(i-1))
7604         sinthet2=dsin(theta(i))
7605         costhet1=dcos(theta(i-1))
7606         costhet2=dcos(theta(i))
7607 c Cosines of halves thetas
7608         costheti12=0.5d0*(1.0d0+costhet1)
7609         costheti22=0.5d0*(1.0d0+costhet2)
7610 C to speed up lets store its mutliplication
7611         sint1t2=sinthet2*sinthet1
7612         sint1t2n=1.0d0
7613 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7614 C +d_n*sin(n*gamma)) *
7615 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7616 C we have two sum 1) Non-Chebyshev which is with n and gamma
7617         etori=0.0d0
7618         do j=1,nterm_kcc(itori,itori1)
7619
7620           nval=nterm_kcc_Tb(itori,itori1)
7621           v1ij=v1_kcc(j,itori,itori1)
7622           v2ij=v2_kcc(j,itori,itori1)
7623 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7624 C v1ij is c_n and d_n in euation above
7625           cosphi=dcos(j*phii)
7626           sinphi=dsin(j*phii)
7627           sint1t2n1=sint1t2n
7628           sint1t2n=sint1t2n*sint1t2
7629           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7630      &        costheti12)
7631           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7632      &        v11_chyb(1,j,itori,itori1),costheti12)
7633 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7634 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7635           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7636      &        costheti22)
7637           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7638      &        v21_chyb(1,j,itori,itori1),costheti22)
7639 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7640 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7641           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7642      &        costheti12)
7643           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7644      &        v12_chyb(1,j,itori,itori1),costheti12)
7645 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7646 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7647           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7648      &        costheti22)
7649           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7650      &        v22_chyb(1,j,itori,itori1),costheti22)
7651 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7652 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7653 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7654 C          if (energy_dec) etors_ii=etors_ii+
7655 C     &                v1ij*cosphi+v2ij*sinphi
7656 C glocig is the gradient local i site in gamma
7657           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7658           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7659           etori=etori+sint1t2n*(actval1+actval2)
7660           glocig=glocig+
7661      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7662      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7663 C now gradient over theta_1
7664           glocit1=glocit1+
7665      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7666      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7667           glocit2=glocit2+
7668      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7669      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7670
7671 C now the Czebyshev polinominal sum
7672 c        do k=1,nterm_kcc_Tb(itori,itori1)
7673 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7674 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7675 C         thybt1(k)=0.0
7676 C         thybt2(k)=0.0
7677 c        enddo
7678 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7679 C     &         gradtschebyshev
7680 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7681 C     &         dcos(theti22)**2),
7682 C     &         dsin(theti22)
7683
7684 C now overal sumation
7685 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7686         enddo ! j
7687         etors=etors+etori
7688 C derivative over gamma
7689         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7690 C derivative over theta1
7691         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7692 C now derivative over theta2
7693         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7694         if (lprn)
7695      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7696      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7697       enddo
7698 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7699 ! 6/20/98 - dihedral angle constraints
7700       if (tor_mode.ne.2) then
7701       edihcnstr=0.0d0
7702 c      do i=1,ndih_constr
7703       do i=idihconstr_start,idihconstr_end
7704         itori=idih_constr(i)
7705         phii=phi(itori)
7706         difi=pinorm(phii-phi0(i))
7707         if (difi.gt.drange(i)) then
7708           difi=difi-drange(i)
7709           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7710           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7711         else if (difi.lt.-drange(i)) then
7712           difi=difi+drange(i)
7713           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7714           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7715         else
7716           difi=0.0
7717         endif
7718        enddo
7719        endif
7720       return
7721       end
7722
7723 C The rigorous attempt to derive energy function
7724       subroutine ebend_kcc(etheta,ethetacnstr)
7725
7726       implicit real*8 (a-h,o-z)
7727       include 'DIMENSIONS'
7728       include 'COMMON.VAR'
7729       include 'COMMON.GEO'
7730       include 'COMMON.LOCAL'
7731       include 'COMMON.TORSION'
7732       include 'COMMON.INTERACT'
7733       include 'COMMON.DERIV'
7734       include 'COMMON.CHAIN'
7735       include 'COMMON.NAMES'
7736       include 'COMMON.IOUNITS'
7737       include 'COMMON.FFIELD'
7738       include 'COMMON.TORCNSTR'
7739       include 'COMMON.CONTROL'
7740       logical lprn
7741       double precision thybt1(maxtermkcc)
7742 C Set lprn=.true. for debugging
7743       lprn=.false.
7744 c     lprn=.true.
7745 C      print *,"wchodze kcc"
7746       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7747       if (tor_mode.ne.2) etheta=0.0D0
7748       do i=ithet_start,ithet_end
7749 c        print *,i,itype(i-1),itype(i),itype(i-2)
7750         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7751      &  .or.itype(i).eq.ntyp1) cycle
7752          iti=itortyp_kcc(itype(i-1))
7753         sinthet=dsin(theta(i)/2.0d0)
7754         costhet=dcos(theta(i)/2.0d0)
7755          do j=1,nbend_kcc_Tb(iti)
7756           thybt1(j)=v1bend_chyb(j,iti)
7757          enddo
7758          sumth1thyb=tschebyshev
7759      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7760         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7761      &    sumth1thyb
7762         ihelp=nbend_kcc_Tb(iti)-1
7763         gradthybt1=gradtschebyshev
7764      &         (0,ihelp,thybt1(1),costhet)
7765         etheta=etheta+sumth1thyb
7766 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7767         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7768      &   gradthybt1*sinthet*(-0.5d0)
7769       enddo
7770       if (tor_mode.ne.2) then
7771       ethetacnstr=0.0d0
7772 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7773       do i=ithetaconstr_start,ithetaconstr_end
7774         itheta=itheta_constr(i)
7775         thetiii=theta(itheta)
7776         difi=pinorm(thetiii-theta_constr0(i))
7777         if (difi.gt.theta_drange(i)) then
7778           difi=difi-theta_drange(i)
7779           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7780           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7781      &    +for_thet_constr(i)*difi**3
7782         else if (difi.lt.-drange(i)) then
7783           difi=difi+drange(i)
7784           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7785           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7786      &    +for_thet_constr(i)*difi**3
7787         else
7788           difi=0.0
7789         endif
7790        if (energy_dec) then
7791         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7792      &    i,itheta,rad2deg*thetiii,
7793      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7794      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7795      &    gloc(itheta+nphi-2,icg)
7796         endif
7797       enddo
7798       endif
7799       return
7800       end
7801 c------------------------------------------------------------------------------
7802       subroutine eback_sc_corr(esccor)
7803 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7804 c        conformational states; temporarily implemented as differences
7805 c        between UNRES torsional potentials (dependent on three types of
7806 c        residues) and the torsional potentials dependent on all 20 types
7807 c        of residues computed from AM1  energy surfaces of terminally-blocked
7808 c        amino-acid residues.
7809       implicit real*8 (a-h,o-z)
7810       include 'DIMENSIONS'
7811       include 'COMMON.VAR'
7812       include 'COMMON.GEO'
7813       include 'COMMON.LOCAL'
7814       include 'COMMON.TORSION'
7815       include 'COMMON.SCCOR'
7816       include 'COMMON.INTERACT'
7817       include 'COMMON.DERIV'
7818       include 'COMMON.CHAIN'
7819       include 'COMMON.NAMES'
7820       include 'COMMON.IOUNITS'
7821       include 'COMMON.FFIELD'
7822       include 'COMMON.CONTROL'
7823       logical lprn
7824 C Set lprn=.true. for debugging
7825       lprn=.false.
7826 c      lprn=.true.
7827 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7828       esccor=0.0D0
7829       do i=itau_start,itau_end
7830         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7831         esccor_ii=0.0D0
7832         isccori=isccortyp(itype(i-2))
7833         isccori1=isccortyp(itype(i-1))
7834 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7835         phii=phi(i)
7836         do intertyp=1,3 !intertyp
7837 cc Added 09 May 2012 (Adasko)
7838 cc  Intertyp means interaction type of backbone mainchain correlation:
7839 c   1 = SC...Ca...Ca...Ca
7840 c   2 = Ca...Ca...Ca...SC
7841 c   3 = SC...Ca...Ca...SCi
7842         gloci=0.0D0
7843         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7844      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7845      &      (itype(i-1).eq.ntyp1)))
7846      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7847      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7848      &     .or.(itype(i).eq.ntyp1)))
7849      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7850      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7851      &      (itype(i-3).eq.ntyp1)))) cycle
7852         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7853         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7854      & cycle
7855        do j=1,nterm_sccor(isccori,isccori1)
7856           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7857           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7858           cosphi=dcos(j*tauangle(intertyp,i))
7859           sinphi=dsin(j*tauangle(intertyp,i))
7860           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7861           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7862         enddo
7863 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7864         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7865         if (lprn)
7866      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7867      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7868      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7869      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7870         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7871        enddo !intertyp
7872       enddo
7873
7874       return
7875       end
7876 c----------------------------------------------------------------------------
7877       subroutine multibody(ecorr)
7878 C This subroutine calculates multi-body contributions to energy following
7879 C the idea of Skolnick et al. If side chains I and J make a contact and
7880 C at the same time side chains I+1 and J+1 make a contact, an extra
7881 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7882       implicit real*8 (a-h,o-z)
7883       include 'DIMENSIONS'
7884       include 'COMMON.IOUNITS'
7885       include 'COMMON.DERIV'
7886       include 'COMMON.INTERACT'
7887       include 'COMMON.CONTACTS'
7888       double precision gx(3),gx1(3)
7889       logical lprn
7890
7891 C Set lprn=.true. for debugging
7892       lprn=.false.
7893
7894       if (lprn) then
7895         write (iout,'(a)') 'Contact function values:'
7896         do i=nnt,nct-2
7897           write (iout,'(i2,20(1x,i2,f10.5))')
7898      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7899         enddo
7900       endif
7901       ecorr=0.0D0
7902       do i=nnt,nct
7903         do j=1,3
7904           gradcorr(j,i)=0.0D0
7905           gradxorr(j,i)=0.0D0
7906         enddo
7907       enddo
7908       do i=nnt,nct-2
7909
7910         DO ISHIFT = 3,4
7911
7912         i1=i+ishift
7913         num_conti=num_cont(i)
7914         num_conti1=num_cont(i1)
7915         do jj=1,num_conti
7916           j=jcont(jj,i)
7917           do kk=1,num_conti1
7918             j1=jcont(kk,i1)
7919             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7920 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7921 cd   &                   ' ishift=',ishift
7922 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7923 C The system gains extra energy.
7924               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7925             endif   ! j1==j+-ishift
7926           enddo     ! kk
7927         enddo       ! jj
7928
7929         ENDDO ! ISHIFT
7930
7931       enddo         ! i
7932       return
7933       end
7934 c------------------------------------------------------------------------------
7935       double precision function esccorr(i,j,k,l,jj,kk)
7936       implicit real*8 (a-h,o-z)
7937       include 'DIMENSIONS'
7938       include 'COMMON.IOUNITS'
7939       include 'COMMON.DERIV'
7940       include 'COMMON.INTERACT'
7941       include 'COMMON.CONTACTS'
7942       include 'COMMON.SHIELD'
7943       double precision gx(3),gx1(3)
7944       logical lprn
7945       lprn=.false.
7946       eij=facont(jj,i)
7947       ekl=facont(kk,k)
7948 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7949 C Calculate the multi-body contribution to energy.
7950 C Calculate multi-body contributions to the gradient.
7951 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7952 cd   & k,l,(gacont(m,kk,k),m=1,3)
7953       do m=1,3
7954         gx(m) =ekl*gacont(m,jj,i)
7955         gx1(m)=eij*gacont(m,kk,k)
7956         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7957         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7958         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7959         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7960       enddo
7961       do m=i,j-1
7962         do ll=1,3
7963           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7964         enddo
7965       enddo
7966       do m=k,l-1
7967         do ll=1,3
7968           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7969         enddo
7970       enddo
7971       esccorr=-eij*ekl
7972       return
7973       end
7974 c------------------------------------------------------------------------------
7975       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7976 C This subroutine calculates multi-body contributions to hydrogen-bonding
7977       implicit real*8 (a-h,o-z)
7978       include 'DIMENSIONS'
7979       include 'COMMON.IOUNITS'
7980 #ifdef MPI
7981       include "mpif.h"
7982       parameter (max_cont=maxconts)
7983       parameter (max_dim=26)
7984       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7985       double precision zapas(max_dim,maxconts,max_fg_procs),
7986      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7987       common /przechowalnia/ zapas
7988       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7989      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7990 #endif
7991       include 'COMMON.SETUP'
7992       include 'COMMON.FFIELD'
7993       include 'COMMON.DERIV'
7994       include 'COMMON.INTERACT'
7995       include 'COMMON.CONTACTS'
7996       include 'COMMON.CONTROL'
7997       include 'COMMON.LOCAL'
7998       double precision gx(3),gx1(3),time00
7999       logical lprn,ldone
8000
8001 C Set lprn=.true. for debugging
8002       lprn=.false.
8003 #ifdef MPI
8004       n_corr=0
8005       n_corr1=0
8006       if (nfgtasks.le.1) goto 30
8007       if (lprn) then
8008         write (iout,'(a)') 'Contact function values before RECEIVE:'
8009         do i=nnt,nct-2
8010           write (iout,'(2i3,50(1x,i2,f5.2))')
8011      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8012      &    j=1,num_cont_hb(i))
8013         enddo
8014       endif
8015       call flush(iout)
8016       do i=1,ntask_cont_from
8017         ncont_recv(i)=0
8018       enddo
8019       do i=1,ntask_cont_to
8020         ncont_sent(i)=0
8021       enddo
8022 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8023 c     & ntask_cont_to
8024 C Make the list of contacts to send to send to other procesors
8025 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8026 c      call flush(iout)
8027       do i=iturn3_start,iturn3_end
8028 c        write (iout,*) "make contact list turn3",i," num_cont",
8029 c     &    num_cont_hb(i)
8030         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8031       enddo
8032       do i=iturn4_start,iturn4_end
8033 c        write (iout,*) "make contact list turn4",i," num_cont",
8034 c     &   num_cont_hb(i)
8035         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8036       enddo
8037       do ii=1,nat_sent
8038         i=iat_sent(ii)
8039 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8040 c     &    num_cont_hb(i)
8041         do j=1,num_cont_hb(i)
8042         do k=1,4
8043           jjc=jcont_hb(j,i)
8044           iproc=iint_sent_local(k,jjc,ii)
8045 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8046           if (iproc.gt.0) then
8047             ncont_sent(iproc)=ncont_sent(iproc)+1
8048             nn=ncont_sent(iproc)
8049             zapas(1,nn,iproc)=i
8050             zapas(2,nn,iproc)=jjc
8051             zapas(3,nn,iproc)=facont_hb(j,i)
8052             zapas(4,nn,iproc)=ees0p(j,i)
8053             zapas(5,nn,iproc)=ees0m(j,i)
8054             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8055             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8056             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8057             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8058             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8059             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8060             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8061             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8062             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8063             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8064             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8065             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8066             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8067             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8068             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8069             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8070             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8071             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8072             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8073             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8074             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8075           endif
8076         enddo
8077         enddo
8078       enddo
8079       if (lprn) then
8080       write (iout,*)
8081      &  "Numbers of contacts to be sent to other processors",
8082      &  (ncont_sent(i),i=1,ntask_cont_to)
8083       write (iout,*) "Contacts sent"
8084       do ii=1,ntask_cont_to
8085         nn=ncont_sent(ii)
8086         iproc=itask_cont_to(ii)
8087         write (iout,*) nn," contacts to processor",iproc,
8088      &   " of CONT_TO_COMM group"
8089         do i=1,nn
8090           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8091         enddo
8092       enddo
8093       call flush(iout)
8094       endif
8095       CorrelType=477
8096       CorrelID=fg_rank+1
8097       CorrelType1=478
8098       CorrelID1=nfgtasks+fg_rank+1
8099       ireq=0
8100 C Receive the numbers of needed contacts from other processors
8101       do ii=1,ntask_cont_from
8102         iproc=itask_cont_from(ii)
8103         ireq=ireq+1
8104         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8105      &    FG_COMM,req(ireq),IERR)
8106       enddo
8107 c      write (iout,*) "IRECV ended"
8108 c      call flush(iout)
8109 C Send the number of contacts needed by other processors
8110       do ii=1,ntask_cont_to
8111         iproc=itask_cont_to(ii)
8112         ireq=ireq+1
8113         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8114      &    FG_COMM,req(ireq),IERR)
8115       enddo
8116 c      write (iout,*) "ISEND ended"
8117 c      write (iout,*) "number of requests (nn)",ireq
8118       call flush(iout)
8119       if (ireq.gt.0)
8120      &  call MPI_Waitall(ireq,req,status_array,ierr)
8121 c      write (iout,*)
8122 c     &  "Numbers of contacts to be received from other processors",
8123 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8124 c      call flush(iout)
8125 C Receive contacts
8126       ireq=0
8127       do ii=1,ntask_cont_from
8128         iproc=itask_cont_from(ii)
8129         nn=ncont_recv(ii)
8130 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8131 c     &   " of CONT_TO_COMM group"
8132         call flush(iout)
8133         if (nn.gt.0) then
8134           ireq=ireq+1
8135           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8136      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8137 c          write (iout,*) "ireq,req",ireq,req(ireq)
8138         endif
8139       enddo
8140 C Send the contacts to processors that need them
8141       do ii=1,ntask_cont_to
8142         iproc=itask_cont_to(ii)
8143         nn=ncont_sent(ii)
8144 c        write (iout,*) nn," contacts to processor",iproc,
8145 c     &   " of CONT_TO_COMM group"
8146         if (nn.gt.0) then
8147           ireq=ireq+1
8148           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8149      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8150 c          write (iout,*) "ireq,req",ireq,req(ireq)
8151 c          do i=1,nn
8152 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8153 c          enddo
8154         endif
8155       enddo
8156 c      write (iout,*) "number of requests (contacts)",ireq
8157 c      write (iout,*) "req",(req(i),i=1,4)
8158 c      call flush(iout)
8159       if (ireq.gt.0)
8160      & call MPI_Waitall(ireq,req,status_array,ierr)
8161       do iii=1,ntask_cont_from
8162         iproc=itask_cont_from(iii)
8163         nn=ncont_recv(iii)
8164         if (lprn) then
8165         write (iout,*) "Received",nn," contacts from processor",iproc,
8166      &   " of CONT_FROM_COMM group"
8167         call flush(iout)
8168         do i=1,nn
8169           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8170         enddo
8171         call flush(iout)
8172         endif
8173         do i=1,nn
8174           ii=zapas_recv(1,i,iii)
8175 c Flag the received contacts to prevent double-counting
8176           jj=-zapas_recv(2,i,iii)
8177 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8178 c          call flush(iout)
8179           nnn=num_cont_hb(ii)+1
8180           num_cont_hb(ii)=nnn
8181           jcont_hb(nnn,ii)=jj
8182           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8183           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8184           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8185           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8186           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8187           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8188           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8189           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8190           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8191           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8192           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8193           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8194           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8195           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8196           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8197           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8198           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8199           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8200           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8201           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8202           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8203           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8204           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8205           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8206         enddo
8207       enddo
8208       call flush(iout)
8209       if (lprn) then
8210         write (iout,'(a)') 'Contact function values after receive:'
8211         do i=nnt,nct-2
8212           write (iout,'(2i3,50(1x,i3,f5.2))')
8213      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8214      &    j=1,num_cont_hb(i))
8215         enddo
8216         call flush(iout)
8217       endif
8218    30 continue
8219 #endif
8220       if (lprn) then
8221         write (iout,'(a)') 'Contact function values:'
8222         do i=nnt,nct-2
8223           write (iout,'(2i3,50(1x,i3,f5.2))')
8224      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8225      &    j=1,num_cont_hb(i))
8226         enddo
8227       endif
8228       ecorr=0.0D0
8229 C Remove the loop below after debugging !!!
8230       do i=nnt,nct
8231         do j=1,3
8232           gradcorr(j,i)=0.0D0
8233           gradxorr(j,i)=0.0D0
8234         enddo
8235       enddo
8236 C Calculate the local-electrostatic correlation terms
8237       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8238         i1=i+1
8239         num_conti=num_cont_hb(i)
8240         num_conti1=num_cont_hb(i+1)
8241         do jj=1,num_conti
8242           j=jcont_hb(jj,i)
8243           jp=iabs(j)
8244           do kk=1,num_conti1
8245             j1=jcont_hb(kk,i1)
8246             jp1=iabs(j1)
8247 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8248 c     &         ' jj=',jj,' kk=',kk
8249             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8250      &          .or. j.lt.0 .and. j1.gt.0) .and.
8251      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8252 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8253 C The system gains extra energy.
8254               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8255               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8256      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8257               n_corr=n_corr+1
8258             else if (j1.eq.j) then
8259 C Contacts I-J and I-(J+1) occur simultaneously.
8260 C The system loses extra energy.
8261 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8262             endif
8263           enddo ! kk
8264           do kk=1,num_conti
8265             j1=jcont_hb(kk,i)
8266 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8267 c    &         ' jj=',jj,' kk=',kk
8268             if (j1.eq.j+1) then
8269 C Contacts I-J and (I+1)-J occur simultaneously.
8270 C The system loses extra energy.
8271 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8272             endif ! j1==j+1
8273           enddo ! kk
8274         enddo ! jj
8275       enddo ! i
8276       return
8277       end
8278 c------------------------------------------------------------------------------
8279       subroutine add_hb_contact(ii,jj,itask)
8280       implicit real*8 (a-h,o-z)
8281       include "DIMENSIONS"
8282       include "COMMON.IOUNITS"
8283       integer max_cont
8284       integer max_dim
8285       parameter (max_cont=maxconts)
8286       parameter (max_dim=26)
8287       include "COMMON.CONTACTS"
8288       double precision zapas(max_dim,maxconts,max_fg_procs),
8289      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8290       common /przechowalnia/ zapas
8291       integer i,j,ii,jj,iproc,itask(4),nn
8292 c      write (iout,*) "itask",itask
8293       do i=1,2
8294         iproc=itask(i)
8295         if (iproc.gt.0) then
8296           do j=1,num_cont_hb(ii)
8297             jjc=jcont_hb(j,ii)
8298 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8299             if (jjc.eq.jj) then
8300               ncont_sent(iproc)=ncont_sent(iproc)+1
8301               nn=ncont_sent(iproc)
8302               zapas(1,nn,iproc)=ii
8303               zapas(2,nn,iproc)=jjc
8304               zapas(3,nn,iproc)=facont_hb(j,ii)
8305               zapas(4,nn,iproc)=ees0p(j,ii)
8306               zapas(5,nn,iproc)=ees0m(j,ii)
8307               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8308               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8309               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8310               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8311               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8312               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8313               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8314               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8315               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8316               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8317               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8318               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8319               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8320               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8321               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8322               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8323               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8324               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8325               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8326               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8327               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8328               exit
8329             endif
8330           enddo
8331         endif
8332       enddo
8333       return
8334       end
8335 c------------------------------------------------------------------------------
8336       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8337      &  n_corr1)
8338 C This subroutine calculates multi-body contributions to hydrogen-bonding
8339       implicit real*8 (a-h,o-z)
8340       include 'DIMENSIONS'
8341       include 'COMMON.IOUNITS'
8342 #ifdef MPI
8343       include "mpif.h"
8344       parameter (max_cont=maxconts)
8345       parameter (max_dim=70)
8346       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8347       double precision zapas(max_dim,maxconts,max_fg_procs),
8348      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8349       common /przechowalnia/ zapas
8350       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8351      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8352 #endif
8353       include 'COMMON.SETUP'
8354       include 'COMMON.FFIELD'
8355       include 'COMMON.DERIV'
8356       include 'COMMON.LOCAL'
8357       include 'COMMON.INTERACT'
8358       include 'COMMON.CONTACTS'
8359       include 'COMMON.CHAIN'
8360       include 'COMMON.CONTROL'
8361       include 'COMMON.SHIELD'
8362       double precision gx(3),gx1(3)
8363       integer num_cont_hb_old(maxres)
8364       logical lprn,ldone
8365       double precision eello4,eello5,eelo6,eello_turn6
8366       external eello4,eello5,eello6,eello_turn6
8367 C Set lprn=.true. for debugging
8368       lprn=.false.
8369       eturn6=0.0d0
8370 #ifdef MPI
8371       do i=1,nres
8372         num_cont_hb_old(i)=num_cont_hb(i)
8373       enddo
8374       n_corr=0
8375       n_corr1=0
8376       if (nfgtasks.le.1) goto 30
8377       if (lprn) then
8378         write (iout,'(a)') 'Contact function values before RECEIVE:'
8379         do i=nnt,nct-2
8380           write (iout,'(2i3,50(1x,i2,f5.2))')
8381      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8382      &    j=1,num_cont_hb(i))
8383         enddo
8384       endif
8385       call flush(iout)
8386       do i=1,ntask_cont_from
8387         ncont_recv(i)=0
8388       enddo
8389       do i=1,ntask_cont_to
8390         ncont_sent(i)=0
8391       enddo
8392 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8393 c     & ntask_cont_to
8394 C Make the list of contacts to send to send to other procesors
8395       do i=iturn3_start,iturn3_end
8396 c        write (iout,*) "make contact list turn3",i," num_cont",
8397 c     &    num_cont_hb(i)
8398         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8399       enddo
8400       do i=iturn4_start,iturn4_end
8401 c        write (iout,*) "make contact list turn4",i," num_cont",
8402 c     &   num_cont_hb(i)
8403         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8404       enddo
8405       do ii=1,nat_sent
8406         i=iat_sent(ii)
8407 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8408 c     &    num_cont_hb(i)
8409         do j=1,num_cont_hb(i)
8410         do k=1,4
8411           jjc=jcont_hb(j,i)
8412           iproc=iint_sent_local(k,jjc,ii)
8413 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8414           if (iproc.ne.0) then
8415             ncont_sent(iproc)=ncont_sent(iproc)+1
8416             nn=ncont_sent(iproc)
8417             zapas(1,nn,iproc)=i
8418             zapas(2,nn,iproc)=jjc
8419             zapas(3,nn,iproc)=d_cont(j,i)
8420             ind=3
8421             do kk=1,3
8422               ind=ind+1
8423               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8424             enddo
8425             do kk=1,2
8426               do ll=1,2
8427                 ind=ind+1
8428                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8429               enddo
8430             enddo
8431             do jj=1,5
8432               do kk=1,3
8433                 do ll=1,2
8434                   do mm=1,2
8435                     ind=ind+1
8436                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8437                   enddo
8438                 enddo
8439               enddo
8440             enddo
8441           endif
8442         enddo
8443         enddo
8444       enddo
8445       if (lprn) then
8446       write (iout,*)
8447      &  "Numbers of contacts to be sent to other processors",
8448      &  (ncont_sent(i),i=1,ntask_cont_to)
8449       write (iout,*) "Contacts sent"
8450       do ii=1,ntask_cont_to
8451         nn=ncont_sent(ii)
8452         iproc=itask_cont_to(ii)
8453         write (iout,*) nn," contacts to processor",iproc,
8454      &   " of CONT_TO_COMM group"
8455         do i=1,nn
8456           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8457         enddo
8458       enddo
8459       call flush(iout)
8460       endif
8461       CorrelType=477
8462       CorrelID=fg_rank+1
8463       CorrelType1=478
8464       CorrelID1=nfgtasks+fg_rank+1
8465       ireq=0
8466 C Receive the numbers of needed contacts from other processors
8467       do ii=1,ntask_cont_from
8468         iproc=itask_cont_from(ii)
8469         ireq=ireq+1
8470         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8471      &    FG_COMM,req(ireq),IERR)
8472       enddo
8473 c      write (iout,*) "IRECV ended"
8474 c      call flush(iout)
8475 C Send the number of contacts needed by other processors
8476       do ii=1,ntask_cont_to
8477         iproc=itask_cont_to(ii)
8478         ireq=ireq+1
8479         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8480      &    FG_COMM,req(ireq),IERR)
8481       enddo
8482 c      write (iout,*) "ISEND ended"
8483 c      write (iout,*) "number of requests (nn)",ireq
8484       call flush(iout)
8485       if (ireq.gt.0)
8486      &  call MPI_Waitall(ireq,req,status_array,ierr)
8487 c      write (iout,*)
8488 c     &  "Numbers of contacts to be received from other processors",
8489 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8490 c      call flush(iout)
8491 C Receive contacts
8492       ireq=0
8493       do ii=1,ntask_cont_from
8494         iproc=itask_cont_from(ii)
8495         nn=ncont_recv(ii)
8496 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8497 c     &   " of CONT_TO_COMM group"
8498         call flush(iout)
8499         if (nn.gt.0) then
8500           ireq=ireq+1
8501           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8502      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8503 c          write (iout,*) "ireq,req",ireq,req(ireq)
8504         endif
8505       enddo
8506 C Send the contacts to processors that need them
8507       do ii=1,ntask_cont_to
8508         iproc=itask_cont_to(ii)
8509         nn=ncont_sent(ii)
8510 c        write (iout,*) nn," contacts to processor",iproc,
8511 c     &   " of CONT_TO_COMM group"
8512         if (nn.gt.0) then
8513           ireq=ireq+1
8514           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8515      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8516 c          write (iout,*) "ireq,req",ireq,req(ireq)
8517 c          do i=1,nn
8518 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8519 c          enddo
8520         endif
8521       enddo
8522 c      write (iout,*) "number of requests (contacts)",ireq
8523 c      write (iout,*) "req",(req(i),i=1,4)
8524 c      call flush(iout)
8525       if (ireq.gt.0)
8526      & call MPI_Waitall(ireq,req,status_array,ierr)
8527       do iii=1,ntask_cont_from
8528         iproc=itask_cont_from(iii)
8529         nn=ncont_recv(iii)
8530         if (lprn) then
8531         write (iout,*) "Received",nn," contacts from processor",iproc,
8532      &   " of CONT_FROM_COMM group"
8533         call flush(iout)
8534         do i=1,nn
8535           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8536         enddo
8537         call flush(iout)
8538         endif
8539         do i=1,nn
8540           ii=zapas_recv(1,i,iii)
8541 c Flag the received contacts to prevent double-counting
8542           jj=-zapas_recv(2,i,iii)
8543 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8544 c          call flush(iout)
8545           nnn=num_cont_hb(ii)+1
8546           num_cont_hb(ii)=nnn
8547           jcont_hb(nnn,ii)=jj
8548           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8549           ind=3
8550           do kk=1,3
8551             ind=ind+1
8552             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8553           enddo
8554           do kk=1,2
8555             do ll=1,2
8556               ind=ind+1
8557               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8558             enddo
8559           enddo
8560           do jj=1,5
8561             do kk=1,3
8562               do ll=1,2
8563                 do mm=1,2
8564                   ind=ind+1
8565                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8566                 enddo
8567               enddo
8568             enddo
8569           enddo
8570         enddo
8571       enddo
8572       call flush(iout)
8573       if (lprn) then
8574         write (iout,'(a)') 'Contact function values after receive:'
8575         do i=nnt,nct-2
8576           write (iout,'(2i3,50(1x,i3,5f6.3))')
8577      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8578      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8579         enddo
8580         call flush(iout)
8581       endif
8582    30 continue
8583 #endif
8584       if (lprn) then
8585         write (iout,'(a)') 'Contact function values:'
8586         do i=nnt,nct-2
8587           write (iout,'(2i3,50(1x,i2,5f6.3))')
8588      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8589      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8590         enddo
8591       endif
8592       ecorr=0.0D0
8593       ecorr5=0.0d0
8594       ecorr6=0.0d0
8595 C Remove the loop below after debugging !!!
8596       do i=nnt,nct
8597         do j=1,3
8598           gradcorr(j,i)=0.0D0
8599           gradxorr(j,i)=0.0D0
8600         enddo
8601       enddo
8602 C Calculate the dipole-dipole interaction energies
8603       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8604       do i=iatel_s,iatel_e+1
8605         num_conti=num_cont_hb(i)
8606         do jj=1,num_conti
8607           j=jcont_hb(jj,i)
8608 #ifdef MOMENT
8609           call dipole(i,j,jj)
8610 #endif
8611         enddo
8612       enddo
8613       endif
8614 C Calculate the local-electrostatic correlation terms
8615 c                write (iout,*) "gradcorr5 in eello5 before loop"
8616 c                do iii=1,nres
8617 c                  write (iout,'(i5,3f10.5)')
8618 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8619 c                enddo
8620       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8621 c        write (iout,*) "corr loop i",i
8622         i1=i+1
8623         num_conti=num_cont_hb(i)
8624         num_conti1=num_cont_hb(i+1)
8625         do jj=1,num_conti
8626           j=jcont_hb(jj,i)
8627           jp=iabs(j)
8628           do kk=1,num_conti1
8629             j1=jcont_hb(kk,i1)
8630             jp1=iabs(j1)
8631 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8632 c     &         ' jj=',jj,' kk=',kk
8633 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8634             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8635      &          .or. j.lt.0 .and. j1.gt.0) .and.
8636      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8637 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8638 C The system gains extra energy.
8639               n_corr=n_corr+1
8640               sqd1=dsqrt(d_cont(jj,i))
8641               sqd2=dsqrt(d_cont(kk,i1))
8642               sred_geom = sqd1*sqd2
8643               IF (sred_geom.lt.cutoff_corr) THEN
8644                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8645      &            ekont,fprimcont)
8646 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8647 cd     &         ' jj=',jj,' kk=',kk
8648                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8649                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8650                 do l=1,3
8651                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8652                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8653                 enddo
8654                 n_corr1=n_corr1+1
8655 cd               write (iout,*) 'sred_geom=',sred_geom,
8656 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8657 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8658 cd               write (iout,*) "g_contij",g_contij
8659 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8660 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8661                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8662                 if (wcorr4.gt.0.0d0)
8663      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8664 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8665                   if (energy_dec.and.wcorr4.gt.0.0d0)
8666      1                 write (iout,'(a6,4i5,0pf7.3)')
8667      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8668 c                write (iout,*) "gradcorr5 before eello5"
8669 c                do iii=1,nres
8670 c                  write (iout,'(i5,3f10.5)')
8671 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8672 c                enddo
8673                 if (wcorr5.gt.0.0d0)
8674      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8675 c                write (iout,*) "gradcorr5 after eello5"
8676 c                do iii=1,nres
8677 c                  write (iout,'(i5,3f10.5)')
8678 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8679 c                enddo
8680                   if (energy_dec.and.wcorr5.gt.0.0d0)
8681      1                 write (iout,'(a6,4i5,0pf7.3)')
8682      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8683 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8684 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8685                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8686      &               .or. wturn6.eq.0.0d0))then
8687 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8688                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8689                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8690      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8691 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8692 cd     &            'ecorr6=',ecorr6
8693 cd                write (iout,'(4e15.5)') sred_geom,
8694 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8695 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8696 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8697                 else if (wturn6.gt.0.0d0
8698      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8699 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8700                   eturn6=eturn6+eello_turn6(i,jj,kk)
8701                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8702      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8703 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8704                 endif
8705               ENDIF
8706 1111          continue
8707             endif
8708           enddo ! kk
8709         enddo ! jj
8710       enddo ! i
8711       do i=1,nres
8712         num_cont_hb(i)=num_cont_hb_old(i)
8713       enddo
8714 c                write (iout,*) "gradcorr5 in eello5"
8715 c                do iii=1,nres
8716 c                  write (iout,'(i5,3f10.5)')
8717 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8718 c                enddo
8719       return
8720       end
8721 c------------------------------------------------------------------------------
8722       subroutine add_hb_contact_eello(ii,jj,itask)
8723       implicit real*8 (a-h,o-z)
8724       include "DIMENSIONS"
8725       include "COMMON.IOUNITS"
8726       integer max_cont
8727       integer max_dim
8728       parameter (max_cont=maxconts)
8729       parameter (max_dim=70)
8730       include "COMMON.CONTACTS"
8731       double precision zapas(max_dim,maxconts,max_fg_procs),
8732      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8733       common /przechowalnia/ zapas
8734       integer i,j,ii,jj,iproc,itask(4),nn
8735 c      write (iout,*) "itask",itask
8736       do i=1,2
8737         iproc=itask(i)
8738         if (iproc.gt.0) then
8739           do j=1,num_cont_hb(ii)
8740             jjc=jcont_hb(j,ii)
8741 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8742             if (jjc.eq.jj) then
8743               ncont_sent(iproc)=ncont_sent(iproc)+1
8744               nn=ncont_sent(iproc)
8745               zapas(1,nn,iproc)=ii
8746               zapas(2,nn,iproc)=jjc
8747               zapas(3,nn,iproc)=d_cont(j,ii)
8748               ind=3
8749               do kk=1,3
8750                 ind=ind+1
8751                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8752               enddo
8753               do kk=1,2
8754                 do ll=1,2
8755                   ind=ind+1
8756                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8757                 enddo
8758               enddo
8759               do jj=1,5
8760                 do kk=1,3
8761                   do ll=1,2
8762                     do mm=1,2
8763                       ind=ind+1
8764                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8765                     enddo
8766                   enddo
8767                 enddo
8768               enddo
8769               exit
8770             endif
8771           enddo
8772         endif
8773       enddo
8774       return
8775       end
8776 c------------------------------------------------------------------------------
8777       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8778       implicit real*8 (a-h,o-z)
8779       include 'DIMENSIONS'
8780       include 'COMMON.IOUNITS'
8781       include 'COMMON.DERIV'
8782       include 'COMMON.INTERACT'
8783       include 'COMMON.CONTACTS'
8784       include 'COMMON.SHIELD'
8785       include 'COMMON.CONTROL'
8786       double precision gx(3),gx1(3)
8787       logical lprn
8788       lprn=.false.
8789 C      print *,"wchodze",fac_shield(i),shield_mode
8790       eij=facont_hb(jj,i)
8791       ekl=facont_hb(kk,k)
8792       ees0pij=ees0p(jj,i)
8793       ees0pkl=ees0p(kk,k)
8794       ees0mij=ees0m(jj,i)
8795       ees0mkl=ees0m(kk,k)
8796       ekont=eij*ekl
8797       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8798 C*
8799 C     & fac_shield(i)**2*fac_shield(j)**2
8800 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8801 C Following 4 lines for diagnostics.
8802 cd    ees0pkl=0.0D0
8803 cd    ees0pij=1.0D0
8804 cd    ees0mkl=0.0D0
8805 cd    ees0mij=1.0D0
8806 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8807 c     & 'Contacts ',i,j,
8808 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8809 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8810 c     & 'gradcorr_long'
8811 C Calculate the multi-body contribution to energy.
8812 C      ecorr=ecorr+ekont*ees
8813 C Calculate multi-body contributions to the gradient.
8814       coeffpees0pij=coeffp*ees0pij
8815       coeffmees0mij=coeffm*ees0mij
8816       coeffpees0pkl=coeffp*ees0pkl
8817       coeffmees0mkl=coeffm*ees0mkl
8818       do ll=1,3
8819 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8820         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8821      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8822      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8823         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8824      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8825      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8826 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8827         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8828      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8829      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8830         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8831      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8832      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8833         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8834      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8835      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8836         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8837         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8838         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8839      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8840      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8841         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8842         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8843 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8844       enddo
8845 c      write (iout,*)
8846 cgrad      do m=i+1,j-1
8847 cgrad        do ll=1,3
8848 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8849 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8850 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8851 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8852 cgrad        enddo
8853 cgrad      enddo
8854 cgrad      do m=k+1,l-1
8855 cgrad        do ll=1,3
8856 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8857 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8858 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8859 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8860 cgrad        enddo
8861 cgrad      enddo
8862 c      write (iout,*) "ehbcorr",ekont*ees
8863 C      print *,ekont,ees,i,k
8864       ehbcorr=ekont*ees
8865 C now gradient over shielding
8866 C      return
8867       if (shield_mode.gt.0) then
8868        j=ees0plist(jj,i)
8869        l=ees0plist(kk,k)
8870 C        print *,i,j,fac_shield(i),fac_shield(j),
8871 C     &fac_shield(k),fac_shield(l)
8872         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8873      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8874           do ilist=1,ishield_list(i)
8875            iresshield=shield_list(ilist,i)
8876            do m=1,3
8877            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8878 C     &      *2.0
8879            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8880      &              rlocshield
8881      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8882             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8883      &+rlocshield
8884            enddo
8885           enddo
8886           do ilist=1,ishield_list(j)
8887            iresshield=shield_list(ilist,j)
8888            do m=1,3
8889            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8890 C     &     *2.0
8891            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8892      &              rlocshield
8893      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8894            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8895      &     +rlocshield
8896            enddo
8897           enddo
8898
8899           do ilist=1,ishield_list(k)
8900            iresshield=shield_list(ilist,k)
8901            do m=1,3
8902            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8903 C     &     *2.0
8904            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8905      &              rlocshield
8906      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8907            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8908      &     +rlocshield
8909            enddo
8910           enddo
8911           do ilist=1,ishield_list(l)
8912            iresshield=shield_list(ilist,l)
8913            do m=1,3
8914            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8915 C     &     *2.0
8916            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8917      &              rlocshield
8918      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8919            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8920      &     +rlocshield
8921            enddo
8922           enddo
8923 C          print *,gshieldx(m,iresshield)
8924           do m=1,3
8925             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8926      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8927             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8928      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8929             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8930      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8931             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8932      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8933
8934             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8935      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8936             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8937      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8938             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8939      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8940             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8941      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8942
8943            enddo
8944       endif
8945       endif
8946       return
8947       end
8948 #ifdef MOMENT
8949 C---------------------------------------------------------------------------
8950       subroutine dipole(i,j,jj)
8951       implicit real*8 (a-h,o-z)
8952       include 'DIMENSIONS'
8953       include 'COMMON.IOUNITS'
8954       include 'COMMON.CHAIN'
8955       include 'COMMON.FFIELD'
8956       include 'COMMON.DERIV'
8957       include 'COMMON.INTERACT'
8958       include 'COMMON.CONTACTS'
8959       include 'COMMON.TORSION'
8960       include 'COMMON.VAR'
8961       include 'COMMON.GEO'
8962       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8963      &  auxmat(2,2)
8964       iti1 = itortyp(itype(i+1))
8965       if (j.lt.nres-1) then
8966         itj1 = itype2loc(itype(j+1))
8967       else
8968         itj1=nloctyp
8969       endif
8970       do iii=1,2
8971         dipi(iii,1)=Ub2(iii,i)
8972         dipderi(iii)=Ub2der(iii,i)
8973         dipi(iii,2)=b1(iii,i+1)
8974         dipj(iii,1)=Ub2(iii,j)
8975         dipderj(iii)=Ub2der(iii,j)
8976         dipj(iii,2)=b1(iii,j+1)
8977       enddo
8978       kkk=0
8979       do iii=1,2
8980         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8981         do jjj=1,2
8982           kkk=kkk+1
8983           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8984         enddo
8985       enddo
8986       do kkk=1,5
8987         do lll=1,3
8988           mmm=0
8989           do iii=1,2
8990             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8991      &        auxvec(1))
8992             do jjj=1,2
8993               mmm=mmm+1
8994               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8995             enddo
8996           enddo
8997         enddo
8998       enddo
8999       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9000       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9001       do iii=1,2
9002         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9003       enddo
9004       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9005       do iii=1,2
9006         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9007       enddo
9008       return
9009       end
9010 #endif
9011 C---------------------------------------------------------------------------
9012       subroutine calc_eello(i,j,k,l,jj,kk)
9013 C
9014 C This subroutine computes matrices and vectors needed to calculate
9015 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9016 C
9017       implicit real*8 (a-h,o-z)
9018       include 'DIMENSIONS'
9019       include 'COMMON.IOUNITS'
9020       include 'COMMON.CHAIN'
9021       include 'COMMON.DERIV'
9022       include 'COMMON.INTERACT'
9023       include 'COMMON.CONTACTS'
9024       include 'COMMON.TORSION'
9025       include 'COMMON.VAR'
9026       include 'COMMON.GEO'
9027       include 'COMMON.FFIELD'
9028       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9029      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9030       logical lprn
9031       common /kutas/ lprn
9032 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9033 cd     & ' jj=',jj,' kk=',kk
9034 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9035 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9036 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9037       do iii=1,2
9038         do jjj=1,2
9039           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9040           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9041         enddo
9042       enddo
9043       call transpose2(aa1(1,1),aa1t(1,1))
9044       call transpose2(aa2(1,1),aa2t(1,1))
9045       do kkk=1,5
9046         do lll=1,3
9047           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9048      &      aa1tder(1,1,lll,kkk))
9049           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9050      &      aa2tder(1,1,lll,kkk))
9051         enddo
9052       enddo
9053       if (l.eq.j+1) then
9054 C parallel orientation of the two CA-CA-CA frames.
9055         if (i.gt.1) then
9056           iti=itype2loc(itype(i))
9057         else
9058           iti=nloctyp
9059         endif
9060         itk1=itype2loc(itype(k+1))
9061         itj=itype2loc(itype(j))
9062         if (l.lt.nres-1) then
9063           itl1=itype2loc(itype(l+1))
9064         else
9065           itl1=nloctyp
9066         endif
9067 C A1 kernel(j+1) A2T
9068 cd        do iii=1,2
9069 cd          write (iout,'(3f10.5,5x,3f10.5)')
9070 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9071 cd        enddo
9072         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9073      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9074      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9075 C Following matrices are needed only for 6-th order cumulants
9076         IF (wcorr6.gt.0.0d0) THEN
9077         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9078      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9079      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9080         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9081      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9082      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9083      &   ADtEAderx(1,1,1,1,1,1))
9084         lprn=.false.
9085         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9086      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9087      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9088      &   ADtEA1derx(1,1,1,1,1,1))
9089         ENDIF
9090 C End 6-th order cumulants
9091 cd        lprn=.false.
9092 cd        if (lprn) then
9093 cd        write (2,*) 'In calc_eello6'
9094 cd        do iii=1,2
9095 cd          write (2,*) 'iii=',iii
9096 cd          do kkk=1,5
9097 cd            write (2,*) 'kkk=',kkk
9098 cd            do jjj=1,2
9099 cd              write (2,'(3(2f10.5),5x)')
9100 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9101 cd            enddo
9102 cd          enddo
9103 cd        enddo
9104 cd        endif
9105         call transpose2(EUgder(1,1,k),auxmat(1,1))
9106         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9107         call transpose2(EUg(1,1,k),auxmat(1,1))
9108         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9109         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9110         do iii=1,2
9111           do kkk=1,5
9112             do lll=1,3
9113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9114      &          EAEAderx(1,1,lll,kkk,iii,1))
9115             enddo
9116           enddo
9117         enddo
9118 C A1T kernel(i+1) A2
9119         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9120      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9121      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9122 C Following matrices are needed only for 6-th order cumulants
9123         IF (wcorr6.gt.0.0d0) THEN
9124         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9125      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9126      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9127         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9128      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9129      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9130      &   ADtEAderx(1,1,1,1,1,2))
9131         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9132      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9133      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9134      &   ADtEA1derx(1,1,1,1,1,2))
9135         ENDIF
9136 C End 6-th order cumulants
9137         call transpose2(EUgder(1,1,l),auxmat(1,1))
9138         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9139         call transpose2(EUg(1,1,l),auxmat(1,1))
9140         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9141         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9142         do iii=1,2
9143           do kkk=1,5
9144             do lll=1,3
9145               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9146      &          EAEAderx(1,1,lll,kkk,iii,2))
9147             enddo
9148           enddo
9149         enddo
9150 C AEAb1 and AEAb2
9151 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9152 C They are needed only when the fifth- or the sixth-order cumulants are
9153 C indluded.
9154         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9155         call transpose2(AEA(1,1,1),auxmat(1,1))
9156         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9157         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9158         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9159         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9160         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9161         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9162         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9163         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9164         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9165         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9166         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9167         call transpose2(AEA(1,1,2),auxmat(1,1))
9168         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9169         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9170         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9171         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9172         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9173         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9174         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9175         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9176         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9177         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9178         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9179 C Calculate the Cartesian derivatives of the vectors.
9180         do iii=1,2
9181           do kkk=1,5
9182             do lll=1,3
9183               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9184               call matvec2(auxmat(1,1),b1(1,i),
9185      &          AEAb1derx(1,lll,kkk,iii,1,1))
9186               call matvec2(auxmat(1,1),Ub2(1,i),
9187      &          AEAb2derx(1,lll,kkk,iii,1,1))
9188               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9189      &          AEAb1derx(1,lll,kkk,iii,2,1))
9190               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9191      &          AEAb2derx(1,lll,kkk,iii,2,1))
9192               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9193               call matvec2(auxmat(1,1),b1(1,j),
9194      &          AEAb1derx(1,lll,kkk,iii,1,2))
9195               call matvec2(auxmat(1,1),Ub2(1,j),
9196      &          AEAb2derx(1,lll,kkk,iii,1,2))
9197               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9198      &          AEAb1derx(1,lll,kkk,iii,2,2))
9199               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9200      &          AEAb2derx(1,lll,kkk,iii,2,2))
9201             enddo
9202           enddo
9203         enddo
9204         ENDIF
9205 C End vectors
9206       else
9207 C Antiparallel orientation of the two CA-CA-CA frames.
9208         if (i.gt.1) then
9209           iti=itype2loc(itype(i))
9210         else
9211           iti=nloctyp
9212         endif
9213         itk1=itype2loc(itype(k+1))
9214         itl=itype2loc(itype(l))
9215         itj=itype2loc(itype(j))
9216         if (j.lt.nres-1) then
9217           itj1=itype2loc(itype(j+1))
9218         else
9219           itj1=nloctyp
9220         endif
9221 C A2 kernel(j-1)T A1T
9222         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9223      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9224      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9225 C Following matrices are needed only for 6-th order cumulants
9226         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9227      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9228         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9229      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9230      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9231         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9232      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9233      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9234      &   ADtEAderx(1,1,1,1,1,1))
9235         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9236      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9237      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9238      &   ADtEA1derx(1,1,1,1,1,1))
9239         ENDIF
9240 C End 6-th order cumulants
9241         call transpose2(EUgder(1,1,k),auxmat(1,1))
9242         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9243         call transpose2(EUg(1,1,k),auxmat(1,1))
9244         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9245         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9246         do iii=1,2
9247           do kkk=1,5
9248             do lll=1,3
9249               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9250      &          EAEAderx(1,1,lll,kkk,iii,1))
9251             enddo
9252           enddo
9253         enddo
9254 C A2T kernel(i+1)T A1
9255         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9256      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9257      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9258 C Following matrices are needed only for 6-th order cumulants
9259         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9260      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9261         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9262      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9263      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9264         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9265      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9266      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9267      &   ADtEAderx(1,1,1,1,1,2))
9268         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9269      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9270      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9271      &   ADtEA1derx(1,1,1,1,1,2))
9272         ENDIF
9273 C End 6-th order cumulants
9274         call transpose2(EUgder(1,1,j),auxmat(1,1))
9275         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9276         call transpose2(EUg(1,1,j),auxmat(1,1))
9277         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9278         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9279         do iii=1,2
9280           do kkk=1,5
9281             do lll=1,3
9282               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9283      &          EAEAderx(1,1,lll,kkk,iii,2))
9284             enddo
9285           enddo
9286         enddo
9287 C AEAb1 and AEAb2
9288 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9289 C They are needed only when the fifth- or the sixth-order cumulants are
9290 C indluded.
9291         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9292      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9293         call transpose2(AEA(1,1,1),auxmat(1,1))
9294         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9295         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9296         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9297         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9298         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9299         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9300         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9301         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9302         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9303         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9304         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9305         call transpose2(AEA(1,1,2),auxmat(1,1))
9306         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9307         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9308         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9309         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9310         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9311         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9312         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9313         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9314         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9315         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9316         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9317 C Calculate the Cartesian derivatives of the vectors.
9318         do iii=1,2
9319           do kkk=1,5
9320             do lll=1,3
9321               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9322               call matvec2(auxmat(1,1),b1(1,i),
9323      &          AEAb1derx(1,lll,kkk,iii,1,1))
9324               call matvec2(auxmat(1,1),Ub2(1,i),
9325      &          AEAb2derx(1,lll,kkk,iii,1,1))
9326               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9327      &          AEAb1derx(1,lll,kkk,iii,2,1))
9328               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9329      &          AEAb2derx(1,lll,kkk,iii,2,1))
9330               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9331               call matvec2(auxmat(1,1),b1(1,l),
9332      &          AEAb1derx(1,lll,kkk,iii,1,2))
9333               call matvec2(auxmat(1,1),Ub2(1,l),
9334      &          AEAb2derx(1,lll,kkk,iii,1,2))
9335               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9336      &          AEAb1derx(1,lll,kkk,iii,2,2))
9337               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9338      &          AEAb2derx(1,lll,kkk,iii,2,2))
9339             enddo
9340           enddo
9341         enddo
9342         ENDIF
9343 C End vectors
9344       endif
9345       return
9346       end
9347 C---------------------------------------------------------------------------
9348       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9349      &  KK,KKderg,AKA,AKAderg,AKAderx)
9350       implicit none
9351       integer nderg
9352       logical transp
9353       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9354      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9355      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9356       integer iii,kkk,lll
9357       integer jjj,mmm
9358       logical lprn
9359       common /kutas/ lprn
9360       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9361       do iii=1,nderg
9362         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9363      &    AKAderg(1,1,iii))
9364       enddo
9365 cd      if (lprn) write (2,*) 'In kernel'
9366       do kkk=1,5
9367 cd        if (lprn) write (2,*) 'kkk=',kkk
9368         do lll=1,3
9369           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9370      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9371 cd          if (lprn) then
9372 cd            write (2,*) 'lll=',lll
9373 cd            write (2,*) 'iii=1'
9374 cd            do jjj=1,2
9375 cd              write (2,'(3(2f10.5),5x)')
9376 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9377 cd            enddo
9378 cd          endif
9379           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9380      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9381 cd          if (lprn) then
9382 cd            write (2,*) 'lll=',lll
9383 cd            write (2,*) 'iii=2'
9384 cd            do jjj=1,2
9385 cd              write (2,'(3(2f10.5),5x)')
9386 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9387 cd            enddo
9388 cd          endif
9389         enddo
9390       enddo
9391       return
9392       end
9393 C---------------------------------------------------------------------------
9394       double precision function eello4(i,j,k,l,jj,kk)
9395       implicit real*8 (a-h,o-z)
9396       include 'DIMENSIONS'
9397       include 'COMMON.IOUNITS'
9398       include 'COMMON.CHAIN'
9399       include 'COMMON.DERIV'
9400       include 'COMMON.INTERACT'
9401       include 'COMMON.CONTACTS'
9402       include 'COMMON.TORSION'
9403       include 'COMMON.VAR'
9404       include 'COMMON.GEO'
9405       double precision pizda(2,2),ggg1(3),ggg2(3)
9406 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9407 cd        eello4=0.0d0
9408 cd        return
9409 cd      endif
9410 cd      print *,'eello4:',i,j,k,l,jj,kk
9411 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9412 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9413 cold      eij=facont_hb(jj,i)
9414 cold      ekl=facont_hb(kk,k)
9415 cold      ekont=eij*ekl
9416       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9417 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9418       gcorr_loc(k-1)=gcorr_loc(k-1)
9419      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9420       if (l.eq.j+1) then
9421         gcorr_loc(l-1)=gcorr_loc(l-1)
9422      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9423       else
9424         gcorr_loc(j-1)=gcorr_loc(j-1)
9425      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9426       endif
9427       do iii=1,2
9428         do kkk=1,5
9429           do lll=1,3
9430             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9431      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9432 cd            derx(lll,kkk,iii)=0.0d0
9433           enddo
9434         enddo
9435       enddo
9436 cd      gcorr_loc(l-1)=0.0d0
9437 cd      gcorr_loc(j-1)=0.0d0
9438 cd      gcorr_loc(k-1)=0.0d0
9439 cd      eel4=1.0d0
9440 cd      write (iout,*)'Contacts have occurred for peptide groups',
9441 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9442 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9443       if (j.lt.nres-1) then
9444         j1=j+1
9445         j2=j-1
9446       else
9447         j1=j-1
9448         j2=j-2
9449       endif
9450       if (l.lt.nres-1) then
9451         l1=l+1
9452         l2=l-1
9453       else
9454         l1=l-1
9455         l2=l-2
9456       endif
9457       do ll=1,3
9458 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9459 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9460         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9461         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9462 cgrad        ghalf=0.5d0*ggg1(ll)
9463         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9464         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9465         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9466         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9467         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9468         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9469 cgrad        ghalf=0.5d0*ggg2(ll)
9470         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9471         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9472         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9473         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9474         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9475         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9476       enddo
9477 cgrad      do m=i+1,j-1
9478 cgrad        do ll=1,3
9479 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9480 cgrad        enddo
9481 cgrad      enddo
9482 cgrad      do m=k+1,l-1
9483 cgrad        do ll=1,3
9484 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9485 cgrad        enddo
9486 cgrad      enddo
9487 cgrad      do m=i+2,j2
9488 cgrad        do ll=1,3
9489 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9490 cgrad        enddo
9491 cgrad      enddo
9492 cgrad      do m=k+2,l2
9493 cgrad        do ll=1,3
9494 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9495 cgrad        enddo
9496 cgrad      enddo
9497 cd      do iii=1,nres-3
9498 cd        write (2,*) iii,gcorr_loc(iii)
9499 cd      enddo
9500       eello4=ekont*eel4
9501 cd      write (2,*) 'ekont',ekont
9502 cd      write (iout,*) 'eello4',ekont*eel4
9503       return
9504       end
9505 C---------------------------------------------------------------------------
9506       double precision function eello5(i,j,k,l,jj,kk)
9507       implicit real*8 (a-h,o-z)
9508       include 'DIMENSIONS'
9509       include 'COMMON.IOUNITS'
9510       include 'COMMON.CHAIN'
9511       include 'COMMON.DERIV'
9512       include 'COMMON.INTERACT'
9513       include 'COMMON.CONTACTS'
9514       include 'COMMON.TORSION'
9515       include 'COMMON.VAR'
9516       include 'COMMON.GEO'
9517       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9518       double precision ggg1(3),ggg2(3)
9519 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9520 C                                                                              C
9521 C                            Parallel chains                                   C
9522 C                                                                              C
9523 C          o             o                   o             o                   C
9524 C         /l\           / \             \   / \           / \   /              C
9525 C        /   \         /   \             \ /   \         /   \ /               C
9526 C       j| o |l1       | o |              o| o |         | o |o                C
9527 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9528 C      \i/   \         /   \ /             /   \         /   \                 C
9529 C       o    k1             o                                                  C
9530 C         (I)          (II)                (III)          (IV)                 C
9531 C                                                                              C
9532 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9533 C                                                                              C
9534 C                            Antiparallel chains                               C
9535 C                                                                              C
9536 C          o             o                   o             o                   C
9537 C         /j\           / \             \   / \           / \   /              C
9538 C        /   \         /   \             \ /   \         /   \ /               C
9539 C      j1| o |l        | o |              o| o |         | o |o                C
9540 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9541 C      \i/   \         /   \ /             /   \         /   \                 C
9542 C       o     k1            o                                                  C
9543 C         (I)          (II)                (III)          (IV)                 C
9544 C                                                                              C
9545 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9546 C                                                                              C
9547 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9548 C                                                                              C
9549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9550 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9551 cd        eello5=0.0d0
9552 cd        return
9553 cd      endif
9554 cd      write (iout,*)
9555 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9556 cd     &   ' and',k,l
9557       itk=itype2loc(itype(k))
9558       itl=itype2loc(itype(l))
9559       itj=itype2loc(itype(j))
9560       eello5_1=0.0d0
9561       eello5_2=0.0d0
9562       eello5_3=0.0d0
9563       eello5_4=0.0d0
9564 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9565 cd     &   eel5_3_num,eel5_4_num)
9566       do iii=1,2
9567         do kkk=1,5
9568           do lll=1,3
9569             derx(lll,kkk,iii)=0.0d0
9570           enddo
9571         enddo
9572       enddo
9573 cd      eij=facont_hb(jj,i)
9574 cd      ekl=facont_hb(kk,k)
9575 cd      ekont=eij*ekl
9576 cd      write (iout,*)'Contacts have occurred for peptide groups',
9577 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9578 cd      goto 1111
9579 C Contribution from the graph I.
9580 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9581 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9582       call transpose2(EUg(1,1,k),auxmat(1,1))
9583       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9584       vv(1)=pizda(1,1)-pizda(2,2)
9585       vv(2)=pizda(1,2)+pizda(2,1)
9586       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9587      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9588 C Explicit gradient in virtual-dihedral angles.
9589       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9590      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9591      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9592       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9593       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9594       vv(1)=pizda(1,1)-pizda(2,2)
9595       vv(2)=pizda(1,2)+pizda(2,1)
9596       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9597      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9598      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9599       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9600       vv(1)=pizda(1,1)-pizda(2,2)
9601       vv(2)=pizda(1,2)+pizda(2,1)
9602       if (l.eq.j+1) then
9603         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9604      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9605      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9606       else
9607         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9608      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9609      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9610       endif
9611 C Cartesian gradient
9612       do iii=1,2
9613         do kkk=1,5
9614           do lll=1,3
9615             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9616      &        pizda(1,1))
9617             vv(1)=pizda(1,1)-pizda(2,2)
9618             vv(2)=pizda(1,2)+pizda(2,1)
9619             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9620      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9621      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9622           enddo
9623         enddo
9624       enddo
9625 c      goto 1112
9626 c1111  continue
9627 C Contribution from graph II
9628       call transpose2(EE(1,1,k),auxmat(1,1))
9629       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9630       vv(1)=pizda(1,1)+pizda(2,2)
9631       vv(2)=pizda(2,1)-pizda(1,2)
9632       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9633      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9634 C Explicit gradient in virtual-dihedral angles.
9635       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9636      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9637       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9638       vv(1)=pizda(1,1)+pizda(2,2)
9639       vv(2)=pizda(2,1)-pizda(1,2)
9640       if (l.eq.j+1) then
9641         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9642      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9643      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9644       else
9645         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9646      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9647      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9648       endif
9649 C Cartesian gradient
9650       do iii=1,2
9651         do kkk=1,5
9652           do lll=1,3
9653             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9654      &        pizda(1,1))
9655             vv(1)=pizda(1,1)+pizda(2,2)
9656             vv(2)=pizda(2,1)-pizda(1,2)
9657             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9658      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9659      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9660           enddo
9661         enddo
9662       enddo
9663 cd      goto 1112
9664 cd1111  continue
9665       if (l.eq.j+1) then
9666 cd        goto 1110
9667 C Parallel orientation
9668 C Contribution from graph III
9669         call transpose2(EUg(1,1,l),auxmat(1,1))
9670         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9671         vv(1)=pizda(1,1)-pizda(2,2)
9672         vv(2)=pizda(1,2)+pizda(2,1)
9673         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9674      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9675 C Explicit gradient in virtual-dihedral angles.
9676         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9677      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9678      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9679         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9680         vv(1)=pizda(1,1)-pizda(2,2)
9681         vv(2)=pizda(1,2)+pizda(2,1)
9682         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9683      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9684      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9685         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9686         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9687         vv(1)=pizda(1,1)-pizda(2,2)
9688         vv(2)=pizda(1,2)+pizda(2,1)
9689         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9690      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9692 C Cartesian gradient
9693         do iii=1,2
9694           do kkk=1,5
9695             do lll=1,3
9696               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9697      &          pizda(1,1))
9698               vv(1)=pizda(1,1)-pizda(2,2)
9699               vv(2)=pizda(1,2)+pizda(2,1)
9700               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9701      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9702      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9703             enddo
9704           enddo
9705         enddo
9706 cd        goto 1112
9707 C Contribution from graph IV
9708 cd1110    continue
9709         call transpose2(EE(1,1,l),auxmat(1,1))
9710         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9711         vv(1)=pizda(1,1)+pizda(2,2)
9712         vv(2)=pizda(2,1)-pizda(1,2)
9713         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9714      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9715 C Explicit gradient in virtual-dihedral angles.
9716         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9717      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9718         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9719         vv(1)=pizda(1,1)+pizda(2,2)
9720         vv(2)=pizda(2,1)-pizda(1,2)
9721         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9722      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9723      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9724 C Cartesian gradient
9725         do iii=1,2
9726           do kkk=1,5
9727             do lll=1,3
9728               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9729      &          pizda(1,1))
9730               vv(1)=pizda(1,1)+pizda(2,2)
9731               vv(2)=pizda(2,1)-pizda(1,2)
9732               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9733      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9734      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9735             enddo
9736           enddo
9737         enddo
9738       else
9739 C Antiparallel orientation
9740 C Contribution from graph III
9741 c        goto 1110
9742         call transpose2(EUg(1,1,j),auxmat(1,1))
9743         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9744         vv(1)=pizda(1,1)-pizda(2,2)
9745         vv(2)=pizda(1,2)+pizda(2,1)
9746         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9747      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9748 C Explicit gradient in virtual-dihedral angles.
9749         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9750      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9751      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9752         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9753         vv(1)=pizda(1,1)-pizda(2,2)
9754         vv(2)=pizda(1,2)+pizda(2,1)
9755         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9756      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9757      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9758         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9759         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9760         vv(1)=pizda(1,1)-pizda(2,2)
9761         vv(2)=pizda(1,2)+pizda(2,1)
9762         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9763      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9764      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9765 C Cartesian gradient
9766         do iii=1,2
9767           do kkk=1,5
9768             do lll=1,3
9769               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9770      &          pizda(1,1))
9771               vv(1)=pizda(1,1)-pizda(2,2)
9772               vv(2)=pizda(1,2)+pizda(2,1)
9773               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9774      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9775      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9776             enddo
9777           enddo
9778         enddo
9779 cd        goto 1112
9780 C Contribution from graph IV
9781 1110    continue
9782         call transpose2(EE(1,1,j),auxmat(1,1))
9783         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9784         vv(1)=pizda(1,1)+pizda(2,2)
9785         vv(2)=pizda(2,1)-pizda(1,2)
9786         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9787      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9788 C Explicit gradient in virtual-dihedral angles.
9789         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9790      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9791         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9792         vv(1)=pizda(1,1)+pizda(2,2)
9793         vv(2)=pizda(2,1)-pizda(1,2)
9794         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9795      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9796      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9797 C Cartesian gradient
9798         do iii=1,2
9799           do kkk=1,5
9800             do lll=1,3
9801               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9802      &          pizda(1,1))
9803               vv(1)=pizda(1,1)+pizda(2,2)
9804               vv(2)=pizda(2,1)-pizda(1,2)
9805               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9806      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9807      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9808             enddo
9809           enddo
9810         enddo
9811       endif
9812 1112  continue
9813       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9814 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9815 cd        write (2,*) 'ijkl',i,j,k,l
9816 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9817 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9818 cd      endif
9819 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9820 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9821 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9822 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9823       if (j.lt.nres-1) then
9824         j1=j+1
9825         j2=j-1
9826       else
9827         j1=j-1
9828         j2=j-2
9829       endif
9830       if (l.lt.nres-1) then
9831         l1=l+1
9832         l2=l-1
9833       else
9834         l1=l-1
9835         l2=l-2
9836       endif
9837 cd      eij=1.0d0
9838 cd      ekl=1.0d0
9839 cd      ekont=1.0d0
9840 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9841 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9842 C        summed up outside the subrouine as for the other subroutines
9843 C        handling long-range interactions. The old code is commented out
9844 C        with "cgrad" to keep track of changes.
9845       do ll=1,3
9846 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9847 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9848         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9849         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9850 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9851 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9852 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9853 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9854 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9855 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9856 c     &   gradcorr5ij,
9857 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9858 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9859 cgrad        ghalf=0.5d0*ggg1(ll)
9860 cd        ghalf=0.0d0
9861         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9862         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9863         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9864         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9865         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9866         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9867 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9868 cgrad        ghalf=0.5d0*ggg2(ll)
9869 cd        ghalf=0.0d0
9870         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9871         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9872         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9873         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9874         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9875         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9876       enddo
9877 cd      goto 1112
9878 cgrad      do m=i+1,j-1
9879 cgrad        do ll=1,3
9880 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9881 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9882 cgrad        enddo
9883 cgrad      enddo
9884 cgrad      do m=k+1,l-1
9885 cgrad        do ll=1,3
9886 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9887 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9888 cgrad        enddo
9889 cgrad      enddo
9890 c1112  continue
9891 cgrad      do m=i+2,j2
9892 cgrad        do ll=1,3
9893 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9894 cgrad        enddo
9895 cgrad      enddo
9896 cgrad      do m=k+2,l2
9897 cgrad        do ll=1,3
9898 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9899 cgrad        enddo
9900 cgrad      enddo
9901 cd      do iii=1,nres-3
9902 cd        write (2,*) iii,g_corr5_loc(iii)
9903 cd      enddo
9904       eello5=ekont*eel5
9905 cd      write (2,*) 'ekont',ekont
9906 cd      write (iout,*) 'eello5',ekont*eel5
9907       return
9908       end
9909 c--------------------------------------------------------------------------
9910       double precision function eello6(i,j,k,l,jj,kk)
9911       implicit real*8 (a-h,o-z)
9912       include 'DIMENSIONS'
9913       include 'COMMON.IOUNITS'
9914       include 'COMMON.CHAIN'
9915       include 'COMMON.DERIV'
9916       include 'COMMON.INTERACT'
9917       include 'COMMON.CONTACTS'
9918       include 'COMMON.TORSION'
9919       include 'COMMON.VAR'
9920       include 'COMMON.GEO'
9921       include 'COMMON.FFIELD'
9922       double precision ggg1(3),ggg2(3)
9923 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9924 cd        eello6=0.0d0
9925 cd        return
9926 cd      endif
9927 cd      write (iout,*)
9928 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9929 cd     &   ' and',k,l
9930       eello6_1=0.0d0
9931       eello6_2=0.0d0
9932       eello6_3=0.0d0
9933       eello6_4=0.0d0
9934       eello6_5=0.0d0
9935       eello6_6=0.0d0
9936 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9937 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9938       do iii=1,2
9939         do kkk=1,5
9940           do lll=1,3
9941             derx(lll,kkk,iii)=0.0d0
9942           enddo
9943         enddo
9944       enddo
9945 cd      eij=facont_hb(jj,i)
9946 cd      ekl=facont_hb(kk,k)
9947 cd      ekont=eij*ekl
9948 cd      eij=1.0d0
9949 cd      ekl=1.0d0
9950 cd      ekont=1.0d0
9951       if (l.eq.j+1) then
9952         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9953         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9954         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9955         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9956         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9957         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9958       else
9959         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9960         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9961         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9962         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9963         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9964           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9965         else
9966           eello6_5=0.0d0
9967         endif
9968         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9969       endif
9970 C If turn contributions are considered, they will be handled separately.
9971       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9972 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9973 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9974 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9975 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9976 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9977 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9978 cd      goto 1112
9979       if (j.lt.nres-1) then
9980         j1=j+1
9981         j2=j-1
9982       else
9983         j1=j-1
9984         j2=j-2
9985       endif
9986       if (l.lt.nres-1) then
9987         l1=l+1
9988         l2=l-1
9989       else
9990         l1=l-1
9991         l2=l-2
9992       endif
9993       do ll=1,3
9994 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9995 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9996 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9997 cgrad        ghalf=0.5d0*ggg1(ll)
9998 cd        ghalf=0.0d0
9999         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10000         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10001         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10002         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10003         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10004         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10005         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10006         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10007 cgrad        ghalf=0.5d0*ggg2(ll)
10008 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10009 cd        ghalf=0.0d0
10010         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10011         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10012         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10013         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10014         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10015         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10016       enddo
10017 cd      goto 1112
10018 cgrad      do m=i+1,j-1
10019 cgrad        do ll=1,3
10020 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10021 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10022 cgrad        enddo
10023 cgrad      enddo
10024 cgrad      do m=k+1,l-1
10025 cgrad        do ll=1,3
10026 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10027 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10028 cgrad        enddo
10029 cgrad      enddo
10030 cgrad1112  continue
10031 cgrad      do m=i+2,j2
10032 cgrad        do ll=1,3
10033 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10034 cgrad        enddo
10035 cgrad      enddo
10036 cgrad      do m=k+2,l2
10037 cgrad        do ll=1,3
10038 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10039 cgrad        enddo
10040 cgrad      enddo
10041 cd      do iii=1,nres-3
10042 cd        write (2,*) iii,g_corr6_loc(iii)
10043 cd      enddo
10044       eello6=ekont*eel6
10045 cd      write (2,*) 'ekont',ekont
10046 cd      write (iout,*) 'eello6',ekont*eel6
10047       return
10048       end
10049 c--------------------------------------------------------------------------
10050       double precision function eello6_graph1(i,j,k,l,imat,swap)
10051       implicit real*8 (a-h,o-z)
10052       include 'DIMENSIONS'
10053       include 'COMMON.IOUNITS'
10054       include 'COMMON.CHAIN'
10055       include 'COMMON.DERIV'
10056       include 'COMMON.INTERACT'
10057       include 'COMMON.CONTACTS'
10058       include 'COMMON.TORSION'
10059       include 'COMMON.VAR'
10060       include 'COMMON.GEO'
10061       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10062       logical swap
10063       logical lprn
10064       common /kutas/ lprn
10065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10066 C                                                                              C
10067 C      Parallel       Antiparallel                                             C
10068 C                                                                              C
10069 C          o             o                                                     C
10070 C         /l\           /j\                                                    C
10071 C        /   \         /   \                                                   C
10072 C       /| o |         | o |\                                                  C
10073 C     \ j|/k\|  /   \  |/k\|l /                                                C
10074 C      \ /   \ /     \ /   \ /                                                 C
10075 C       o     o       o     o                                                  C
10076 C       i             i                                                        C
10077 C                                                                              C
10078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10079       itk=itype2loc(itype(k))
10080       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10081       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10082       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10083       call transpose2(EUgC(1,1,k),auxmat(1,1))
10084       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10085       vv1(1)=pizda1(1,1)-pizda1(2,2)
10086       vv1(2)=pizda1(1,2)+pizda1(2,1)
10087       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10088       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10089       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10090       s5=scalar2(vv(1),Dtobr2(1,i))
10091 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10092       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10093       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10094      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10095      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10096      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10097      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10098      & +scalar2(vv(1),Dtobr2der(1,i)))
10099       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10100       vv1(1)=pizda1(1,1)-pizda1(2,2)
10101       vv1(2)=pizda1(1,2)+pizda1(2,1)
10102       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10103       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10104       if (l.eq.j+1) then
10105         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10106      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10107      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10108      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10109      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10110       else
10111         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10112      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10113      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10114      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10115      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10116       endif
10117       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10118       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10119       vv1(1)=pizda1(1,1)-pizda1(2,2)
10120       vv1(2)=pizda1(1,2)+pizda1(2,1)
10121       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10122      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10123      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10124      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10125       do iii=1,2
10126         if (swap) then
10127           ind=3-iii
10128         else
10129           ind=iii
10130         endif
10131         do kkk=1,5
10132           do lll=1,3
10133             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10134             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10135             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10136             call transpose2(EUgC(1,1,k),auxmat(1,1))
10137             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10138      &        pizda1(1,1))
10139             vv1(1)=pizda1(1,1)-pizda1(2,2)
10140             vv1(2)=pizda1(1,2)+pizda1(2,1)
10141             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10142             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10143      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10144             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10145      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10146             s5=scalar2(vv(1),Dtobr2(1,i))
10147             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10148           enddo
10149         enddo
10150       enddo
10151       return
10152       end
10153 c----------------------------------------------------------------------------
10154       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10155       implicit real*8 (a-h,o-z)
10156       include 'DIMENSIONS'
10157       include 'COMMON.IOUNITS'
10158       include 'COMMON.CHAIN'
10159       include 'COMMON.DERIV'
10160       include 'COMMON.INTERACT'
10161       include 'COMMON.CONTACTS'
10162       include 'COMMON.TORSION'
10163       include 'COMMON.VAR'
10164       include 'COMMON.GEO'
10165       logical swap
10166       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10167      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10168       logical lprn
10169       common /kutas/ lprn
10170 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10171 C                                                                              C
10172 C      Parallel       Antiparallel                                             C
10173 C                                                                              C
10174 C          o             o                                                     C
10175 C     \   /l\           /j\   /                                                C
10176 C      \ /   \         /   \ /                                                 C
10177 C       o| o |         | o |o                                                  C
10178 C     \ j|/k\|      \  |/k\|l                                                  C
10179 C      \ /   \       \ /   \                                                   C
10180 C       o             o                                                        C
10181 C       i             i                                                        C
10182 C                                                                              C
10183 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10184 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10185 C AL 7/4/01 s1 would occur in the sixth-order moment,
10186 C           but not in a cluster cumulant
10187 #ifdef MOMENT
10188       s1=dip(1,jj,i)*dip(1,kk,k)
10189 #endif
10190       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10191       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10192       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10193       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10194       call transpose2(EUg(1,1,k),auxmat(1,1))
10195       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10196       vv(1)=pizda(1,1)-pizda(2,2)
10197       vv(2)=pizda(1,2)+pizda(2,1)
10198       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10199 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10200 #ifdef MOMENT
10201       eello6_graph2=-(s1+s2+s3+s4)
10202 #else
10203       eello6_graph2=-(s2+s3+s4)
10204 #endif
10205 c      eello6_graph2=-s3
10206 C Derivatives in gamma(i-1)
10207       if (i.gt.1) then
10208 #ifdef MOMENT
10209         s1=dipderg(1,jj,i)*dip(1,kk,k)
10210 #endif
10211         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10212         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10213         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10214         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10215 #ifdef MOMENT
10216         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10217 #else
10218         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10219 #endif
10220 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10221       endif
10222 C Derivatives in gamma(k-1)
10223 #ifdef MOMENT
10224       s1=dip(1,jj,i)*dipderg(1,kk,k)
10225 #endif
10226       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10227       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10228       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10229       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10230       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10231       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10232       vv(1)=pizda(1,1)-pizda(2,2)
10233       vv(2)=pizda(1,2)+pizda(2,1)
10234       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10235 #ifdef MOMENT
10236       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10237 #else
10238       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10239 #endif
10240 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10241 C Derivatives in gamma(j-1) or gamma(l-1)
10242       if (j.gt.1) then
10243 #ifdef MOMENT
10244         s1=dipderg(3,jj,i)*dip(1,kk,k)
10245 #endif
10246         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10247         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10248         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10249         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10250         vv(1)=pizda(1,1)-pizda(2,2)
10251         vv(2)=pizda(1,2)+pizda(2,1)
10252         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10253 #ifdef MOMENT
10254         if (swap) then
10255           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10256         else
10257           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10258         endif
10259 #endif
10260         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10261 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10262       endif
10263 C Derivatives in gamma(l-1) or gamma(j-1)
10264       if (l.gt.1) then
10265 #ifdef MOMENT
10266         s1=dip(1,jj,i)*dipderg(3,kk,k)
10267 #endif
10268         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10269         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10270         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10271         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10272         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10273         vv(1)=pizda(1,1)-pizda(2,2)
10274         vv(2)=pizda(1,2)+pizda(2,1)
10275         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10276 #ifdef MOMENT
10277         if (swap) then
10278           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10279         else
10280           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10281         endif
10282 #endif
10283         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10284 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10285       endif
10286 C Cartesian derivatives.
10287       if (lprn) then
10288         write (2,*) 'In eello6_graph2'
10289         do iii=1,2
10290           write (2,*) 'iii=',iii
10291           do kkk=1,5
10292             write (2,*) 'kkk=',kkk
10293             do jjj=1,2
10294               write (2,'(3(2f10.5),5x)')
10295      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10296             enddo
10297           enddo
10298         enddo
10299       endif
10300       do iii=1,2
10301         do kkk=1,5
10302           do lll=1,3
10303 #ifdef MOMENT
10304             if (iii.eq.1) then
10305               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10306             else
10307               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10308             endif
10309 #endif
10310             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10311      &        auxvec(1))
10312             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10313             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10314      &        auxvec(1))
10315             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10316             call transpose2(EUg(1,1,k),auxmat(1,1))
10317             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10318      &        pizda(1,1))
10319             vv(1)=pizda(1,1)-pizda(2,2)
10320             vv(2)=pizda(1,2)+pizda(2,1)
10321             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10322 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10323 #ifdef MOMENT
10324             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10325 #else
10326             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10327 #endif
10328             if (swap) then
10329               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10330             else
10331               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10332             endif
10333           enddo
10334         enddo
10335       enddo
10336       return
10337       end
10338 c----------------------------------------------------------------------------
10339       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10340       implicit real*8 (a-h,o-z)
10341       include 'DIMENSIONS'
10342       include 'COMMON.IOUNITS'
10343       include 'COMMON.CHAIN'
10344       include 'COMMON.DERIV'
10345       include 'COMMON.INTERACT'
10346       include 'COMMON.CONTACTS'
10347       include 'COMMON.TORSION'
10348       include 'COMMON.VAR'
10349       include 'COMMON.GEO'
10350       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10351       logical swap
10352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10353 C                                                                              C
10354 C      Parallel       Antiparallel                                             C
10355 C                                                                              C
10356 C          o             o                                                     C
10357 C         /l\   /   \   /j\                                                    C
10358 C        /   \ /     \ /   \                                                   C
10359 C       /| o |o       o| o |\                                                  C
10360 C       j|/k\|  /      |/k\|l /                                                C
10361 C        /   \ /       /   \ /                                                 C
10362 C       /     o       /     o                                                  C
10363 C       i             i                                                        C
10364 C                                                                              C
10365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10366 C
10367 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10368 C           energy moment and not to the cluster cumulant.
10369       iti=itortyp(itype(i))
10370       if (j.lt.nres-1) then
10371         itj1=itype2loc(itype(j+1))
10372       else
10373         itj1=nloctyp
10374       endif
10375       itk=itype2loc(itype(k))
10376       itk1=itype2loc(itype(k+1))
10377       if (l.lt.nres-1) then
10378         itl1=itype2loc(itype(l+1))
10379       else
10380         itl1=nloctyp
10381       endif
10382 #ifdef MOMENT
10383       s1=dip(4,jj,i)*dip(4,kk,k)
10384 #endif
10385       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10386       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10387       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10388       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10389       call transpose2(EE(1,1,k),auxmat(1,1))
10390       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10391       vv(1)=pizda(1,1)+pizda(2,2)
10392       vv(2)=pizda(2,1)-pizda(1,2)
10393       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10394 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10395 cd     & "sum",-(s2+s3+s4)
10396 #ifdef MOMENT
10397       eello6_graph3=-(s1+s2+s3+s4)
10398 #else
10399       eello6_graph3=-(s2+s3+s4)
10400 #endif
10401 c      eello6_graph3=-s4
10402 C Derivatives in gamma(k-1)
10403       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10404       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10405       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10406       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10407 C Derivatives in gamma(l-1)
10408       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10409       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10410       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10411       vv(1)=pizda(1,1)+pizda(2,2)
10412       vv(2)=pizda(2,1)-pizda(1,2)
10413       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10414       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10415 C Cartesian derivatives.
10416       do iii=1,2
10417         do kkk=1,5
10418           do lll=1,3
10419 #ifdef MOMENT
10420             if (iii.eq.1) then
10421               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10422             else
10423               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10424             endif
10425 #endif
10426             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10427      &        auxvec(1))
10428             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10429             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10430      &        auxvec(1))
10431             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10432             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10433      &        pizda(1,1))
10434             vv(1)=pizda(1,1)+pizda(2,2)
10435             vv(2)=pizda(2,1)-pizda(1,2)
10436             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10437 #ifdef MOMENT
10438             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10439 #else
10440             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10441 #endif
10442             if (swap) then
10443               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10444             else
10445               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10446             endif
10447 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10448           enddo
10449         enddo
10450       enddo
10451       return
10452       end
10453 c----------------------------------------------------------------------------
10454       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10455       implicit real*8 (a-h,o-z)
10456       include 'DIMENSIONS'
10457       include 'COMMON.IOUNITS'
10458       include 'COMMON.CHAIN'
10459       include 'COMMON.DERIV'
10460       include 'COMMON.INTERACT'
10461       include 'COMMON.CONTACTS'
10462       include 'COMMON.TORSION'
10463       include 'COMMON.VAR'
10464       include 'COMMON.GEO'
10465       include 'COMMON.FFIELD'
10466       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10467      & auxvec1(2),auxmat1(2,2)
10468       logical swap
10469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10470 C                                                                              C
10471 C      Parallel       Antiparallel                                             C
10472 C                                                                              C
10473 C          o             o                                                     C
10474 C         /l\   /   \   /j\                                                    C
10475 C        /   \ /     \ /   \                                                   C
10476 C       /| o |o       o| o |\                                                  C
10477 C     \ j|/k\|      \  |/k\|l                                                  C
10478 C      \ /   \       \ /   \                                                   C
10479 C       o     \       o     \                                                  C
10480 C       i             i                                                        C
10481 C                                                                              C
10482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10483 C
10484 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10485 C           energy moment and not to the cluster cumulant.
10486 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10487       iti=itype2loc(itype(i))
10488       itj=itype2loc(itype(j))
10489       if (j.lt.nres-1) then
10490         itj1=itype2loc(itype(j+1))
10491       else
10492         itj1=nloctyp
10493       endif
10494       itk=itype2loc(itype(k))
10495       if (k.lt.nres-1) then
10496         itk1=itype2loc(itype(k+1))
10497       else
10498         itk1=nloctyp
10499       endif
10500       itl=itype2loc(itype(l))
10501       if (l.lt.nres-1) then
10502         itl1=itype2loc(itype(l+1))
10503       else
10504         itl1=nloctyp
10505       endif
10506 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10507 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10508 cd     & ' itl',itl,' itl1',itl1
10509 #ifdef MOMENT
10510       if (imat.eq.1) then
10511         s1=dip(3,jj,i)*dip(3,kk,k)
10512       else
10513         s1=dip(2,jj,j)*dip(2,kk,l)
10514       endif
10515 #endif
10516       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10517       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10518       if (j.eq.l+1) then
10519         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10520         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10521       else
10522         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10523         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10524       endif
10525       call transpose2(EUg(1,1,k),auxmat(1,1))
10526       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10527       vv(1)=pizda(1,1)-pizda(2,2)
10528       vv(2)=pizda(2,1)+pizda(1,2)
10529       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10530 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10531 #ifdef MOMENT
10532       eello6_graph4=-(s1+s2+s3+s4)
10533 #else
10534       eello6_graph4=-(s2+s3+s4)
10535 #endif
10536 C Derivatives in gamma(i-1)
10537       if (i.gt.1) then
10538 #ifdef MOMENT
10539         if (imat.eq.1) then
10540           s1=dipderg(2,jj,i)*dip(3,kk,k)
10541         else
10542           s1=dipderg(4,jj,j)*dip(2,kk,l)
10543         endif
10544 #endif
10545         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10546         if (j.eq.l+1) then
10547           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10548           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10549         else
10550           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10551           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10552         endif
10553         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10554         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10555 cd          write (2,*) 'turn6 derivatives'
10556 #ifdef MOMENT
10557           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10558 #else
10559           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10560 #endif
10561         else
10562 #ifdef MOMENT
10563           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10564 #else
10565           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10566 #endif
10567         endif
10568       endif
10569 C Derivatives in gamma(k-1)
10570 #ifdef MOMENT
10571       if (imat.eq.1) then
10572         s1=dip(3,jj,i)*dipderg(2,kk,k)
10573       else
10574         s1=dip(2,jj,j)*dipderg(4,kk,l)
10575       endif
10576 #endif
10577       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10578       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10579       if (j.eq.l+1) then
10580         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10581         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10582       else
10583         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10584         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10585       endif
10586       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10587       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10588       vv(1)=pizda(1,1)-pizda(2,2)
10589       vv(2)=pizda(2,1)+pizda(1,2)
10590       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10591       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10592 #ifdef MOMENT
10593         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10594 #else
10595         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10596 #endif
10597       else
10598 #ifdef MOMENT
10599         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10600 #else
10601         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10602 #endif
10603       endif
10604 C Derivatives in gamma(j-1) or gamma(l-1)
10605       if (l.eq.j+1 .and. l.gt.1) then
10606         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10607         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10608         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10609         vv(1)=pizda(1,1)-pizda(2,2)
10610         vv(2)=pizda(2,1)+pizda(1,2)
10611         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10612         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10613       else if (j.gt.1) then
10614         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10615         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10616         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10617         vv(1)=pizda(1,1)-pizda(2,2)
10618         vv(2)=pizda(2,1)+pizda(1,2)
10619         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10620         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10621           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10622         else
10623           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10624         endif
10625       endif
10626 C Cartesian derivatives.
10627       do iii=1,2
10628         do kkk=1,5
10629           do lll=1,3
10630 #ifdef MOMENT
10631             if (iii.eq.1) then
10632               if (imat.eq.1) then
10633                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10634               else
10635                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10636               endif
10637             else
10638               if (imat.eq.1) then
10639                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10640               else
10641                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10642               endif
10643             endif
10644 #endif
10645             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10646      &        auxvec(1))
10647             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10648             if (j.eq.l+1) then
10649               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10650      &          b1(1,j+1),auxvec(1))
10651               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10652             else
10653               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10654      &          b1(1,l+1),auxvec(1))
10655               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10656             endif
10657             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10658      &        pizda(1,1))
10659             vv(1)=pizda(1,1)-pizda(2,2)
10660             vv(2)=pizda(2,1)+pizda(1,2)
10661             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10662             if (swap) then
10663               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10664 #ifdef MOMENT
10665                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10666      &             -(s1+s2+s4)
10667 #else
10668                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10669      &             -(s2+s4)
10670 #endif
10671                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10672               else
10673 #ifdef MOMENT
10674                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10675 #else
10676                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10677 #endif
10678                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10679               endif
10680             else
10681 #ifdef MOMENT
10682               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10683 #else
10684               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10685 #endif
10686               if (l.eq.j+1) then
10687                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10688               else
10689                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10690               endif
10691             endif
10692           enddo
10693         enddo
10694       enddo
10695       return
10696       end
10697 c----------------------------------------------------------------------------
10698       double precision function eello_turn6(i,jj,kk)
10699       implicit real*8 (a-h,o-z)
10700       include 'DIMENSIONS'
10701       include 'COMMON.IOUNITS'
10702       include 'COMMON.CHAIN'
10703       include 'COMMON.DERIV'
10704       include 'COMMON.INTERACT'
10705       include 'COMMON.CONTACTS'
10706       include 'COMMON.TORSION'
10707       include 'COMMON.VAR'
10708       include 'COMMON.GEO'
10709       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10710      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10711      &  ggg1(3),ggg2(3)
10712       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10713      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10714 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10715 C           the respective energy moment and not to the cluster cumulant.
10716       s1=0.0d0
10717       s8=0.0d0
10718       s13=0.0d0
10719 c
10720       eello_turn6=0.0d0
10721       j=i+4
10722       k=i+1
10723       l=i+3
10724       iti=itype2loc(itype(i))
10725       itk=itype2loc(itype(k))
10726       itk1=itype2loc(itype(k+1))
10727       itl=itype2loc(itype(l))
10728       itj=itype2loc(itype(j))
10729 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10730 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10731 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10732 cd        eello6=0.0d0
10733 cd        return
10734 cd      endif
10735 cd      write (iout,*)
10736 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10737 cd     &   ' and',k,l
10738 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10739       do iii=1,2
10740         do kkk=1,5
10741           do lll=1,3
10742             derx_turn(lll,kkk,iii)=0.0d0
10743           enddo
10744         enddo
10745       enddo
10746 cd      eij=1.0d0
10747 cd      ekl=1.0d0
10748 cd      ekont=1.0d0
10749       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10750 cd      eello6_5=0.0d0
10751 cd      write (2,*) 'eello6_5',eello6_5
10752 #ifdef MOMENT
10753       call transpose2(AEA(1,1,1),auxmat(1,1))
10754       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10755       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10756       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10757 #endif
10758       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10759       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10760       s2 = scalar2(b1(1,k),vtemp1(1))
10761 #ifdef MOMENT
10762       call transpose2(AEA(1,1,2),atemp(1,1))
10763       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10764       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10765       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10766 #endif
10767       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10768       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10769       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10770 #ifdef MOMENT
10771       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10772       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10773       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10774       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10775       ss13 = scalar2(b1(1,k),vtemp4(1))
10776       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10777 #endif
10778 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10779 c      s1=0.0d0
10780 c      s2=0.0d0
10781 c      s8=0.0d0
10782 c      s12=0.0d0
10783 c      s13=0.0d0
10784       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10785 C Derivatives in gamma(i+2)
10786       s1d =0.0d0
10787       s8d =0.0d0
10788 #ifdef MOMENT
10789       call transpose2(AEA(1,1,1),auxmatd(1,1))
10790       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10791       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10792       call transpose2(AEAderg(1,1,2),atempd(1,1))
10793       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10794       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10795 #endif
10796       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10797       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10798       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10799 c      s1d=0.0d0
10800 c      s2d=0.0d0
10801 c      s8d=0.0d0
10802 c      s12d=0.0d0
10803 c      s13d=0.0d0
10804       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10805 C Derivatives in gamma(i+3)
10806 #ifdef MOMENT
10807       call transpose2(AEA(1,1,1),auxmatd(1,1))
10808       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10809       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10810       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10811 #endif
10812       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10813       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10814       s2d = scalar2(b1(1,k),vtemp1d(1))
10815 #ifdef MOMENT
10816       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10817       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10818 #endif
10819       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10820 #ifdef MOMENT
10821       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10822       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10823       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10824 #endif
10825 c      s1d=0.0d0
10826 c      s2d=0.0d0
10827 c      s8d=0.0d0
10828 c      s12d=0.0d0
10829 c      s13d=0.0d0
10830 #ifdef MOMENT
10831       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10832      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10833 #else
10834       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10835      &               -0.5d0*ekont*(s2d+s12d)
10836 #endif
10837 C Derivatives in gamma(i+4)
10838       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10839       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10840       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10841 #ifdef MOMENT
10842       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10843       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10844       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10845 #endif
10846 c      s1d=0.0d0
10847 c      s2d=0.0d0
10848 c      s8d=0.0d0
10849 C      s12d=0.0d0
10850 c      s13d=0.0d0
10851 #ifdef MOMENT
10852       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10853 #else
10854       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10855 #endif
10856 C Derivatives in gamma(i+5)
10857 #ifdef MOMENT
10858       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10859       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10860       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10861 #endif
10862       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10863       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10864       s2d = scalar2(b1(1,k),vtemp1d(1))
10865 #ifdef MOMENT
10866       call transpose2(AEA(1,1,2),atempd(1,1))
10867       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10868       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10869 #endif
10870       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10871       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10872 #ifdef MOMENT
10873       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10874       ss13d = scalar2(b1(1,k),vtemp4d(1))
10875       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10876 #endif
10877 c      s1d=0.0d0
10878 c      s2d=0.0d0
10879 c      s8d=0.0d0
10880 c      s12d=0.0d0
10881 c      s13d=0.0d0
10882 #ifdef MOMENT
10883       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10884      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10885 #else
10886       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10887      &               -0.5d0*ekont*(s2d+s12d)
10888 #endif
10889 C Cartesian derivatives
10890       do iii=1,2
10891         do kkk=1,5
10892           do lll=1,3
10893 #ifdef MOMENT
10894             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10895             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10896             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10897 #endif
10898             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10899             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10900      &          vtemp1d(1))
10901             s2d = scalar2(b1(1,k),vtemp1d(1))
10902 #ifdef MOMENT
10903             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10904             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10905             s8d = -(atempd(1,1)+atempd(2,2))*
10906      &           scalar2(cc(1,1,itl),vtemp2(1))
10907 #endif
10908             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10909      &           auxmatd(1,1))
10910             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10911             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10912 c      s1d=0.0d0
10913 c      s2d=0.0d0
10914 c      s8d=0.0d0
10915 c      s12d=0.0d0
10916 c      s13d=0.0d0
10917 #ifdef MOMENT
10918             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10919      &        - 0.5d0*(s1d+s2d)
10920 #else
10921             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10922      &        - 0.5d0*s2d
10923 #endif
10924 #ifdef MOMENT
10925             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10926      &        - 0.5d0*(s8d+s12d)
10927 #else
10928             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10929      &        - 0.5d0*s12d
10930 #endif
10931           enddo
10932         enddo
10933       enddo
10934 #ifdef MOMENT
10935       do kkk=1,5
10936         do lll=1,3
10937           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10938      &      achuj_tempd(1,1))
10939           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10940           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10941           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10942           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10943           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10944      &      vtemp4d(1))
10945           ss13d = scalar2(b1(1,k),vtemp4d(1))
10946           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10947           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10948         enddo
10949       enddo
10950 #endif
10951 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10952 cd     &  16*eel_turn6_num
10953 cd      goto 1112
10954       if (j.lt.nres-1) then
10955         j1=j+1
10956         j2=j-1
10957       else
10958         j1=j-1
10959         j2=j-2
10960       endif
10961       if (l.lt.nres-1) then
10962         l1=l+1
10963         l2=l-1
10964       else
10965         l1=l-1
10966         l2=l-2
10967       endif
10968       do ll=1,3
10969 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10970 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10971 cgrad        ghalf=0.5d0*ggg1(ll)
10972 cd        ghalf=0.0d0
10973         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10974         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10975         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10976      &    +ekont*derx_turn(ll,2,1)
10977         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10978         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10979      &    +ekont*derx_turn(ll,4,1)
10980         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10981         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10982         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10983 cgrad        ghalf=0.5d0*ggg2(ll)
10984 cd        ghalf=0.0d0
10985         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10986      &    +ekont*derx_turn(ll,2,2)
10987         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10988         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10989      &    +ekont*derx_turn(ll,4,2)
10990         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10991         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10992         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10993       enddo
10994 cd      goto 1112
10995 cgrad      do m=i+1,j-1
10996 cgrad        do ll=1,3
10997 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10998 cgrad        enddo
10999 cgrad      enddo
11000 cgrad      do m=k+1,l-1
11001 cgrad        do ll=1,3
11002 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11003 cgrad        enddo
11004 cgrad      enddo
11005 cgrad1112  continue
11006 cgrad      do m=i+2,j2
11007 cgrad        do ll=1,3
11008 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11009 cgrad        enddo
11010 cgrad      enddo
11011 cgrad      do m=k+2,l2
11012 cgrad        do ll=1,3
11013 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11014 cgrad        enddo
11015 cgrad      enddo
11016 cd      do iii=1,nres-3
11017 cd        write (2,*) iii,g_corr6_loc(iii)
11018 cd      enddo
11019       eello_turn6=ekont*eel_turn6
11020 cd      write (2,*) 'ekont',ekont
11021 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11022       return
11023       end
11024
11025 C-----------------------------------------------------------------------------
11026       double precision function scalar(u,v)
11027 !DIR$ INLINEALWAYS scalar
11028 #ifndef OSF
11029 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11030 #endif
11031       implicit none
11032       double precision u(3),v(3)
11033 cd      double precision sc
11034 cd      integer i
11035 cd      sc=0.0d0
11036 cd      do i=1,3
11037 cd        sc=sc+u(i)*v(i)
11038 cd      enddo
11039 cd      scalar=sc
11040
11041       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11042       return
11043       end
11044 crc-------------------------------------------------
11045       SUBROUTINE MATVEC2(A1,V1,V2)
11046 !DIR$ INLINEALWAYS MATVEC2
11047 #ifndef OSF
11048 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11049 #endif
11050       implicit real*8 (a-h,o-z)
11051       include 'DIMENSIONS'
11052       DIMENSION A1(2,2),V1(2),V2(2)
11053 c      DO 1 I=1,2
11054 c        VI=0.0
11055 c        DO 3 K=1,2
11056 c    3     VI=VI+A1(I,K)*V1(K)
11057 c        Vaux(I)=VI
11058 c    1 CONTINUE
11059
11060       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11061       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11062
11063       v2(1)=vaux1
11064       v2(2)=vaux2
11065       END
11066 C---------------------------------------
11067       SUBROUTINE MATMAT2(A1,A2,A3)
11068 #ifndef OSF
11069 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11070 #endif
11071       implicit real*8 (a-h,o-z)
11072       include 'DIMENSIONS'
11073       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11074 c      DIMENSION AI3(2,2)
11075 c        DO  J=1,2
11076 c          A3IJ=0.0
11077 c          DO K=1,2
11078 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11079 c          enddo
11080 c          A3(I,J)=A3IJ
11081 c       enddo
11082 c      enddo
11083
11084       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11085       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11086       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11087       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11088
11089       A3(1,1)=AI3_11
11090       A3(2,1)=AI3_21
11091       A3(1,2)=AI3_12
11092       A3(2,2)=AI3_22
11093       END
11094
11095 c-------------------------------------------------------------------------
11096       double precision function scalar2(u,v)
11097 !DIR$ INLINEALWAYS scalar2
11098       implicit none
11099       double precision u(2),v(2)
11100       double precision sc
11101       integer i
11102       scalar2=u(1)*v(1)+u(2)*v(2)
11103       return
11104       end
11105
11106 C-----------------------------------------------------------------------------
11107
11108       subroutine transpose2(a,at)
11109 !DIR$ INLINEALWAYS transpose2
11110 #ifndef OSF
11111 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11112 #endif
11113       implicit none
11114       double precision a(2,2),at(2,2)
11115       at(1,1)=a(1,1)
11116       at(1,2)=a(2,1)
11117       at(2,1)=a(1,2)
11118       at(2,2)=a(2,2)
11119       return
11120       end
11121 c--------------------------------------------------------------------------
11122       subroutine transpose(n,a,at)
11123       implicit none
11124       integer n,i,j
11125       double precision a(n,n),at(n,n)
11126       do i=1,n
11127         do j=1,n
11128           at(j,i)=a(i,j)
11129         enddo
11130       enddo
11131       return
11132       end
11133 C---------------------------------------------------------------------------
11134       subroutine prodmat3(a1,a2,kk,transp,prod)
11135 !DIR$ INLINEALWAYS prodmat3
11136 #ifndef OSF
11137 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11138 #endif
11139       implicit none
11140       integer i,j
11141       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11142       logical transp
11143 crc      double precision auxmat(2,2),prod_(2,2)
11144
11145       if (transp) then
11146 crc        call transpose2(kk(1,1),auxmat(1,1))
11147 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11148 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11149
11150            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11151      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11152            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11153      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11154            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11155      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11156            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11157      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11158
11159       else
11160 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11161 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11162
11163            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11164      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11165            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11166      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11167            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11168      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11169            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11170      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11171
11172       endif
11173 c      call transpose2(a2(1,1),a2t(1,1))
11174
11175 crc      print *,transp
11176 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11177 crc      print *,((prod(i,j),i=1,2),j=1,2)
11178
11179       return
11180       end
11181 CCC----------------------------------------------
11182       subroutine Eliptransfer(eliptran)
11183       implicit real*8 (a-h,o-z)
11184       include 'DIMENSIONS'
11185       include 'COMMON.GEO'
11186       include 'COMMON.VAR'
11187       include 'COMMON.LOCAL'
11188       include 'COMMON.CHAIN'
11189       include 'COMMON.DERIV'
11190       include 'COMMON.NAMES'
11191       include 'COMMON.INTERACT'
11192       include 'COMMON.IOUNITS'
11193       include 'COMMON.CALC'
11194       include 'COMMON.CONTROL'
11195       include 'COMMON.SPLITELE'
11196       include 'COMMON.SBRIDGE'
11197 C this is done by Adasko
11198 C      print *,"wchodze"
11199 C structure of box:
11200 C      water
11201 C--bordliptop-- buffore starts
11202 C--bufliptop--- here true lipid starts
11203 C      lipid
11204 C--buflipbot--- lipid ends buffore starts
11205 C--bordlipbot--buffore ends
11206       eliptran=0.0
11207       do i=ilip_start,ilip_end
11208 C       do i=1,1
11209         if (itype(i).eq.ntyp1) cycle
11210
11211         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11212         if (positi.le.0.0) positi=positi+boxzsize
11213 C        print *,i
11214 C first for peptide groups
11215 c for each residue check if it is in lipid or lipid water border area
11216        if ((positi.gt.bordlipbot)
11217      &.and.(positi.lt.bordliptop)) then
11218 C the energy transfer exist
11219         if (positi.lt.buflipbot) then
11220 C what fraction I am in
11221          fracinbuf=1.0d0-
11222      &        ((positi-bordlipbot)/lipbufthick)
11223 C lipbufthick is thickenes of lipid buffore
11224          sslip=sscalelip(fracinbuf)
11225          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11226          eliptran=eliptran+sslip*pepliptran
11227          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11228          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11229 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11230
11231 C        print *,"doing sccale for lower part"
11232 C         print *,i,sslip,fracinbuf,ssgradlip
11233         elseif (positi.gt.bufliptop) then
11234          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11235          sslip=sscalelip(fracinbuf)
11236          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11237          eliptran=eliptran+sslip*pepliptran
11238          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11239          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11240 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11241 C          print *, "doing sscalefor top part"
11242 C         print *,i,sslip,fracinbuf,ssgradlip
11243         else
11244          eliptran=eliptran+pepliptran
11245 C         print *,"I am in true lipid"
11246         endif
11247 C       else
11248 C       eliptran=elpitran+0.0 ! I am in water
11249        endif
11250        enddo
11251 C       print *, "nic nie bylo w lipidzie?"
11252 C now multiply all by the peptide group transfer factor
11253 C       eliptran=eliptran*pepliptran
11254 C now the same for side chains
11255 CV       do i=1,1
11256        do i=ilip_start,ilip_end
11257         if (itype(i).eq.ntyp1) cycle
11258         positi=(mod(c(3,i+nres),boxzsize))
11259         if (positi.le.0) positi=positi+boxzsize
11260 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11261 c for each residue check if it is in lipid or lipid water border area
11262 C       respos=mod(c(3,i+nres),boxzsize)
11263 C       print *,positi,bordlipbot,buflipbot
11264        if ((positi.gt.bordlipbot)
11265      & .and.(positi.lt.bordliptop)) then
11266 C the energy transfer exist
11267         if (positi.lt.buflipbot) then
11268          fracinbuf=1.0d0-
11269      &     ((positi-bordlipbot)/lipbufthick)
11270 C lipbufthick is thickenes of lipid buffore
11271          sslip=sscalelip(fracinbuf)
11272          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11273          eliptran=eliptran+sslip*liptranene(itype(i))
11274          gliptranx(3,i)=gliptranx(3,i)
11275      &+ssgradlip*liptranene(itype(i))
11276          gliptranc(3,i-1)= gliptranc(3,i-1)
11277      &+ssgradlip*liptranene(itype(i))
11278 C         print *,"doing sccale for lower part"
11279         elseif (positi.gt.bufliptop) then
11280          fracinbuf=1.0d0-
11281      &((bordliptop-positi)/lipbufthick)
11282          sslip=sscalelip(fracinbuf)
11283          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11284          eliptran=eliptran+sslip*liptranene(itype(i))
11285          gliptranx(3,i)=gliptranx(3,i)
11286      &+ssgradlip*liptranene(itype(i))
11287          gliptranc(3,i-1)= gliptranc(3,i-1)
11288      &+ssgradlip*liptranene(itype(i))
11289 C          print *, "doing sscalefor top part",sslip,fracinbuf
11290         else
11291          eliptran=eliptran+liptranene(itype(i))
11292 C         print *,"I am in true lipid"
11293         endif
11294         endif ! if in lipid or buffor
11295 C       else
11296 C       eliptran=elpitran+0.0 ! I am in water
11297        enddo
11298        return
11299        end
11300 C---------------------------------------------------------
11301 C AFM soubroutine for constant force
11302        subroutine AFMforce(Eafmforce)
11303        implicit real*8 (a-h,o-z)
11304       include 'DIMENSIONS'
11305       include 'COMMON.GEO'
11306       include 'COMMON.VAR'
11307       include 'COMMON.LOCAL'
11308       include 'COMMON.CHAIN'
11309       include 'COMMON.DERIV'
11310       include 'COMMON.NAMES'
11311       include 'COMMON.INTERACT'
11312       include 'COMMON.IOUNITS'
11313       include 'COMMON.CALC'
11314       include 'COMMON.CONTROL'
11315       include 'COMMON.SPLITELE'
11316       include 'COMMON.SBRIDGE'
11317       real*8 diffafm(3)
11318       dist=0.0d0
11319       Eafmforce=0.0d0
11320       do i=1,3
11321       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11322       dist=dist+diffafm(i)**2
11323       enddo
11324       dist=dsqrt(dist)
11325       Eafmforce=-forceAFMconst*(dist-distafminit)
11326       do i=1,3
11327       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11328       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11329       enddo
11330 C      print *,'AFM',Eafmforce
11331       return
11332       end
11333 C---------------------------------------------------------
11334 C AFM subroutine with pseudoconstant velocity
11335        subroutine AFMvel(Eafmforce)
11336        implicit real*8 (a-h,o-z)
11337       include 'DIMENSIONS'
11338       include 'COMMON.GEO'
11339       include 'COMMON.VAR'
11340       include 'COMMON.LOCAL'
11341       include 'COMMON.CHAIN'
11342       include 'COMMON.DERIV'
11343       include 'COMMON.NAMES'
11344       include 'COMMON.INTERACT'
11345       include 'COMMON.IOUNITS'
11346       include 'COMMON.CALC'
11347       include 'COMMON.CONTROL'
11348       include 'COMMON.SPLITELE'
11349       include 'COMMON.SBRIDGE'
11350       real*8 diffafm(3)
11351 C Only for check grad COMMENT if not used for checkgrad
11352 C      totT=3.0d0
11353 C--------------------------------------------------------
11354 C      print *,"wchodze"
11355       dist=0.0d0
11356       Eafmforce=0.0d0
11357       do i=1,3
11358       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11359       dist=dist+diffafm(i)**2
11360       enddo
11361       dist=dsqrt(dist)
11362       Eafmforce=0.5d0*forceAFMconst
11363      & *(distafminit+totTafm*velAFMconst-dist)**2
11364 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11365       do i=1,3
11366       gradafm(i,afmend-1)=-forceAFMconst*
11367      &(distafminit+totTafm*velAFMconst-dist)
11368      &*diffafm(i)/dist
11369       gradafm(i,afmbeg-1)=forceAFMconst*
11370      &(distafminit+totTafm*velAFMconst-dist)
11371      &*diffafm(i)/dist
11372       enddo
11373 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11374       return
11375       end
11376 C-----------------------------------------------------------
11377 C first for shielding is setting of function of side-chains
11378        subroutine set_shield_fac
11379       implicit real*8 (a-h,o-z)
11380       include 'DIMENSIONS'
11381       include 'COMMON.CHAIN'
11382       include 'COMMON.DERIV'
11383       include 'COMMON.IOUNITS'
11384       include 'COMMON.SHIELD'
11385       include 'COMMON.INTERACT'
11386 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11387       double precision div77_81/0.974996043d0/,
11388      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11389
11390 C the vector between center of side_chain and peptide group
11391        double precision pep_side(3),long,side_calf(3),
11392      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11393      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11394 C the line belowe needs to be changed for FGPROC>1
11395       do i=1,nres-1
11396       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11397       ishield_list(i)=0
11398 Cif there two consequtive dummy atoms there is no peptide group between them
11399 C the line below has to be changed for FGPROC>1
11400       VolumeTotal=0.0
11401       do k=1,nres
11402        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11403        dist_pep_side=0.0
11404        dist_side_calf=0.0
11405        do j=1,3
11406 C first lets set vector conecting the ithe side-chain with kth side-chain
11407       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11408 C      pep_side(j)=2.0d0
11409 C and vector conecting the side-chain with its proper calfa
11410       side_calf(j)=c(j,k+nres)-c(j,k)
11411 C      side_calf(j)=2.0d0
11412       pept_group(j)=c(j,i)-c(j,i+1)
11413 C lets have their lenght
11414       dist_pep_side=pep_side(j)**2+dist_pep_side
11415       dist_side_calf=dist_side_calf+side_calf(j)**2
11416       dist_pept_group=dist_pept_group+pept_group(j)**2
11417       enddo
11418        dist_pep_side=dsqrt(dist_pep_side)
11419        dist_pept_group=dsqrt(dist_pept_group)
11420        dist_side_calf=dsqrt(dist_side_calf)
11421       do j=1,3
11422         pep_side_norm(j)=pep_side(j)/dist_pep_side
11423         side_calf_norm(j)=dist_side_calf
11424       enddo
11425 C now sscale fraction
11426        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11427 C       print *,buff_shield,"buff"
11428 C now sscale
11429         if (sh_frac_dist.le.0.0) cycle
11430 C If we reach here it means that this side chain reaches the shielding sphere
11431 C Lets add him to the list for gradient
11432         ishield_list(i)=ishield_list(i)+1
11433 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11434 C this list is essential otherwise problem would be O3
11435         shield_list(ishield_list(i),i)=k
11436 C Lets have the sscale value
11437         if (sh_frac_dist.gt.1.0) then
11438          scale_fac_dist=1.0d0
11439          do j=1,3
11440          sh_frac_dist_grad(j)=0.0d0
11441          enddo
11442         else
11443          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11444      &                   *(2.0*sh_frac_dist-3.0d0)
11445          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11446      &                  /dist_pep_side/buff_shield*0.5
11447 C remember for the final gradient multiply sh_frac_dist_grad(j)
11448 C for side_chain by factor -2 !
11449          do j=1,3
11450          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11451 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11452 C     &                    sh_frac_dist_grad(j)
11453          enddo
11454         endif
11455 C        if ((i.eq.3).and.(k.eq.2)) then
11456 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11457 C     & ,"TU"
11458 C        endif
11459
11460 C this is what is now we have the distance scaling now volume...
11461       short=short_r_sidechain(itype(k))
11462       long=long_r_sidechain(itype(k))
11463       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11464 C now costhet_grad
11465 C       costhet=0.0d0
11466        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11467 C       costhet_fac=0.0d0
11468        do j=1,3
11469          costhet_grad(j)=costhet_fac*pep_side(j)
11470        enddo
11471 C remember for the final gradient multiply costhet_grad(j)
11472 C for side_chain by factor -2 !
11473 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11474 C pep_side0pept_group is vector multiplication
11475       pep_side0pept_group=0.0
11476       do j=1,3
11477       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11478       enddo
11479       cosalfa=(pep_side0pept_group/
11480      & (dist_pep_side*dist_side_calf))
11481       fac_alfa_sin=1.0-cosalfa**2
11482       fac_alfa_sin=dsqrt(fac_alfa_sin)
11483       rkprim=fac_alfa_sin*(long-short)+short
11484 C now costhet_grad
11485        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11486        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11487
11488        do j=1,3
11489          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11490      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11491      &*(long-short)/fac_alfa_sin*cosalfa/
11492      &((dist_pep_side*dist_side_calf))*
11493      &((side_calf(j))-cosalfa*
11494      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11495
11496         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11497      &*(long-short)/fac_alfa_sin*cosalfa
11498      &/((dist_pep_side*dist_side_calf))*
11499      &(pep_side(j)-
11500      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11501        enddo
11502
11503       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11504      &                    /VSolvSphere_div
11505      &                    *wshield
11506 C now the gradient...
11507 C grad_shield is gradient of Calfa for peptide groups
11508 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11509 C     &               costhet,cosphi
11510 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11511 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11512       do j=1,3
11513       grad_shield(j,i)=grad_shield(j,i)
11514 C gradient po skalowaniu
11515      &                +(sh_frac_dist_grad(j)
11516 C  gradient po costhet
11517      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11518      &-scale_fac_dist*(cosphi_grad_long(j))
11519      &/(1.0-cosphi) )*div77_81
11520      &*VofOverlap
11521 C grad_shield_side is Cbeta sidechain gradient
11522       grad_shield_side(j,ishield_list(i),i)=
11523      &        (sh_frac_dist_grad(j)*-2.0d0
11524      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11525      &       +scale_fac_dist*(cosphi_grad_long(j))
11526      &        *2.0d0/(1.0-cosphi))
11527      &        *div77_81*VofOverlap
11528
11529        grad_shield_loc(j,ishield_list(i),i)=
11530      &   scale_fac_dist*cosphi_grad_loc(j)
11531      &        *2.0d0/(1.0-cosphi)
11532      &        *div77_81*VofOverlap
11533       enddo
11534       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11535       enddo
11536       fac_shield(i)=VolumeTotal*div77_81+div4_81
11537 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11538       enddo
11539       return
11540       end
11541 C--------------------------------------------------------------------------
11542       double precision function tschebyshev(m,n,x,y)
11543       implicit none
11544       include "DIMENSIONS"
11545       integer i,m,n
11546       double precision x(n),y,yy(0:maxvar),aux
11547 c Tschebyshev polynomial. Note that the first term is omitted
11548 c m=0: the constant term is included
11549 c m=1: the constant term is not included
11550       yy(0)=1.0d0
11551       yy(1)=y
11552       do i=2,n
11553         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11554       enddo
11555       aux=0.0d0
11556       do i=m,n
11557         aux=aux+x(i)*yy(i)
11558       enddo
11559       tschebyshev=aux
11560       return
11561       end
11562 C--------------------------------------------------------------------------
11563       double precision function gradtschebyshev(m,n,x,y)
11564       implicit none
11565       include "DIMENSIONS"
11566       integer i,m,n
11567       double precision x(n+1),y,yy(0:maxvar),aux
11568 c Tschebyshev polynomial. Note that the first term is omitted
11569 c m=0: the constant term is included
11570 c m=1: the constant term is not included
11571       yy(0)=1.0d0
11572       yy(1)=2.0d0*y
11573       do i=2,n
11574         yy(i)=2*y*yy(i-1)-yy(i-2)
11575       enddo
11576       aux=0.0d0
11577       do i=m,n
11578         aux=aux+x(i+1)*yy(i)*(i+1)
11579 C        print *, x(i+1),yy(i),i
11580       enddo
11581       gradtschebyshev=aux
11582       return
11583       end
11584 C------------------------------------------------------------------------
11585 C first for shielding is setting of function of side-chains
11586        subroutine set_shield_fac2
11587       implicit real*8 (a-h,o-z)
11588       include 'DIMENSIONS'
11589       include 'COMMON.CHAIN'
11590       include 'COMMON.DERIV'
11591       include 'COMMON.IOUNITS'
11592       include 'COMMON.SHIELD'
11593       include 'COMMON.INTERACT'
11594       include 'COMMON.LOCAL'
11595
11596 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11597       double precision div77_81/0.974996043d0/,
11598      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11599
11600 C the vector between center of side_chain and peptide group
11601        double precision pep_side(3),long,side_calf(3),
11602      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11603      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11604 C      write(2,*) "ivec",ivec_start,ivec_end
11605       do i=1,nres
11606         fac_shield(i)=0.0d0
11607         do j=1,3
11608         grad_shield(j,i)=0.0d0
11609         enddo
11610       enddo
11611 C the line belowe needs to be changed for FGPROC>1
11612       do i=ivec_start,ivec_end
11613 C      do i=1,nres-1
11614 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11615       ishield_list(i)=0
11616       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11617 Cif there two consequtive dummy atoms there is no peptide group between them
11618 C the line below has to be changed for FGPROC>1
11619       VolumeTotal=0.0
11620       do k=1,nres
11621        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11622        dist_pep_side=0.0
11623        dist_side_calf=0.0
11624        do j=1,3
11625 C first lets set vector conecting the ithe side-chain with kth side-chain
11626       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11627 C      pep_side(j)=2.0d0
11628 C and vector conecting the side-chain with its proper calfa
11629       side_calf(j)=c(j,k+nres)-c(j,k)
11630 C      side_calf(j)=2.0d0
11631       pept_group(j)=c(j,i)-c(j,i+1)
11632 C lets have their lenght
11633       dist_pep_side=pep_side(j)**2+dist_pep_side
11634       dist_side_calf=dist_side_calf+side_calf(j)**2
11635       dist_pept_group=dist_pept_group+pept_group(j)**2
11636       enddo
11637        dist_pep_side=dsqrt(dist_pep_side)
11638        dist_pept_group=dsqrt(dist_pept_group)
11639        dist_side_calf=dsqrt(dist_side_calf)
11640       do j=1,3
11641         pep_side_norm(j)=pep_side(j)/dist_pep_side
11642         side_calf_norm(j)=dist_side_calf
11643       enddo
11644 C now sscale fraction
11645        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11646 C       print *,buff_shield,"buff"
11647 C now sscale
11648         if (sh_frac_dist.le.0.0) cycle
11649 C        print *,ishield_list(i),i
11650 C If we reach here it means that this side chain reaches the shielding sphere
11651 C Lets add him to the list for gradient
11652         ishield_list(i)=ishield_list(i)+1
11653 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11654 C this list is essential otherwise problem would be O3
11655         shield_list(ishield_list(i),i)=k
11656 C Lets have the sscale value
11657         if (sh_frac_dist.gt.1.0) then
11658          scale_fac_dist=1.0d0
11659          do j=1,3
11660          sh_frac_dist_grad(j)=0.0d0
11661          enddo
11662         else
11663          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11664      &                   *(2.0d0*sh_frac_dist-3.0d0)
11665          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11666      &                  /dist_pep_side/buff_shield*0.5d0
11667 C remember for the final gradient multiply sh_frac_dist_grad(j)
11668 C for side_chain by factor -2 !
11669          do j=1,3
11670          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11671 C         sh_frac_dist_grad(j)=0.0d0
11672 C         scale_fac_dist=1.0d0
11673 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11674 C     &                    sh_frac_dist_grad(j)
11675          enddo
11676         endif
11677 C this is what is now we have the distance scaling now volume...
11678       short=short_r_sidechain(itype(k))
11679       long=long_r_sidechain(itype(k))
11680       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11681       sinthet=short/dist_pep_side*costhet
11682 C now costhet_grad
11683 C       costhet=0.6d0
11684 C       sinthet=0.8
11685        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11686 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11687 C     &             -short/dist_pep_side**2/costhet)
11688 C       costhet_fac=0.0d0
11689        do j=1,3
11690          costhet_grad(j)=costhet_fac*pep_side(j)
11691        enddo
11692 C remember for the final gradient multiply costhet_grad(j)
11693 C for side_chain by factor -2 !
11694 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11695 C pep_side0pept_group is vector multiplication
11696       pep_side0pept_group=0.0d0
11697       do j=1,3
11698       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11699       enddo
11700       cosalfa=(pep_side0pept_group/
11701      & (dist_pep_side*dist_side_calf))
11702       fac_alfa_sin=1.0d0-cosalfa**2
11703       fac_alfa_sin=dsqrt(fac_alfa_sin)
11704       rkprim=fac_alfa_sin*(long-short)+short
11705 C      rkprim=short
11706
11707 C now costhet_grad
11708        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11709 C       cosphi=0.6
11710        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11711        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11712      &      dist_pep_side**2)
11713 C       sinphi=0.8
11714        do j=1,3
11715          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11716      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11717      &*(long-short)/fac_alfa_sin*cosalfa/
11718      &((dist_pep_side*dist_side_calf))*
11719      &((side_calf(j))-cosalfa*
11720      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11721 C       cosphi_grad_long(j)=0.0d0
11722         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11723      &*(long-short)/fac_alfa_sin*cosalfa
11724      &/((dist_pep_side*dist_side_calf))*
11725      &(pep_side(j)-
11726      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11727 C       cosphi_grad_loc(j)=0.0d0
11728        enddo
11729 C      print *,sinphi,sinthet
11730       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11731      &                    /VSolvSphere_div
11732 C     &                    *wshield
11733 C now the gradient...
11734       do j=1,3
11735       grad_shield(j,i)=grad_shield(j,i)
11736 C gradient po skalowaniu
11737      &                +(sh_frac_dist_grad(j)*VofOverlap
11738 C  gradient po costhet
11739      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11740      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11741      &       sinphi/sinthet*costhet*costhet_grad(j)
11742      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11743      & )*wshield
11744 C grad_shield_side is Cbeta sidechain gradient
11745       grad_shield_side(j,ishield_list(i),i)=
11746      &        (sh_frac_dist_grad(j)*-2.0d0
11747      &        *VofOverlap
11748      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11749      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11750      &       sinphi/sinthet*costhet*costhet_grad(j)
11751      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11752      &       )*wshield
11753
11754        grad_shield_loc(j,ishield_list(i),i)=
11755      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11756      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11757      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11758      &        ))
11759      &        *wshield
11760       enddo
11761       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11762       enddo
11763       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11764 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
11765       enddo
11766       return
11767       end
11768 C-----------------------------------------------------------------------
11769 C-----------------------------------------------------------
11770 C This subroutine is to mimic the histone like structure but as well can be
11771 C utilizet to nanostructures (infinit) small modification has to be used to
11772 C make it finite (z gradient at the ends has to be changes as well as the x,y
11773 C gradient has to be modified at the ends
11774 C The energy function is Kihara potential
11775 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11776 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11777 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11778 C simple Kihara potential
11779       subroutine calctube(Etube)
11780        implicit real*8 (a-h,o-z)
11781       include 'DIMENSIONS'
11782       include 'COMMON.GEO'
11783       include 'COMMON.VAR'
11784       include 'COMMON.LOCAL'
11785       include 'COMMON.CHAIN'
11786       include 'COMMON.DERIV'
11787       include 'COMMON.NAMES'
11788       include 'COMMON.INTERACT'
11789       include 'COMMON.IOUNITS'
11790       include 'COMMON.CALC'
11791       include 'COMMON.CONTROL'
11792       include 'COMMON.SPLITELE'
11793       include 'COMMON.SBRIDGE'
11794       double precision tub_r,vectube(3),enetube(maxres*2)
11795       Etube=0.0d0
11796       do i=1,2*nres
11797         enetube(i)=0.0d0
11798       enddo
11799 C first we calculate the distance from tube center
11800 C first sugare-phosphate group for NARES this would be peptide group
11801 C for UNRES
11802       do i=1,nres
11803 C lets ommit dummy atoms for now
11804        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11805 C now calculate distance from center of tube and direction vectors
11806       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11807           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11808       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
11809           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11810       vectube(1)=vectube(1)-tubecenter(1)
11811       vectube(2)=vectube(2)-tubecenter(2)
11812
11813 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11814 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11815
11816 C as the tube is infinity we do not calculate the Z-vector use of Z
11817 C as chosen axis
11818       vectube(3)=0.0d0
11819 C now calculte the distance
11820        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11821 C now normalize vector
11822       vectube(1)=vectube(1)/tub_r
11823       vectube(2)=vectube(2)/tub_r
11824 C calculte rdiffrence between r and r0
11825       rdiff=tub_r-tubeR0
11826 C and its 6 power
11827       rdiff6=rdiff**6.0d0
11828 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11829        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11830 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11831 C       print *,rdiff,rdiff6,pep_aa_tube
11832 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11833 C now we calculate gradient
11834        fac=(-12.0d0*pep_aa_tube/rdiff6+
11835      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11836 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11837 C     &rdiff,fac
11838
11839 C now direction of gg_tube vector
11840         do j=1,3
11841         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11842         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11843         enddo
11844         enddo
11845 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11846         do i=1,nres
11847 C Lets not jump over memory as we use many times iti
11848          iti=itype(i)
11849 C lets ommit dummy atoms for now
11850          if ((iti.eq.ntyp1)
11851 C in UNRES uncomment the line below as GLY has no side-chain...
11852 C      .or.(iti.eq.10)
11853      &   ) cycle
11854           vectube(1)=c(1,i+nres)
11855           vectube(1)=mod(vectube(1),boxxsize)
11856           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11857           vectube(2)=c(2,i+nres)
11858           vectube(2)=mod(vectube(2),boxysize)
11859           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11860
11861       vectube(1)=vectube(1)-tubecenter(1)
11862       vectube(2)=vectube(2)-tubecenter(2)
11863
11864 C as the tube is infinity we do not calculate the Z-vector use of Z
11865 C as chosen axis
11866       vectube(3)=0.0d0
11867 C now calculte the distance
11868        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11869 C now normalize vector
11870       vectube(1)=vectube(1)/tub_r
11871       vectube(2)=vectube(2)/tub_r
11872 C calculte rdiffrence between r and r0
11873       rdiff=tub_r-tubeR0
11874 C and its 6 power
11875       rdiff6=rdiff**6.0d0
11876 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11877        sc_aa_tube=sc_aa_tube_par(iti)
11878        sc_bb_tube=sc_bb_tube_par(iti)
11879        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11880 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11881 C now we calculate gradient
11882        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11883      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11884 C now direction of gg_tube vector
11885          do j=1,3
11886           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11887           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11888          enddo
11889         enddo
11890         do i=1,2*nres
11891           Etube=Etube+enetube(i)
11892         enddo
11893 C        print *,"ETUBE", etube
11894         return
11895         end
11896 C TO DO 1) add to total energy
11897 C       2) add to gradient summation
11898 C       3) add reading parameters (AND of course oppening of PARAM file)
11899 C       4) add reading the center of tube
11900 C       5) add COMMONs
11901 C       6) add to zerograd
11902
11903 C-----------------------------------------------------------------------
11904 C-----------------------------------------------------------
11905 C This subroutine is to mimic the histone like structure but as well can be
11906 C utilizet to nanostructures (infinit) small modification has to be used to
11907 C make it finite (z gradient at the ends has to be changes as well as the x,y
11908 C gradient has to be modified at the ends
11909 C The energy function is Kihara potential
11910 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11911 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11912 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11913 C simple Kihara potential
11914       subroutine calctube2(Etube)
11915        implicit real*8 (a-h,o-z)
11916       include 'DIMENSIONS'
11917       include 'COMMON.GEO'
11918       include 'COMMON.VAR'
11919       include 'COMMON.LOCAL'
11920       include 'COMMON.CHAIN'
11921       include 'COMMON.DERIV'
11922       include 'COMMON.NAMES'
11923       include 'COMMON.INTERACT'
11924       include 'COMMON.IOUNITS'
11925       include 'COMMON.CALC'
11926       include 'COMMON.CONTROL'
11927       include 'COMMON.SPLITELE'
11928       include 'COMMON.SBRIDGE'
11929       double precision tub_r,vectube(3),enetube(maxres*2)
11930       Etube=0.0d0
11931       do i=1,2*nres
11932         enetube(i)=0.0d0
11933       enddo
11934 C first we calculate the distance from tube center
11935 C first sugare-phosphate group for NARES this would be peptide group
11936 C for UNRES
11937       do i=1,nres
11938 C lets ommit dummy atoms for now
11939
11940        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11941 C now calculate distance from center of tube and direction vectors
11942       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11943           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11944       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
11945           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11946       vectube(1)=vectube(1)-tubecenter(1)
11947       vectube(2)=vectube(2)-tubecenter(2)
11948
11949 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11950 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11951
11952 C as the tube is infinity we do not calculate the Z-vector use of Z
11953 C as chosen axis
11954       vectube(3)=0.0d0
11955 C now calculte the distance
11956        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11957 C now normalize vector
11958       vectube(1)=vectube(1)/tub_r
11959       vectube(2)=vectube(2)/tub_r
11960 C calculte rdiffrence between r and r0
11961       rdiff=tub_r-tubeR0
11962 C and its 6 power
11963       rdiff6=rdiff**6.0d0
11964 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11965        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11966 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11967 C       print *,rdiff,rdiff6,pep_aa_tube
11968 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11969 C now we calculate gradient
11970        fac=(-12.0d0*pep_aa_tube/rdiff6+
11971      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11972 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11973 C     &rdiff,fac
11974
11975 C now direction of gg_tube vector
11976         do j=1,3
11977         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11978         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11979         enddo
11980         enddo
11981 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11982         do i=1,nres
11983 C Lets not jump over memory as we use many times iti
11984          iti=itype(i)
11985 C lets ommit dummy atoms for now
11986          if ((iti.eq.ntyp1)
11987 C in UNRES uncomment the line below as GLY has no side-chain...
11988      &      .or.(iti.eq.10)
11989      &   ) cycle
11990           vectube(1)=c(1,i+nres)
11991           vectube(1)=mod(vectube(1),boxxsize)
11992           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11993           vectube(2)=c(2,i+nres)
11994           vectube(2)=mod(vectube(2),boxysize)
11995           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11996
11997       vectube(1)=vectube(1)-tubecenter(1)
11998       vectube(2)=vectube(2)-tubecenter(2)
11999 C THIS FRAGMENT MAKES TUBE FINITE
12000         positi=(mod(c(3,i+nres),boxzsize))
12001         if (positi.le.0) positi=positi+boxzsize
12002 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12003 c for each residue check if it is in lipid or lipid water border area
12004 C       respos=mod(c(3,i+nres),boxzsize)
12005        print *,positi,bordtubebot,buftubebot,bordtubetop
12006        if ((positi.gt.bordtubebot)
12007      & .and.(positi.lt.bordtubetop)) then
12008 C the energy transfer exist
12009         if (positi.lt.buftubebot) then
12010          fracinbuf=1.0d0-
12011      &     ((positi-bordtubebot)/tubebufthick)
12012 C lipbufthick is thickenes of lipid buffore
12013          sstube=sscalelip(fracinbuf)
12014          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12015          print *,ssgradtube, sstube,tubetranene(itype(i))
12016          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12017 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12018 C     &+ssgradtube*tubetranene(itype(i))
12019 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12020 C     &+ssgradtube*tubetranene(itype(i))
12021 C         print *,"doing sccale for lower part"
12022         elseif (positi.gt.buftubetop) then
12023          fracinbuf=1.0d0-
12024      &((bordtubetop-positi)/tubebufthick)
12025          sstube=sscalelip(fracinbuf)
12026          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12027          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12028 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12029 C     &+ssgradtube*tubetranene(itype(i))
12030 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12031 C     &+ssgradtube*tubetranene(itype(i))
12032 C          print *, "doing sscalefor top part",sslip,fracinbuf
12033         else
12034          sstube=1.0d0
12035          ssgradtube=0.0d0
12036          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12037 C         print *,"I am in true lipid"
12038         endif
12039         else
12040 C          sstube=0.0d0
12041 C          ssgradtube=0.0d0
12042         cycle
12043         endif ! if in lipid or buffor
12044 CEND OF FINITE FRAGMENT
12045 C as the tube is infinity we do not calculate the Z-vector use of Z
12046 C as chosen axis
12047       vectube(3)=0.0d0
12048 C now calculte the distance
12049        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12050 C now normalize vector
12051       vectube(1)=vectube(1)/tub_r
12052       vectube(2)=vectube(2)/tub_r
12053 C calculte rdiffrence between r and r0
12054       rdiff=tub_r-tubeR0
12055 C and its 6 power
12056       rdiff6=rdiff**6.0d0
12057 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12058        sc_aa_tube=sc_aa_tube_par(iti)
12059        sc_bb_tube=sc_bb_tube_par(iti)
12060        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12061      &                 *sstube+enetube(i+nres)
12062 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12063 C now we calculate gradient
12064        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12065      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12066 C now direction of gg_tube vector
12067          do j=1,3
12068           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12069           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12070          enddo
12071          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12072      &+ssgradtube*enetube(i+nres)/sstube
12073          gg_tube(3,i-1)= gg_tube(3,i-1)
12074      &+ssgradtube*enetube(i+nres)/sstube
12075
12076         enddo
12077         do i=1,2*nres
12078           Etube=Etube+enetube(i)
12079         enddo
12080 C        print *,"ETUBE", etube
12081         return
12082         end
12083 C TO DO 1) add to total energy
12084 C       2) add to gradient summation
12085 C       3) add reading parameters (AND of course oppening of PARAM file)
12086 C       4) add reading the center of tube
12087 C       5) add COMMONs
12088 C       6) add to zerograd
12089