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 #ifdef DEBUG
 479         write (iout,*) "energies after REDUCE"
 480         call enerprint(energia)
 481         call flush(iout)
 482 #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       include 'COMMON.SHIELD'
3425       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3426      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3427       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3428      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3429       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3430      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3431      &    num_conti,j1,j2
3432 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3433 #ifdef MOMENT
3434       double precision scal_el /1.0d0/
3435 #else
3436       double precision scal_el /0.5d0/
3437 #endif
3438 C 12/13/98
3439 C 13-go grudnia roku pamietnego...
3440       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3441      &                   0.0d0,1.0d0,0.0d0,
3442      &                   0.0d0,0.0d0,1.0d0/
3443 cd      write(iout,*) 'In EELEC'
3444 cd      do i=1,nloctyp
3445 cd        write(iout,*) 'Type',i
3446 cd        write(iout,*) 'B1',B1(:,i)
3447 cd        write(iout,*) 'B2',B2(:,i)
3448 cd        write(iout,*) 'CC',CC(:,:,i)
3449 cd        write(iout,*) 'DD',DD(:,:,i)
3450 cd        write(iout,*) 'EE',EE(:,:,i)
3451 cd      enddo
3452 cd      call check_vecgrad
3453 cd      stop
3454       if (icheckgrad.eq.1) then
3455         do i=1,nres-1
3456           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3457           do k=1,3
3458             dc_norm(k,i)=dc(k,i)*fac
3459           enddo
3460 c          write (iout,*) 'i',i,' fac',fac
3461         enddo
3462       endif
3463       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3464      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3465      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3466 c        call vec_and_deriv
3467 #ifdef TIMING
3468         time01=MPI_Wtime()
3469 #endif
3470         call set_matrices
3471 #ifdef TIMING
3472         time_mat=time_mat+MPI_Wtime()-time01
3473 #endif
3474       endif
3475 cd      do i=1,nres-1
3476 cd        write (iout,*) 'i=',i
3477 cd        do k=1,3
3478 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3479 cd        enddo
3480 cd        do k=1,3
3481 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3482 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3483 cd        enddo
3484 cd      enddo
3485       t_eelecij=0.0d0
3486       ees=0.0D0
3487       evdw1=0.0D0
3488       eel_loc=0.0d0
3489       eello_turn3=0.0d0
3490       eello_turn4=0.0d0
3491       ind=0
3492       do i=1,nres
3493         num_cont_hb(i)=0
3494       enddo
3495 cd      print '(a)','Enter EELEC'
3496 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3497       do i=1,nres
3498         gel_loc_loc(i)=0.0d0
3499         gcorr_loc(i)=0.0d0
3500       enddo
3501 c
3502 c
3503 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3504 C
3505 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3506 C
3507 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3508       do i=iturn3_start,iturn3_end
3509 c        if (i.le.1) cycle
3510 C        write(iout,*) "tu jest i",i
3511         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3512 C changes suggested by Ana to avoid out of bounds
3513 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3514 c     & .or.((i+4).gt.nres)
3515 c     & .or.((i-1).le.0)
3516 C end of changes by Ana
3517      &  .or. itype(i+2).eq.ntyp1
3518      &  .or. itype(i+3).eq.ntyp1) cycle
3519 C Adam: Instructions below will switch off existing interactions
3520 c        if(i.gt.1)then
3521 c          if(itype(i-1).eq.ntyp1)cycle
3522 c        end if
3523 c        if(i.LT.nres-3)then
3524 c          if (itype(i+4).eq.ntyp1) cycle
3525 c        end if
3526         dxi=dc(1,i)
3527         dyi=dc(2,i)
3528         dzi=dc(3,i)
3529         dx_normi=dc_norm(1,i)
3530         dy_normi=dc_norm(2,i)
3531         dz_normi=dc_norm(3,i)
3532         xmedi=c(1,i)+0.5d0*dxi
3533         ymedi=c(2,i)+0.5d0*dyi
3534         zmedi=c(3,i)+0.5d0*dzi
3535           xmedi=mod(xmedi,boxxsize)
3536           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3537           ymedi=mod(ymedi,boxysize)
3538           if (ymedi.lt.0) ymedi=ymedi+boxysize
3539           zmedi=mod(zmedi,boxzsize)
3540           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3541           zmedi2=mod(zmedi,boxzsize)
3542           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3543        if ((zmedi2.gt.bordlipbot)
3544      &.and.(zmedi2.lt.bordliptop)) then
3545 C the energy transfer exist
3546         if (zmedi2.lt.buflipbot) then
3547 C what fraction I am in
3548          fracinbuf=1.0d0-
3549      &        ((zmedi2-bordlipbot)/lipbufthick)
3550 C lipbufthick is thickenes of lipid buffore
3551          sslipi=sscalelip(fracinbuf)
3552          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3553         elseif (zmedi2.gt.bufliptop) then
3554          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3555          sslipi=sscalelip(fracinbuf)
3556          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3557         else
3558          sslipi=1.0d0
3559          ssgradlipi=0.0d0
3560         endif
3561        else
3562          sslipi=0.0d0
3563          ssgradlipi=0.0d0
3564        endif
3565         num_conti=0
3566         call eelecij(i,i+2,ees,evdw1,eel_loc)
3567         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3568         num_cont_hb(i)=num_conti
3569       enddo
3570       do i=iturn4_start,iturn4_end
3571         if (i.lt.1) cycle
3572         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3573 C changes suggested by Ana to avoid out of bounds
3574 c     & .or.((i+5).gt.nres)
3575 c     & .or.((i-1).le.0)
3576 C end of changes suggested by Ana
3577      &    .or. itype(i+3).eq.ntyp1
3578      &    .or. itype(i+4).eq.ntyp1
3579 c     &    .or. itype(i+5).eq.ntyp1
3580 c     &    .or. itype(i).eq.ntyp1
3581 c     &    .or. itype(i-1).eq.ntyp1
3582      &                             ) cycle
3583         dxi=dc(1,i)
3584         dyi=dc(2,i)
3585         dzi=dc(3,i)
3586         dx_normi=dc_norm(1,i)
3587         dy_normi=dc_norm(2,i)
3588         dz_normi=dc_norm(3,i)
3589         xmedi=c(1,i)+0.5d0*dxi
3590         ymedi=c(2,i)+0.5d0*dyi
3591         zmedi=c(3,i)+0.5d0*dzi
3592 C Return atom into box, boxxsize is size of box in x dimension
3593 c  194   continue
3594 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3595 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3596 C Condition for being inside the proper box
3597 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3598 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3599 c        go to 194
3600 c        endif
3601 c  195   continue
3602 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3603 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3604 C Condition for being inside the proper box
3605 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3606 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3607 c        go to 195
3608 c        endif
3609 c  196   continue
3610 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3611 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3612 C Condition for being inside the proper box
3613 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3614 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3615 c        go to 196
3616 c        endif
3617           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3618           ymedi=mod(ymedi,boxysize)
3619           if (ymedi.lt.0) ymedi=ymedi+boxysize
3620           zmedi=mod(zmedi,boxzsize)
3621           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3622           zmedi2=mod(zmedi,boxzsize)
3623           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3624        if ((zmedi2.gt.bordlipbot)
3625      &.and.(zmedi2.lt.bordliptop)) then
3626 C the energy transfer exist
3627         if (zmedi2.lt.buflipbot) then
3628 C what fraction I am in
3629          fracinbuf=1.0d0-
3630      &        ((zmedi2-bordlipbot)/lipbufthick)
3631 C lipbufthick is thickenes of lipid buffore
3632          sslipi=sscalelip(fracinbuf)
3633          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3634         elseif (zmedi2.gt.bufliptop) then
3635          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3636          sslipi=sscalelip(fracinbuf)
3637          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3638         else
3639          sslipi=1.0d0
3640          ssgradlipi=0.0
3641         endif
3642        else
3643          sslipi=0.0d0
3644          ssgradlipi=0.0
3645        endif
3646         num_conti=num_cont_hb(i)
3647 c        write(iout,*) "JESTEM W PETLI"
3648         call eelecij(i,i+3,ees,evdw1,eel_loc)
3649         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3650      &   call eturn4(i,eello_turn4)
3651         num_cont_hb(i)=num_conti
3652       enddo   ! i
3653 C Loop over all neighbouring boxes
3654 C      do xshift=-1,1
3655 C      do yshift=-1,1
3656 C      do zshift=-1,1
3657 c
3658 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3659 c
3660 CTU KURWA
3661       do i=iatel_s,iatel_e
3662 C        do i=75,75
3663 c        if (i.le.1) cycle
3664         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3665 C changes suggested by Ana to avoid out of bounds
3666 c     & .or.((i+2).gt.nres)
3667 c     & .or.((i-1).le.0)
3668 C end of changes by Ana
3669 c     &  .or. itype(i+2).eq.ntyp1
3670 c     &  .or. itype(i-1).eq.ntyp1
3671      &                ) cycle
3672         dxi=dc(1,i)
3673         dyi=dc(2,i)
3674         dzi=dc(3,i)
3675         dx_normi=dc_norm(1,i)
3676         dy_normi=dc_norm(2,i)
3677         dz_normi=dc_norm(3,i)
3678         xmedi=c(1,i)+0.5d0*dxi
3679         ymedi=c(2,i)+0.5d0*dyi
3680         zmedi=c(3,i)+0.5d0*dzi
3681           xmedi=mod(xmedi,boxxsize)
3682           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3683           ymedi=mod(ymedi,boxysize)
3684           if (ymedi.lt.0) ymedi=ymedi+boxysize
3685           zmedi=mod(zmedi,boxzsize)
3686           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3687        if ((zmedi.gt.bordlipbot)
3688      &.and.(zmedi.lt.bordliptop)) then
3689 C the energy transfer exist
3690         if (zmedi.lt.buflipbot) then
3691 C what fraction I am in
3692          fracinbuf=1.0d0-
3693      &        ((zmedi-bordlipbot)/lipbufthick)
3694 C lipbufthick is thickenes of lipid buffore
3695          sslipi=sscalelip(fracinbuf)
3696          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3697         elseif (zmedi.gt.bufliptop) then
3698          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3699          sslipi=sscalelip(fracinbuf)
3700          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3701         else
3702          sslipi=1.0d0
3703          ssgradlipi=0.0
3704         endif
3705        else
3706          sslipi=0.0d0
3707          ssgradlipi=0.0
3708        endif
3709 C         print *,sslipi,"TU?!"
3710 C          xmedi=xmedi+xshift*boxxsize
3711 C          ymedi=ymedi+yshift*boxysize
3712 C          zmedi=zmedi+zshift*boxzsize
3713
3714 C Return tom into box, boxxsize is size of box in x dimension
3715 c  164   continue
3716 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3717 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3718 C Condition for being inside the proper box
3719 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3720 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3721 c        go to 164
3722 c        endif
3723 c  165   continue
3724 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3725 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3726 C Condition for being inside the proper box
3727 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3728 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3729 c        go to 165
3730 c        endif
3731 c  166   continue
3732 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3733 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3734 cC Condition for being inside the proper box
3735 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3736 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3737 c        go to 166
3738 c        endif
3739
3740 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3741         num_conti=num_cont_hb(i)
3742 C I TU KURWA
3743         do j=ielstart(i),ielend(i)
3744 C          do j=16,17
3745 C          write (iout,*) i,j
3746 C         if (j.le.1) cycle
3747           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3748 C changes suggested by Ana to avoid out of bounds
3749 c     & .or.((j+2).gt.nres)
3750 c     & .or.((j-1).le.0)
3751 C end of changes by Ana
3752 c     & .or.itype(j+2).eq.ntyp1
3753 c     & .or.itype(j-1).eq.ntyp1
3754      &) cycle
3755           call eelecij(i,j,ees,evdw1,eel_loc)
3756         enddo ! j
3757         num_cont_hb(i)=num_conti
3758       enddo   ! i
3759 C     enddo   ! zshift
3760 C      enddo   ! yshift
3761 C      enddo   ! xshift
3762
3763 c      write (iout,*) "Number of loop steps in EELEC:",ind
3764 cd      do i=1,nres
3765 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3766 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3767 cd      enddo
3768 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3769 ccc      eel_loc=eel_loc+eello_turn3
3770 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3771       return
3772       end
3773 C-------------------------------------------------------------------------------
3774       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3775       implicit real*8 (a-h,o-z)
3776       include 'DIMENSIONS'
3777 #ifdef MPI
3778       include "mpif.h"
3779 #endif
3780       include 'COMMON.CONTROL'
3781       include 'COMMON.IOUNITS'
3782       include 'COMMON.GEO'
3783       include 'COMMON.VAR'
3784       include 'COMMON.LOCAL'
3785       include 'COMMON.CHAIN'
3786       include 'COMMON.DERIV'
3787       include 'COMMON.INTERACT'
3788       include 'COMMON.CONTACTS'
3789       include 'COMMON.TORSION'
3790       include 'COMMON.VECTORS'
3791       include 'COMMON.FFIELD'
3792       include 'COMMON.TIME1'
3793       include 'COMMON.SPLITELE'
3794       include 'COMMON.SHIELD'
3795       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3796      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3797       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3798      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3799      &    gmuij2(4),gmuji2(4)
3800       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3801      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3802      &    num_conti,j1,j2
3803 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3804 #ifdef MOMENT
3805       double precision scal_el /1.0d0/
3806 #else
3807       double precision scal_el /0.5d0/
3808 #endif
3809 C 12/13/98
3810 C 13-go grudnia roku pamietnego...
3811       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3812      &                   0.0d0,1.0d0,0.0d0,
3813      &                   0.0d0,0.0d0,1.0d0/
3814        integer xshift,yshift,zshift
3815 c          time00=MPI_Wtime()
3816 cd      write (iout,*) "eelecij",i,j
3817 c          ind=ind+1
3818           iteli=itel(i)
3819           itelj=itel(j)
3820           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3821           aaa=app(iteli,itelj)
3822           bbb=bpp(iteli,itelj)
3823           ael6i=ael6(iteli,itelj)
3824           ael3i=ael3(iteli,itelj)
3825           dxj=dc(1,j)
3826           dyj=dc(2,j)
3827           dzj=dc(3,j)
3828           dx_normj=dc_norm(1,j)
3829           dy_normj=dc_norm(2,j)
3830           dz_normj=dc_norm(3,j)
3831 C          xj=c(1,j)+0.5D0*dxj-xmedi
3832 C          yj=c(2,j)+0.5D0*dyj-ymedi
3833 C          zj=c(3,j)+0.5D0*dzj-zmedi
3834           xj=c(1,j)+0.5D0*dxj
3835           yj=c(2,j)+0.5D0*dyj
3836           zj=c(3,j)+0.5D0*dzj
3837           xj=mod(xj,boxxsize)
3838           if (xj.lt.0) xj=xj+boxxsize
3839           yj=mod(yj,boxysize)
3840           if (yj.lt.0) yj=yj+boxysize
3841           zj=mod(zj,boxzsize)
3842           if (zj.lt.0) zj=zj+boxzsize
3843           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3844        if ((zj.gt.bordlipbot)
3845      &.and.(zj.lt.bordliptop)) then
3846 C the energy transfer exist
3847         if (zj.lt.buflipbot) then
3848 C what fraction I am in
3849          fracinbuf=1.0d0-
3850      &        ((zj-bordlipbot)/lipbufthick)
3851 C lipbufthick is thickenes of lipid buffore
3852          sslipj=sscalelip(fracinbuf)
3853          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3854         elseif (zj.gt.bufliptop) then
3855          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3856          sslipj=sscalelip(fracinbuf)
3857          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3858         else
3859          sslipj=1.0d0
3860          ssgradlipj=0.0
3861         endif
3862        else
3863          sslipj=0.0d0
3864          ssgradlipj=0.0
3865        endif
3866       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3867       xj_safe=xj
3868       yj_safe=yj
3869       zj_safe=zj
3870       isubchap=0
3871       do xshift=-1,1
3872       do yshift=-1,1
3873       do zshift=-1,1
3874           xj=xj_safe+xshift*boxxsize
3875           yj=yj_safe+yshift*boxysize
3876           zj=zj_safe+zshift*boxzsize
3877           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3878           if(dist_temp.lt.dist_init) then
3879             dist_init=dist_temp
3880             xj_temp=xj
3881             yj_temp=yj
3882             zj_temp=zj
3883             isubchap=1
3884           endif
3885        enddo
3886        enddo
3887        enddo
3888        if (isubchap.eq.1) then
3889           xj=xj_temp-xmedi
3890           yj=yj_temp-ymedi
3891           zj=zj_temp-zmedi
3892        else
3893           xj=xj_safe-xmedi
3894           yj=yj_safe-ymedi
3895           zj=zj_safe-zmedi
3896        endif
3897 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3898 c  174   continue
3899 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3900 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3901 C Condition for being inside the proper box
3902 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3903 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3904 c        go to 174
3905 c        endif
3906 c  175   continue
3907 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3908 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3909 C Condition for being inside the proper box
3910 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3911 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3912 c        go to 175
3913 c        endif
3914 c  176   continue
3915 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3916 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3917 C Condition for being inside the proper box
3918 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3919 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3920 c        go to 176
3921 c        endif
3922 C        endif !endPBC condintion
3923 C        xj=xj-xmedi
3924 C        yj=yj-ymedi
3925 C        zj=zj-zmedi
3926           rij=xj*xj+yj*yj+zj*zj
3927
3928             sss=sscale(sqrt(rij))
3929             sssgrad=sscagrad(sqrt(rij))
3930 c            if (sss.gt.0.0d0) then
3931           rrmij=1.0D0/rij
3932           rij=dsqrt(rij)
3933           rmij=1.0D0/rij
3934           r3ij=rrmij*rmij
3935           r6ij=r3ij*r3ij
3936           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3937           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3938           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3939           fac=cosa-3.0D0*cosb*cosg
3940           ev1=aaa*r6ij*r6ij
3941 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3942           if (j.eq.i+2) ev1=scal_el*ev1
3943           ev2=bbb*r6ij
3944           fac3=ael6i*r6ij
3945           fac4=ael3i*r3ij
3946           evdwij=(ev1+ev2)
3947           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3948           el2=fac4*fac
3949 C MARYSIA
3950 C          eesij=(el1+el2)
3951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3953           if (shield_mode.gt.0) then
3954 C          fac_shield(i)=0.4
3955 C          fac_shield(j)=0.6
3956           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3957           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3958           eesij=(el1+el2)
3959           ees=ees+eesij
3960 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3961 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3962           else
3963           fac_shield(i)=1.0
3964           fac_shield(j)=1.0
3965           eesij=(el1+el2)
3966           ees=ees+eesij
3967      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3968 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3969           endif
3970           evdw1=evdw1+evdwij*sss
3971      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3972 C          print *,sslipi,sslipj,lipscale**2,
3973 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3974 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3975 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3976 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3977 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3978
3979           if (energy_dec) then
3980               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3981      &'evdw1',i,j,evdwij
3982      &,iteli,itelj,aaa,evdw1
3983               write (iout,*) sss
3984               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3985      &fac_shield(i),fac_shield(j)
3986           endif
3987
3988 C
3989 C Calculate contributions to the Cartesian gradient.
3990 C
3991 #ifdef SPLITELE
3992           facvdw=-6*rrmij*(ev1+evdwij)*sss
3993      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994           facel=-3*rrmij*(el1+eesij)
3995      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3996           fac1=fac
3997           erij(1)=xj*rmij
3998           erij(2)=yj*rmij
3999           erij(3)=zj*rmij
4000
4001 *
4002 * Radial derivatives. First process both termini of the fragment (i,j)
4003 *
4004           ggg(1)=facel*xj
4005           ggg(2)=facel*yj
4006           ggg(3)=facel*zj
4007           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4008      &  (shield_mode.gt.0)) then
4009 C          print *,i,j
4010           do ilist=1,ishield_list(i)
4011            iresshield=shield_list(ilist,i)
4012            do k=1,3
4013            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4014      &      *2.0
4015            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4016      &              rlocshield
4017      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4018             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4019 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4020 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4021 C             if (iresshield.gt.i) then
4022 C               do ishi=i+1,iresshield-1
4023 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4024 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4025 C
4026 C              enddo
4027 C             else
4028 C               do ishi=iresshield,i
4029 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4030 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4031 C
4032 C               enddo
4033 C              endif
4034            enddo
4035           enddo
4036           do ilist=1,ishield_list(j)
4037            iresshield=shield_list(ilist,j)
4038            do k=1,3
4039            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4040      &     *2.0
4041            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4042      &              rlocshield
4043      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4044            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4045
4046 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4047 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4048 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4049 C             if (iresshield.gt.j) then
4050 C               do ishi=j+1,iresshield-1
4051 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4052 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4053 C
4054 C               enddo
4055 C            else
4056 C               do ishi=iresshield,j
4057 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4058 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4059 C               enddo
4060 C              endif
4061            enddo
4062           enddo
4063
4064           do k=1,3
4065             gshieldc(k,i)=gshieldc(k,i)+
4066      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4067             gshieldc(k,j)=gshieldc(k,j)+
4068      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4069             gshieldc(k,i-1)=gshieldc(k,i-1)+
4070      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4071             gshieldc(k,j-1)=gshieldc(k,j-1)+
4072      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4073
4074            enddo
4075            endif
4076 c          do k=1,3
4077 c            ghalf=0.5D0*ggg(k)
4078 c            gelc(k,i)=gelc(k,i)+ghalf
4079 c            gelc(k,j)=gelc(k,j)+ghalf
4080 c          enddo
4081 c 9/28/08 AL Gradient compotents will be summed only at the end
4082 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4083           do k=1,3
4084             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4085 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4086             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4087 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4088 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4089 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4090 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4091 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4092           enddo
4093 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4094 C Lipidic part for lipscale
4095             gelc_long(3,j)=gelc_long(3,j)+
4096      &     ssgradlipj*eesij/2.0d0*lipscale**2
4097
4098             gelc_long(3,i)=gelc_long(3,i)+
4099      &     ssgradlipi*eesij/2.0d0*lipscale**2
4100
4101 *
4102 * Loop over residues i+1 thru j-1.
4103 *
4104 cgrad          do k=i+1,j-1
4105 cgrad            do l=1,3
4106 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4107 cgrad            enddo
4108 cgrad          enddo
4109           if (sss.gt.0.0) then
4110           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4111      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4112
4113           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4114      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4115
4116           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4117      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4118           else
4119           ggg(1)=0.0
4120           ggg(2)=0.0
4121           ggg(3)=0.0
4122           endif
4123 c          do k=1,3
4124 c            ghalf=0.5D0*ggg(k)
4125 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4126 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4127 c          enddo
4128 c 9/28/08 AL Gradient compotents will be summed only at the end
4129           do k=1,3
4130             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4131             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4132           enddo
4133 C Lipidic part for scaling weight
4134            gvdwpp(3,j)=gvdwpp(3,j)+
4135      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4136            gvdwpp(3,i)=gvdwpp(3,i)+
4137      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4138
4139 *
4140 * Loop over residues i+1 thru j-1.
4141 *
4142 cgrad          do k=i+1,j-1
4143 cgrad            do l=1,3
4144 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4145 cgrad            enddo
4146 cgrad          enddo
4147 #else
4148 C MARYSIA
4149           facvdw=(ev1+evdwij)*sss
4150      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4151           facel=(el1+eesij)
4152           fac1=fac
4153           fac=-3*rrmij*(facvdw+facvdw+facel)
4154           erij(1)=xj*rmij
4155           erij(2)=yj*rmij
4156           erij(3)=zj*rmij
4157 *
4158 * Radial derivatives. First process both termini of the fragment (i,j)
4159 *
4160           ggg(1)=fac*xj
4161 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4162           ggg(2)=fac*yj
4163 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4164           ggg(3)=fac*zj
4165 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4166 c          do k=1,3
4167 c            ghalf=0.5D0*ggg(k)
4168 c            gelc(k,i)=gelc(k,i)+ghalf
4169 c            gelc(k,j)=gelc(k,j)+ghalf
4170 c          enddo
4171 c 9/28/08 AL Gradient compotents will be summed only at the end
4172           do k=1,3
4173             gelc_long(k,j)=gelc(k,j)+ggg(k)
4174             gelc_long(k,i)=gelc(k,i)-ggg(k)
4175           enddo
4176 *
4177 * Loop over residues i+1 thru j-1.
4178 *
4179 cgrad          do k=i+1,j-1
4180 cgrad            do l=1,3
4181 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4182 cgrad            enddo
4183 cgrad          enddo
4184 c 9/28/08 AL Gradient compotents will be summed only at the end
4185           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4186      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4187
4188           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4189      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4190
4191           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4192      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4193           do k=1,3
4194             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4195             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4196           enddo
4197            gvdwpp(3,j)=gvdwpp(3,j)+
4198      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4199            gvdwpp(3,i)=gvdwpp(3,i)+
4200      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4201
4202 #endif
4203 *
4204 * Angular part
4205 *
4206           ecosa=2.0D0*fac3*fac1+fac4
4207           fac4=-3.0D0*fac4
4208           fac3=-6.0D0*fac3
4209           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4210           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4211           do k=1,3
4212             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4213             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4214           enddo
4215 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4216 cd   &          (dcosg(k),k=1,3)
4217           do k=1,3
4218             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4219      &      fac_shield(i)**2*fac_shield(j)**2
4220      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4221           enddo
4222 c          do k=1,3
4223 c            ghalf=0.5D0*ggg(k)
4224 c            gelc(k,i)=gelc(k,i)+ghalf
4225 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4226 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4227 c            gelc(k,j)=gelc(k,j)+ghalf
4228 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4229 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4230 c          enddo
4231 cgrad          do k=i+1,j-1
4232 cgrad            do l=1,3
4233 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4234 cgrad            enddo
4235 cgrad          enddo
4236 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4237           do k=1,3
4238             gelc(k,i)=gelc(k,i)
4239      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4240      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4241      &           *fac_shield(i)**2*fac_shield(j)**2
4242      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4243             gelc(k,j)=gelc(k,j)
4244      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4245      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4246      &           *fac_shield(i)**2*fac_shield(j)**2
4247      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4248             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4249             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4250           enddo
4251 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4252
4253 C MARYSIA
4254 c          endif !sscale
4255           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4256      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4257      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4258 C
4259 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4260 C   energy of a peptide unit is assumed in the form of a second-order
4261 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4262 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4263 C   are computed for EVERY pair of non-contiguous peptide groups.
4264 C
4265
4266           if (j.lt.nres-1) then
4267             j1=j+1
4268             j2=j-1
4269           else
4270             j1=j-1
4271             j2=j-2
4272           endif
4273           kkk=0
4274           lll=0
4275           do k=1,2
4276             do l=1,2
4277               kkk=kkk+1
4278               muij(kkk)=mu(k,i)*mu(l,j)
4279 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4280 #ifdef NEWCORR
4281              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4282 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4283              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4284              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4285 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4286              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4287 #endif
4288             enddo
4289           enddo
4290 cd         write (iout,*) 'EELEC: i',i,' j',j
4291 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4292 cd          write(iout,*) 'muij',muij
4293           ury=scalar(uy(1,i),erij)
4294           urz=scalar(uz(1,i),erij)
4295           vry=scalar(uy(1,j),erij)
4296           vrz=scalar(uz(1,j),erij)
4297           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4298           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4299           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4300           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4301           fac=dsqrt(-ael6i)*r3ij
4302           a22=a22*fac
4303           a23=a23*fac
4304           a32=a32*fac
4305           a33=a33*fac
4306 cd          write (iout,'(4i5,4f10.5)')
4307 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4308 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4309 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4310 cd     &      uy(:,j),uz(:,j)
4311 cd          write (iout,'(4f10.5)')
4312 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4313 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4314 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4315 cd           write (iout,'(9f10.5/)')
4316 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4317 C Derivatives of the elements of A in virtual-bond vectors
4318           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4319           do k=1,3
4320             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4321             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4322             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4323             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4324             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4325             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4326             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4327             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4328             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4329             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4330             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4331             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4332           enddo
4333 C Compute radial contributions to the gradient
4334           facr=-3.0d0*rrmij
4335           a22der=a22*facr
4336           a23der=a23*facr
4337           a32der=a32*facr
4338           a33der=a33*facr
4339           agg(1,1)=a22der*xj
4340           agg(2,1)=a22der*yj
4341           agg(3,1)=a22der*zj
4342           agg(1,2)=a23der*xj
4343           agg(2,2)=a23der*yj
4344           agg(3,2)=a23der*zj
4345           agg(1,3)=a32der*xj
4346           agg(2,3)=a32der*yj
4347           agg(3,3)=a32der*zj
4348           agg(1,4)=a33der*xj
4349           agg(2,4)=a33der*yj
4350           agg(3,4)=a33der*zj
4351 C Add the contributions coming from er
4352           fac3=-3.0d0*fac
4353           do k=1,3
4354             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4355             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4356             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4357             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4358           enddo
4359           do k=1,3
4360 C Derivatives in DC(i)
4361 cgrad            ghalf1=0.5d0*agg(k,1)
4362 cgrad            ghalf2=0.5d0*agg(k,2)
4363 cgrad            ghalf3=0.5d0*agg(k,3)
4364 cgrad            ghalf4=0.5d0*agg(k,4)
4365             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4366      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4367             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4368      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4369             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4370      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4371             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4372      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4373 C Derivatives in DC(i+1)
4374             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4375      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4376             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4377      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4378             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4379      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4380             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4381      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4382 C Derivatives in DC(j)
4383             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4384      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4385             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4386      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4387             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4388      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4389             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4390      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4391 C Derivatives in DC(j+1) or DC(nres-1)
4392             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4393      &      -3.0d0*vryg(k,3)*ury)
4394             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4395      &      -3.0d0*vrzg(k,3)*ury)
4396             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4397      &      -3.0d0*vryg(k,3)*urz)
4398             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4399      &      -3.0d0*vrzg(k,3)*urz)
4400 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4401 cgrad              do l=1,4
4402 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4403 cgrad              enddo
4404 cgrad            endif
4405           enddo
4406           acipa(1,1)=a22
4407           acipa(1,2)=a23
4408           acipa(2,1)=a32
4409           acipa(2,2)=a33
4410           a22=-a22
4411           a23=-a23
4412           do l=1,2
4413             do k=1,3
4414               agg(k,l)=-agg(k,l)
4415               aggi(k,l)=-aggi(k,l)
4416               aggi1(k,l)=-aggi1(k,l)
4417               aggj(k,l)=-aggj(k,l)
4418               aggj1(k,l)=-aggj1(k,l)
4419             enddo
4420           enddo
4421           if (j.lt.nres-1) then
4422             a22=-a22
4423             a32=-a32
4424             do l=1,3,2
4425               do k=1,3
4426                 agg(k,l)=-agg(k,l)
4427                 aggi(k,l)=-aggi(k,l)
4428                 aggi1(k,l)=-aggi1(k,l)
4429                 aggj(k,l)=-aggj(k,l)
4430                 aggj1(k,l)=-aggj1(k,l)
4431               enddo
4432             enddo
4433           else
4434             a22=-a22
4435             a23=-a23
4436             a32=-a32
4437             a33=-a33
4438             do l=1,4
4439               do k=1,3
4440                 agg(k,l)=-agg(k,l)
4441                 aggi(k,l)=-aggi(k,l)
4442                 aggi1(k,l)=-aggi1(k,l)
4443                 aggj(k,l)=-aggj(k,l)
4444                 aggj1(k,l)=-aggj1(k,l)
4445               enddo
4446             enddo
4447           endif
4448           ENDIF ! WCORR
4449           IF (wel_loc.gt.0.0d0) THEN
4450 C Contribution to the local-electrostatic energy coming from the i-j pair
4451           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4452      &     +a33*muij(4)
4453           if (shield_mode.eq.0) then
4454            fac_shield(i)=1.0
4455            fac_shield(j)=1.0
4456 C          else
4457 C           fac_shield(i)=0.4
4458 C           fac_shield(j)=0.6
4459           endif
4460           eel_loc_ij=eel_loc_ij
4461      &    *fac_shield(i)*fac_shield(j)
4462      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4463
4464 C Now derivative over eel_loc
4465           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4466      &  (shield_mode.gt.0)) then
4467 C          print *,i,j
4468
4469           do ilist=1,ishield_list(i)
4470            iresshield=shield_list(ilist,i)
4471            do k=1,3
4472            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4473      &                                          /fac_shield(i)
4474 C     &      *2.0
4475            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4476      &              rlocshield
4477      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4478             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4479      &      +rlocshield
4480            enddo
4481           enddo
4482           do ilist=1,ishield_list(j)
4483            iresshield=shield_list(ilist,j)
4484            do k=1,3
4485            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4486      &                                       /fac_shield(j)
4487 C     &     *2.0
4488            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4489      &              rlocshield
4490      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4491            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4492      &             +rlocshield
4493
4494            enddo
4495           enddo
4496
4497           do k=1,3
4498             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4499      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4500             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4501      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4502             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4503      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4504             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4505      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4506            enddo
4507            endif
4508
4509
4510 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4511 c     &                     ' eel_loc_ij',eel_loc_ij
4512 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4513 C Calculate patrial derivative for theta angle
4514 #ifdef NEWCORR
4515          geel_loc_ij=(a22*gmuij1(1)
4516      &     +a23*gmuij1(2)
4517      &     +a32*gmuij1(3)
4518      &     +a33*gmuij1(4))
4519      &    *fac_shield(i)*fac_shield(j)
4520      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4521
4522 c         write(iout,*) "derivative over thatai"
4523 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4524 c     &   a33*gmuij1(4)
4525          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4526      &      geel_loc_ij*wel_loc
4527 c         write(iout,*) "derivative over thatai-1"
4528 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4529 c     &   a33*gmuij2(4)
4530          geel_loc_ij=
4531      &     a22*gmuij2(1)
4532      &     +a23*gmuij2(2)
4533      &     +a32*gmuij2(3)
4534      &     +a33*gmuij2(4)
4535          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4536      &      geel_loc_ij*wel_loc
4537      &    *fac_shield(i)*fac_shield(j)
4538      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4539
4540
4541 c  Derivative over j residue
4542          geel_loc_ji=a22*gmuji1(1)
4543      &     +a23*gmuji1(2)
4544      &     +a32*gmuji1(3)
4545      &     +a33*gmuji1(4)
4546 c         write(iout,*) "derivative over thataj"
4547 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4548 c     &   a33*gmuji1(4)
4549
4550         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4551      &      geel_loc_ji*wel_loc
4552      &    *fac_shield(i)*fac_shield(j)
4553      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4554
4555          geel_loc_ji=
4556      &     +a22*gmuji2(1)
4557      &     +a23*gmuji2(2)
4558      &     +a32*gmuji2(3)
4559      &     +a33*gmuji2(4)
4560 c         write(iout,*) "derivative over thataj-1"
4561 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4562 c     &   a33*gmuji2(4)
4563          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4564      &      geel_loc_ji*wel_loc
4565      &    *fac_shield(i)*fac_shield(j)
4566      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4567
4568 #endif
4569 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4570
4571           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4572      &            'eelloc',i,j,eel_loc_ij
4573 c           if (eel_loc_ij.ne.0)
4574 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4575 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4576
4577           eel_loc=eel_loc+eel_loc_ij
4578 C Partial derivatives in virtual-bond dihedral angles gamma
4579           if (i.gt.1)
4580      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4581      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4582      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4583      &    *fac_shield(i)*fac_shield(j)
4584      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4585
4586           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4587      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4588      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4589      &    *fac_shield(i)*fac_shield(j)
4590      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4591
4592 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4593           do l=1,3
4594             ggg(l)=(agg(l,1)*muij(1)+
4595      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4596      &    *fac_shield(i)*fac_shield(j)
4597      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4598
4599             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4600             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4601 cgrad            ghalf=0.5d0*ggg(l)
4602 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4603 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4604           enddo
4605             gel_loc_long(3,j)=gel_loc_long(3,j)+
4606      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4607      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4608
4609             gel_loc_long(3,i)=gel_loc_long(3,i)+
4610      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4611      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4612
4613 cgrad          do k=i+1,j2
4614 cgrad            do l=1,3
4615 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4616 cgrad            enddo
4617 cgrad          enddo
4618 C Remaining derivatives of eello
4619           do l=1,3
4620             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4621      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4622      &    *fac_shield(i)*fac_shield(j)
4623      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4624
4625             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4626      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4627      &    *fac_shield(i)*fac_shield(j)
4628      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4629
4630             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4631      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4632      &    *fac_shield(i)*fac_shield(j)
4633      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4634
4635             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4636      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4637      &    *fac_shield(i)*fac_shield(j)
4638      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4639
4640           enddo
4641           ENDIF
4642 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4643 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4644           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4645      &       .and. num_conti.le.maxconts) then
4646 c            write (iout,*) i,j," entered corr"
4647 C
4648 C Calculate the contact function. The ith column of the array JCONT will
4649 C contain the numbers of atoms that make contacts with the atom I (of numbers
4650 C greater than I). The arrays FACONT and GACONT will contain the values of
4651 C the contact function and its derivative.
4652 c           r0ij=1.02D0*rpp(iteli,itelj)
4653 c           r0ij=1.11D0*rpp(iteli,itelj)
4654             r0ij=2.20D0*rpp(iteli,itelj)
4655 c           r0ij=1.55D0*rpp(iteli,itelj)
4656             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4657             if (fcont.gt.0.0D0) then
4658               num_conti=num_conti+1
4659               if (num_conti.gt.maxconts) then
4660                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4661      &                         ' will skip next contacts for this conf.'
4662               else
4663                 jcont_hb(num_conti,i)=j
4664 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4665 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4666                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4667      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4668 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4669 C  terms.
4670                 d_cont(num_conti,i)=rij
4671 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4672 C     --- Electrostatic-interaction matrix ---
4673                 a_chuj(1,1,num_conti,i)=a22
4674                 a_chuj(1,2,num_conti,i)=a23
4675                 a_chuj(2,1,num_conti,i)=a32
4676                 a_chuj(2,2,num_conti,i)=a33
4677 C     --- Gradient of rij
4678                 do kkk=1,3
4679                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4680                 enddo
4681                 kkll=0
4682                 do k=1,2
4683                   do l=1,2
4684                     kkll=kkll+1
4685                     do m=1,3
4686                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4687                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4688                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4689                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4690                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4691                     enddo
4692                   enddo
4693                 enddo
4694                 ENDIF
4695                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4696 C Calculate contact energies
4697                 cosa4=4.0D0*cosa
4698                 wij=cosa-3.0D0*cosb*cosg
4699                 cosbg1=cosb+cosg
4700                 cosbg2=cosb-cosg
4701 c               fac3=dsqrt(-ael6i)/r0ij**3
4702                 fac3=dsqrt(-ael6i)*r3ij
4703 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4704                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4705                 if (ees0tmp.gt.0) then
4706                   ees0pij=dsqrt(ees0tmp)
4707                 else
4708                   ees0pij=0
4709                 endif
4710 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4711                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4712                 if (ees0tmp.gt.0) then
4713                   ees0mij=dsqrt(ees0tmp)
4714                 else
4715                   ees0mij=0
4716                 endif
4717 c               ees0mij=0.0D0
4718                 if (shield_mode.eq.0) then
4719                 fac_shield(i)=1.0d0
4720                 fac_shield(j)=1.0d0
4721                 else
4722                 ees0plist(num_conti,i)=j
4723 C                fac_shield(i)=0.4d0
4724 C                fac_shield(j)=0.6d0
4725                 endif
4726                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4727      &          *fac_shield(i)*fac_shield(j)
4728                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4729      &          *fac_shield(i)*fac_shield(j)
4730 C Diagnostics. Comment out or remove after debugging!
4731 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4732 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4733 c               ees0m(num_conti,i)=0.0D0
4734 C End diagnostics.
4735 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4736 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4737 C Angular derivatives of the contact function
4738                 ees0pij1=fac3/ees0pij
4739                 ees0mij1=fac3/ees0mij
4740                 fac3p=-3.0D0*fac3*rrmij
4741                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4742                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4743 c               ees0mij1=0.0D0
4744                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4745                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4746                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4747                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4748                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4749                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4750                 ecosap=ecosa1+ecosa2
4751                 ecosbp=ecosb1+ecosb2
4752                 ecosgp=ecosg1+ecosg2
4753                 ecosam=ecosa1-ecosa2
4754                 ecosbm=ecosb1-ecosb2
4755                 ecosgm=ecosg1-ecosg2
4756 C Diagnostics
4757 c               ecosap=ecosa1
4758 c               ecosbp=ecosb1
4759 c               ecosgp=ecosg1
4760 c               ecosam=0.0D0
4761 c               ecosbm=0.0D0
4762 c               ecosgm=0.0D0
4763 C End diagnostics
4764                 facont_hb(num_conti,i)=fcont
4765                 fprimcont=fprimcont/rij
4766 cd              facont_hb(num_conti,i)=1.0D0
4767 C Following line is for diagnostics.
4768 cd              fprimcont=0.0D0
4769                 do k=1,3
4770                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4771                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4772                 enddo
4773                 do k=1,3
4774                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4775                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4776                 enddo
4777                 gggp(1)=gggp(1)+ees0pijp*xj
4778                 gggp(2)=gggp(2)+ees0pijp*yj
4779                 gggp(3)=gggp(3)+ees0pijp*zj
4780                 gggm(1)=gggm(1)+ees0mijp*xj
4781                 gggm(2)=gggm(2)+ees0mijp*yj
4782                 gggm(3)=gggm(3)+ees0mijp*zj
4783 C Derivatives due to the contact function
4784                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4785                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4786                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4787                 do k=1,3
4788 c
4789 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4790 c          following the change of gradient-summation algorithm.
4791 c
4792 cgrad                  ghalfp=0.5D0*gggp(k)
4793 cgrad                  ghalfm=0.5D0*gggm(k)
4794                   gacontp_hb1(k,num_conti,i)=!ghalfp
4795      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4796      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4797      &          *fac_shield(i)*fac_shield(j)
4798
4799                   gacontp_hb2(k,num_conti,i)=!ghalfp
4800      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4801      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4802      &          *fac_shield(i)*fac_shield(j)
4803
4804                   gacontp_hb3(k,num_conti,i)=gggp(k)
4805      &          *fac_shield(i)*fac_shield(j)
4806
4807                   gacontm_hb1(k,num_conti,i)=!ghalfm
4808      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4809      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4810      &          *fac_shield(i)*fac_shield(j)
4811
4812                   gacontm_hb2(k,num_conti,i)=!ghalfm
4813      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4814      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4815      &          *fac_shield(i)*fac_shield(j)
4816
4817                   gacontm_hb3(k,num_conti,i)=gggm(k)
4818      &          *fac_shield(i)*fac_shield(j)
4819
4820                 enddo
4821 C Diagnostics. Comment out or remove after debugging!
4822 cdiag           do k=1,3
4823 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4824 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4825 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4826 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4827 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4828 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4829 cdiag           enddo
4830               ENDIF ! wcorr
4831               endif  ! num_conti.le.maxconts
4832             endif  ! fcont.gt.0
4833           endif    ! j.gt.i+1
4834           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4835             do k=1,4
4836               do l=1,3
4837                 ghalf=0.5d0*agg(l,k)
4838                 aggi(l,k)=aggi(l,k)+ghalf
4839                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4840                 aggj(l,k)=aggj(l,k)+ghalf
4841               enddo
4842             enddo
4843             if (j.eq.nres-1 .and. i.lt.j-2) then
4844               do k=1,4
4845                 do l=1,3
4846                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4847                 enddo
4848               enddo
4849             endif
4850           endif
4851 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4852       return
4853       end
4854 C-----------------------------------------------------------------------------
4855       subroutine eturn3(i,eello_turn3)
4856 C Third- and fourth-order contributions from turns
4857       implicit real*8 (a-h,o-z)
4858       include 'DIMENSIONS'
4859       include 'COMMON.IOUNITS'
4860       include 'COMMON.GEO'
4861       include 'COMMON.VAR'
4862       include 'COMMON.LOCAL'
4863       include 'COMMON.CHAIN'
4864       include 'COMMON.DERIV'
4865       include 'COMMON.INTERACT'
4866       include 'COMMON.CONTACTS'
4867       include 'COMMON.TORSION'
4868       include 'COMMON.VECTORS'
4869       include 'COMMON.FFIELD'
4870       include 'COMMON.CONTROL'
4871       include 'COMMON.SHIELD'
4872       dimension ggg(3)
4873       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4874      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4875      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4876      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4877      &  auxgmat2(2,2),auxgmatt2(2,2)
4878       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4879      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4880       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4881      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4882      &    num_conti,j1,j2
4883       j=i+2
4884 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4885 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4886           zj=(c(3,j)+c(3,j+1))/2.0d0
4887 C          xj=mod(xj,boxxsize)
4888 C          if (xj.lt.0) xj=xj+boxxsize
4889 C          yj=mod(yj,boxysize)
4890 C          if (yj.lt.0) yj=yj+boxysize
4891           zj=mod(zj,boxzsize)
4892           if (zj.lt.0) zj=zj+boxzsize
4893           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4894        if ((zj.gt.bordlipbot)
4895      &.and.(zj.lt.bordliptop)) then
4896 C the energy transfer exist
4897         if (zj.lt.buflipbot) then
4898 C what fraction I am in
4899          fracinbuf=1.0d0-
4900      &        ((zj-bordlipbot)/lipbufthick)
4901 C lipbufthick is thickenes of lipid buffore
4902          sslipj=sscalelip(fracinbuf)
4903          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4904         elseif (zj.gt.bufliptop) then
4905          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4906          sslipj=sscalelip(fracinbuf)
4907          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4908         else
4909          sslipj=1.0d0
4910          ssgradlipj=0.0
4911         endif
4912        else
4913          sslipj=0.0d0
4914          ssgradlipj=0.0
4915        endif
4916 C      sslipj=0.0
4917 C      ssgradlipj=0.0d0
4918
4919 C      write (iout,*) "eturn3",i,j,j1,j2
4920       a_temp(1,1)=a22
4921       a_temp(1,2)=a23
4922       a_temp(2,1)=a32
4923       a_temp(2,2)=a33
4924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4925 C
4926 C               Third-order contributions
4927 C
4928 C                 (i+2)o----(i+3)
4929 C                      | |
4930 C                      | |
4931 C                 (i+1)o----i
4932 C
4933 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4934 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4935         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4936 c auxalary matices for theta gradient
4937 c auxalary matrix for i+1 and constant i+2
4938         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4939 c auxalary matrix for i+2 and constant i+1
4940         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4941         call transpose2(auxmat(1,1),auxmat1(1,1))
4942         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4943         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4944         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4945         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4946         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4947         if (shield_mode.eq.0) then
4948         fac_shield(i)=1.0d0
4949         fac_shield(j)=1.0d0
4950 C        else
4951 C        fac_shield(i)=0.4
4952 C        fac_shield(j)=0.6
4953         endif
4954 C         if (j.eq.78)
4955 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
4956         eello_turn3=eello_turn3+
4957 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4958      &0.5d0*(pizda(1,1)+pizda(2,2))
4959      &  *fac_shield(i)*fac_shield(j)
4960      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4961         eello_t3=
4962      &0.5d0*(pizda(1,1)+pizda(2,2))
4963      &  *fac_shield(i)*fac_shield(j)
4964 #ifdef NEWCORR
4965 C Derivatives in theta
4966         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4967      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4968      &   *fac_shield(i)*fac_shield(j)
4969      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4970
4971         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4972      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4973      &   *fac_shield(i)*fac_shield(j)
4974      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4975
4976 #endif
4977
4978 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4979 C Derivatives in shield mode
4980           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4981      &  (shield_mode.gt.0)) then
4982 C          print *,i,j
4983
4984           do ilist=1,ishield_list(i)
4985            iresshield=shield_list(ilist,i)
4986            do k=1,3
4987            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4988 C     &      *2.0
4989            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4990      &              rlocshield
4991      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4992             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4993      &      +rlocshield
4994            enddo
4995           enddo
4996           do ilist=1,ishield_list(j)
4997            iresshield=shield_list(ilist,j)
4998            do k=1,3
4999            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5000 C     &     *2.0
5001            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5002      &              rlocshield
5003      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5004            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5005      &             +rlocshield
5006
5007            enddo
5008           enddo
5009
5010           do k=1,3
5011             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5012      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5013             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5014      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5015             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5016      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5017             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5018      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5019            enddo
5020            endif
5021
5022 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5023 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5024 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5025 cd     &    ' eello_turn3_num',4*eello_turn3_num
5026 C Derivatives in gamma(i)
5027         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5028         call transpose2(auxmat2(1,1),auxmat3(1,1))
5029         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5030         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5031      &   *fac_shield(i)*fac_shield(j)
5032      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5033
5034 C Derivatives in gamma(i+1)
5035         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5036         call transpose2(auxmat2(1,1),auxmat3(1,1))
5037         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5038         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5039      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5040      &   *fac_shield(i)*fac_shield(j)
5041      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5042
5043 C Cartesian derivatives
5044         do l=1,3
5045 c            ghalf1=0.5d0*agg(l,1)
5046 c            ghalf2=0.5d0*agg(l,2)
5047 c            ghalf3=0.5d0*agg(l,3)
5048 c            ghalf4=0.5d0*agg(l,4)
5049           a_temp(1,1)=aggi(l,1)!+ghalf1
5050           a_temp(1,2)=aggi(l,2)!+ghalf2
5051           a_temp(2,1)=aggi(l,3)!+ghalf3
5052           a_temp(2,2)=aggi(l,4)!+ghalf4
5053           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5054           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5055      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5056      &   *fac_shield(i)*fac_shield(j)
5057      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5058
5059           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5060           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5061           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5062           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5063           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5064           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5065      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5066      &   *fac_shield(i)*fac_shield(j)
5067      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5068           a_temp(1,1)=aggj(l,1)!+ghalf1
5069           a_temp(1,2)=aggj(l,2)!+ghalf2
5070           a_temp(2,1)=aggj(l,3)!+ghalf3
5071           a_temp(2,2)=aggj(l,4)!+ghalf4
5072           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5073           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5074      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5075      &   *fac_shield(i)*fac_shield(j)
5076      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5077
5078           a_temp(1,1)=aggj1(l,1)
5079           a_temp(1,2)=aggj1(l,2)
5080           a_temp(2,1)=aggj1(l,3)
5081           a_temp(2,2)=aggj1(l,4)
5082           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5083           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5084      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5085      &   *fac_shield(i)*fac_shield(j)
5086      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5087         enddo
5088          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5089      &     ssgradlipi*eello_t3/4.0d0*lipscale
5090          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5091      &     ssgradlipj*eello_t3/4.0d0*lipscale
5092          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5093      &     ssgradlipi*eello_t3/4.0d0*lipscale
5094          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5095      &     ssgradlipj*eello_t3/4.0d0*lipscale
5096
5097 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5098       return
5099       end
5100 C-------------------------------------------------------------------------------
5101       subroutine eturn4(i,eello_turn4)
5102 C Third- and fourth-order contributions from turns
5103       implicit real*8 (a-h,o-z)
5104       include 'DIMENSIONS'
5105       include 'COMMON.IOUNITS'
5106       include 'COMMON.GEO'
5107       include 'COMMON.VAR'
5108       include 'COMMON.LOCAL'
5109       include 'COMMON.CHAIN'
5110       include 'COMMON.DERIV'
5111       include 'COMMON.INTERACT'
5112       include 'COMMON.CONTACTS'
5113       include 'COMMON.TORSION'
5114       include 'COMMON.VECTORS'
5115       include 'COMMON.FFIELD'
5116       include 'COMMON.CONTROL'
5117       include 'COMMON.SHIELD'
5118       dimension ggg(3)
5119       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5120      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5121      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5122      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5123      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5124      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5125      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5126       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5127      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5128       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5129      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5130      &    num_conti,j1,j2
5131       j=i+3
5132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5133 C
5134 C               Fourth-order contributions
5135 C
5136 C                 (i+3)o----(i+4)
5137 C                     /  |
5138 C               (i+2)o   |
5139 C                     \  |
5140 C                 (i+1)o----i
5141 C
5142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5143 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5144 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5145 c        write(iout,*)"WCHODZE W PROGRAM"
5146           zj=(c(3,j)+c(3,j+1))/2.0d0
5147 C          xj=mod(xj,boxxsize)
5148 C          if (xj.lt.0) xj=xj+boxxsize
5149 C          yj=mod(yj,boxysize)
5150 C          if (yj.lt.0) yj=yj+boxysize
5151           zj=mod(zj,boxzsize)
5152           if (zj.lt.0) zj=zj+boxzsize
5153 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5154        if ((zj.gt.bordlipbot)
5155      &.and.(zj.lt.bordliptop)) then
5156 C the energy transfer exist
5157         if (zj.lt.buflipbot) then
5158 C what fraction I am in
5159          fracinbuf=1.0d0-
5160      &        ((zj-bordlipbot)/lipbufthick)
5161 C lipbufthick is thickenes of lipid buffore
5162          sslipj=sscalelip(fracinbuf)
5163          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5164         elseif (zj.gt.bufliptop) then
5165          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5166          sslipj=sscalelip(fracinbuf)
5167          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5168         else
5169          sslipj=1.0d0
5170          ssgradlipj=0.0
5171         endif
5172        else
5173          sslipj=0.0d0
5174          ssgradlipj=0.0
5175        endif
5176
5177         a_temp(1,1)=a22
5178         a_temp(1,2)=a23
5179         a_temp(2,1)=a32
5180         a_temp(2,2)=a33
5181         iti1=itype2loc(itype(i+1))
5182         iti2=itype2loc(itype(i+2))
5183         iti3=itype2loc(itype(i+3))
5184 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5185         call transpose2(EUg(1,1,i+1),e1t(1,1))
5186         call transpose2(Eug(1,1,i+2),e2t(1,1))
5187         call transpose2(Eug(1,1,i+3),e3t(1,1))
5188 C Ematrix derivative in theta
5189         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5190         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5191         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5192         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5193 c       eta1 in derivative theta
5194         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5195         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5196 c       auxgvec is derivative of Ub2 so i+3 theta
5197         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5198 c       auxalary matrix of E i+1
5199         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5200 c        s1=0.0
5201 c        gs1=0.0
5202         s1=scalar2(b1(1,i+2),auxvec(1))
5203 c derivative of theta i+2 with constant i+3
5204         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5205 c derivative of theta i+2 with constant i+2
5206         gs32=scalar2(b1(1,i+2),auxgvec(1))
5207 c derivative of E matix in theta of i+1
5208         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5209
5210         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5211 c       ea31 in derivative theta
5212         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5213         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5214 c auxilary matrix auxgvec of Ub2 with constant E matirx
5215         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5216 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5217         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5218
5219 c        s2=0.0
5220 c        gs2=0.0
5221         s2=scalar2(b1(1,i+1),auxvec(1))
5222 c derivative of theta i+1 with constant i+3
5223         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5224 c derivative of theta i+2 with constant i+1
5225         gs21=scalar2(b1(1,i+1),auxgvec(1))
5226 c derivative of theta i+3 with constant i+1
5227         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5228 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5229 c     &  gtb1(1,i+1)
5230         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5231 c two derivatives over diffetent matrices
5232 c gtae3e2 is derivative over i+3
5233         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5234 c ae3gte2 is derivative over i+2
5235         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5236         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5237 c three possible derivative over theta E matices
5238 c i+1
5239         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5240 c i+2
5241         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5242 c i+3
5243         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5244         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5245
5246         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5247         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5248         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5249         if (shield_mode.eq.0) then
5250         fac_shield(i)=1.0
5251         fac_shield(j)=1.0
5252 C        else
5253 C        fac_shield(i)=0.6
5254 C        fac_shield(j)=0.4
5255         endif
5256         eello_turn4=eello_turn4-(s1+s2+s3)
5257      &  *fac_shield(i)*fac_shield(j)
5258      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5259
5260         eello_t4=-(s1+s2+s3)
5261      &  *fac_shield(i)*fac_shield(j)
5262 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5263         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5264      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5265 C Now derivative over shield:
5266           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5267      &  (shield_mode.gt.0)) then
5268 C          print *,i,j
5269
5270           do ilist=1,ishield_list(i)
5271            iresshield=shield_list(ilist,i)
5272            do k=1,3
5273            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5274 C     &      *2.0
5275            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5276      &              rlocshield
5277      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5278             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5279      &      +rlocshield
5280            enddo
5281           enddo
5282           do ilist=1,ishield_list(j)
5283            iresshield=shield_list(ilist,j)
5284            do k=1,3
5285            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5286 C     &     *2.0
5287            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5288      &              rlocshield
5289      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5290            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5291      &             +rlocshield
5292
5293            enddo
5294           enddo
5295
5296           do k=1,3
5297             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5298      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5299             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5300      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5301             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5302      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5303             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5304      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5305            enddo
5306            endif
5307
5308
5309
5310
5311
5312
5313 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5314 cd     &    ' eello_turn4_num',8*eello_turn4_num
5315 #ifdef NEWCORR
5316         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5317      &                  -(gs13+gsE13+gsEE1)*wturn4
5318      &  *fac_shield(i)*fac_shield(j)
5319      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5320
5321         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5322      &                    -(gs23+gs21+gsEE2)*wturn4
5323      &  *fac_shield(i)*fac_shield(j)
5324      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5325
5326         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5327      &                    -(gs32+gsE31+gsEE3)*wturn4
5328      &  *fac_shield(i)*fac_shield(j)
5329      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5330
5331 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5332 c     &   gs2
5333 #endif
5334         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5335      &      'eturn4',i,j,-(s1+s2+s3)
5336 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 c     &    ' eello_turn4_num',8*eello_turn4_num
5338 C Derivatives in gamma(i)
5339         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5340         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5341         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5342         s1=scalar2(b1(1,i+2),auxvec(1))
5343         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5344         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5345         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5346      &  *fac_shield(i)*fac_shield(j)
5347      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5348
5349 C Derivatives in gamma(i+1)
5350         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5351         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5352         s2=scalar2(b1(1,i+1),auxvec(1))
5353         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5354         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5355         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5356         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5357      &  *fac_shield(i)*fac_shield(j)
5358      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5359
5360 C Derivatives in gamma(i+2)
5361         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5362         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5363         s1=scalar2(b1(1,i+2),auxvec(1))
5364         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5365         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5366         s2=scalar2(b1(1,i+1),auxvec(1))
5367         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5368         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5369         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5370         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5371      &  *fac_shield(i)*fac_shield(j)
5372      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5373
5374 C Cartesian derivatives
5375 C Derivatives of this turn contributions in DC(i+2)
5376         if (j.lt.nres-1) then
5377           do l=1,3
5378             a_temp(1,1)=agg(l,1)
5379             a_temp(1,2)=agg(l,2)
5380             a_temp(2,1)=agg(l,3)
5381             a_temp(2,2)=agg(l,4)
5382             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5383             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5384             s1=scalar2(b1(1,i+2),auxvec(1))
5385             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5386             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5387             s2=scalar2(b1(1,i+1),auxvec(1))
5388             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5389             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5390             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5391             ggg(l)=-(s1+s2+s3)
5392             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5393      &  *fac_shield(i)*fac_shield(j)
5394      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5395
5396           enddo
5397         endif
5398 C Remaining derivatives of this turn contribution
5399         do l=1,3
5400           a_temp(1,1)=aggi(l,1)
5401           a_temp(1,2)=aggi(l,2)
5402           a_temp(2,1)=aggi(l,3)
5403           a_temp(2,2)=aggi(l,4)
5404           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5405           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5406           s1=scalar2(b1(1,i+2),auxvec(1))
5407           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5408           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5409           s2=scalar2(b1(1,i+1),auxvec(1))
5410           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5411           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5412           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5413           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5414      &  *fac_shield(i)*fac_shield(j)
5415      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5416
5417           a_temp(1,1)=aggi1(l,1)
5418           a_temp(1,2)=aggi1(l,2)
5419           a_temp(2,1)=aggi1(l,3)
5420           a_temp(2,2)=aggi1(l,4)
5421           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5422           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5423           s1=scalar2(b1(1,i+2),auxvec(1))
5424           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5425           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5426           s2=scalar2(b1(1,i+1),auxvec(1))
5427           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5428           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5429           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5430           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5431      &  *fac_shield(i)*fac_shield(j)
5432      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5433
5434           a_temp(1,1)=aggj(l,1)
5435           a_temp(1,2)=aggj(l,2)
5436           a_temp(2,1)=aggj(l,3)
5437           a_temp(2,2)=aggj(l,4)
5438           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5439           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5440           s1=scalar2(b1(1,i+2),auxvec(1))
5441           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5442           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5443           s2=scalar2(b1(1,i+1),auxvec(1))
5444           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5445           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5446           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5447           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5448      &  *fac_shield(i)*fac_shield(j)
5449      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5450
5451           a_temp(1,1)=aggj1(l,1)
5452           a_temp(1,2)=aggj1(l,2)
5453           a_temp(2,1)=aggj1(l,3)
5454           a_temp(2,2)=aggj1(l,4)
5455           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5456           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5457           s1=scalar2(b1(1,i+2),auxvec(1))
5458           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5459           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5460           s2=scalar2(b1(1,i+1),auxvec(1))
5461           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5462           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5463           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5464 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5465           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5466      &  *fac_shield(i)*fac_shield(j)
5467      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5468         enddo
5469          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5470      &     ssgradlipi*eello_t4/4.0d0*lipscale
5471          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5472      &     ssgradlipj*eello_t4/4.0d0*lipscale
5473          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5474      &     ssgradlipi*eello_t4/4.0d0*lipscale
5475          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5476      &     ssgradlipj*eello_t4/4.0d0*lipscale
5477       return
5478       end
5479 C-----------------------------------------------------------------------------
5480       subroutine vecpr(u,v,w)
5481       implicit real*8(a-h,o-z)
5482       dimension u(3),v(3),w(3)
5483       w(1)=u(2)*v(3)-u(3)*v(2)
5484       w(2)=-u(1)*v(3)+u(3)*v(1)
5485       w(3)=u(1)*v(2)-u(2)*v(1)
5486       return
5487       end
5488 C-----------------------------------------------------------------------------
5489       subroutine unormderiv(u,ugrad,unorm,ungrad)
5490 C This subroutine computes the derivatives of a normalized vector u, given
5491 C the derivatives computed without normalization conditions, ugrad. Returns
5492 C ungrad.
5493       implicit none
5494       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5495       double precision vec(3)
5496       double precision scalar
5497       integer i,j
5498 c      write (2,*) 'ugrad',ugrad
5499 c      write (2,*) 'u',u
5500       do i=1,3
5501         vec(i)=scalar(ugrad(1,i),u(1))
5502       enddo
5503 c      write (2,*) 'vec',vec
5504       do i=1,3
5505         do j=1,3
5506           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5507         enddo
5508       enddo
5509 c      write (2,*) 'ungrad',ungrad
5510       return
5511       end
5512 C-----------------------------------------------------------------------------
5513       subroutine escp_soft_sphere(evdw2,evdw2_14)
5514 C
5515 C This subroutine calculates the excluded-volume interaction energy between
5516 C peptide-group centers and side chains and its gradient in virtual-bond and
5517 C side-chain vectors.
5518 C
5519       implicit real*8 (a-h,o-z)
5520       include 'DIMENSIONS'
5521       include 'COMMON.GEO'
5522       include 'COMMON.VAR'
5523       include 'COMMON.LOCAL'
5524       include 'COMMON.CHAIN'
5525       include 'COMMON.DERIV'
5526       include 'COMMON.INTERACT'
5527       include 'COMMON.FFIELD'
5528       include 'COMMON.IOUNITS'
5529       include 'COMMON.CONTROL'
5530       dimension ggg(3)
5531       evdw2=0.0D0
5532       evdw2_14=0.0d0
5533       r0_scp=4.5d0
5534 cd    print '(a)','Enter ESCP'
5535 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5536 C      do xshift=-1,1
5537 C      do yshift=-1,1
5538 C      do zshift=-1,1
5539       do i=iatscp_s,iatscp_e
5540         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5541         iteli=itel(i)
5542         xi=0.5D0*(c(1,i)+c(1,i+1))
5543         yi=0.5D0*(c(2,i)+c(2,i+1))
5544         zi=0.5D0*(c(3,i)+c(3,i+1))
5545 C Return atom into box, boxxsize is size of box in x dimension
5546 c  134   continue
5547 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5548 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5549 C Condition for being inside the proper box
5550 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5551 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5552 c        go to 134
5553 c        endif
5554 c  135   continue
5555 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5556 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5557 C Condition for being inside the proper box
5558 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5559 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5560 c        go to 135
5561 c c       endif
5562 c  136   continue
5563 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5564 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5565 cC Condition for being inside the proper box
5566 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5567 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5568 c        go to 136
5569 c        endif
5570           xi=mod(xi,boxxsize)
5571           if (xi.lt.0) xi=xi+boxxsize
5572           yi=mod(yi,boxysize)
5573           if (yi.lt.0) yi=yi+boxysize
5574           zi=mod(zi,boxzsize)
5575           if (zi.lt.0) zi=zi+boxzsize
5576 C          xi=xi+xshift*boxxsize
5577 C          yi=yi+yshift*boxysize
5578 C          zi=zi+zshift*boxzsize
5579         do iint=1,nscp_gr(i)
5580
5581         do j=iscpstart(i,iint),iscpend(i,iint)
5582           if (itype(j).eq.ntyp1) cycle
5583           itypj=iabs(itype(j))
5584 C Uncomment following three lines for SC-p interactions
5585 c         xj=c(1,nres+j)-xi
5586 c         yj=c(2,nres+j)-yi
5587 c         zj=c(3,nres+j)-zi
5588 C Uncomment following three lines for Ca-p interactions
5589           xj=c(1,j)
5590           yj=c(2,j)
5591           zj=c(3,j)
5592 c  174   continue
5593 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5594 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5595 C Condition for being inside the proper box
5596 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5597 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5598 c        go to 174
5599 c        endif
5600 c  175   continue
5601 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5602 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5603 cC Condition for being inside the proper box
5604 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5605 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5606 c        go to 175
5607 c        endif
5608 c  176   continue
5609 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5610 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5611 C Condition for being inside the proper box
5612 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5613 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5614 c        go to 176
5615           xj=mod(xj,boxxsize)
5616           if (xj.lt.0) xj=xj+boxxsize
5617           yj=mod(yj,boxysize)
5618           if (yj.lt.0) yj=yj+boxysize
5619           zj=mod(zj,boxzsize)
5620           if (zj.lt.0) zj=zj+boxzsize
5621       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5622       xj_safe=xj
5623       yj_safe=yj
5624       zj_safe=zj
5625       subchap=0
5626       do xshift=-1,1
5627       do yshift=-1,1
5628       do zshift=-1,1
5629           xj=xj_safe+xshift*boxxsize
5630           yj=yj_safe+yshift*boxysize
5631           zj=zj_safe+zshift*boxzsize
5632           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5633           if(dist_temp.lt.dist_init) then
5634             dist_init=dist_temp
5635             xj_temp=xj
5636             yj_temp=yj
5637             zj_temp=zj
5638             subchap=1
5639           endif
5640        enddo
5641        enddo
5642        enddo
5643        if (subchap.eq.1) then
5644           xj=xj_temp-xi
5645           yj=yj_temp-yi
5646           zj=zj_temp-zi
5647        else
5648           xj=xj_safe-xi
5649           yj=yj_safe-yi
5650           zj=zj_safe-zi
5651        endif
5652 c c       endif
5653 C          xj=xj-xi
5654 C          yj=yj-yi
5655 C          zj=zj-zi
5656           rij=xj*xj+yj*yj+zj*zj
5657
5658           r0ij=r0_scp
5659           r0ijsq=r0ij*r0ij
5660           if (rij.lt.r0ijsq) then
5661             evdwij=0.25d0*(rij-r0ijsq)**2
5662             fac=rij-r0ijsq
5663           else
5664             evdwij=0.0d0
5665             fac=0.0d0
5666           endif
5667           evdw2=evdw2+evdwij
5668 C
5669 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5670 C
5671           ggg(1)=xj*fac
5672           ggg(2)=yj*fac
5673           ggg(3)=zj*fac
5674 cgrad          if (j.lt.i) then
5675 cd          write (iout,*) 'j<i'
5676 C Uncomment following three lines for SC-p interactions
5677 c           do k=1,3
5678 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5679 c           enddo
5680 cgrad          else
5681 cd          write (iout,*) 'j>i'
5682 cgrad            do k=1,3
5683 cgrad              ggg(k)=-ggg(k)
5684 C Uncomment following line for SC-p interactions
5685 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5686 cgrad            enddo
5687 cgrad          endif
5688 cgrad          do k=1,3
5689 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5690 cgrad          enddo
5691 cgrad          kstart=min0(i+1,j)
5692 cgrad          kend=max0(i-1,j-1)
5693 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5694 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5695 cgrad          do k=kstart,kend
5696 cgrad            do l=1,3
5697 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5698 cgrad            enddo
5699 cgrad          enddo
5700           do k=1,3
5701             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5702             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5703           enddo
5704         enddo
5705
5706         enddo ! iint
5707       enddo ! i
5708 C      enddo !zshift
5709 C      enddo !yshift
5710 C      enddo !xshift
5711       return
5712       end
5713 C-----------------------------------------------------------------------------
5714       subroutine escp(evdw2,evdw2_14)
5715 C
5716 C This subroutine calculates the excluded-volume interaction energy between
5717 C peptide-group centers and side chains and its gradient in virtual-bond and
5718 C side-chain vectors.
5719 C
5720       implicit real*8 (a-h,o-z)
5721       include 'DIMENSIONS'
5722       include 'COMMON.GEO'
5723       include 'COMMON.VAR'
5724       include 'COMMON.LOCAL'
5725       include 'COMMON.CHAIN'
5726       include 'COMMON.DERIV'
5727       include 'COMMON.INTERACT'
5728       include 'COMMON.FFIELD'
5729       include 'COMMON.IOUNITS'
5730       include 'COMMON.CONTROL'
5731       include 'COMMON.SPLITELE'
5732       dimension ggg(3)
5733       evdw2=0.0D0
5734       evdw2_14=0.0d0
5735 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5736 cd    print '(a)','Enter ESCP'
5737 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5738 C      do xshift=-1,1
5739 C      do yshift=-1,1
5740 C      do zshift=-1,1
5741       do i=iatscp_s,iatscp_e
5742         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5743         iteli=itel(i)
5744         xi=0.5D0*(c(1,i)+c(1,i+1))
5745         yi=0.5D0*(c(2,i)+c(2,i+1))
5746         zi=0.5D0*(c(3,i)+c(3,i+1))
5747           xi=mod(xi,boxxsize)
5748           if (xi.lt.0) xi=xi+boxxsize
5749           yi=mod(yi,boxysize)
5750           if (yi.lt.0) yi=yi+boxysize
5751           zi=mod(zi,boxzsize)
5752           if (zi.lt.0) zi=zi+boxzsize
5753 c          xi=xi+xshift*boxxsize
5754 c          yi=yi+yshift*boxysize
5755 c          zi=zi+zshift*boxzsize
5756 c        print *,xi,yi,zi,'polozenie i'
5757 C Return atom into box, boxxsize is size of box in x dimension
5758 c  134   continue
5759 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5760 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5761 C Condition for being inside the proper box
5762 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5763 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5764 c        go to 134
5765 c        endif
5766 c  135   continue
5767 c          print *,xi,boxxsize,"pierwszy"
5768
5769 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5770 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5771 C Condition for being inside the proper box
5772 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5773 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5774 c        go to 135
5775 c        endif
5776 c  136   continue
5777 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5778 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5779 C Condition for being inside the proper box
5780 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5781 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5782 c        go to 136
5783 c        endif
5784         do iint=1,nscp_gr(i)
5785
5786         do j=iscpstart(i,iint),iscpend(i,iint)
5787           itypj=iabs(itype(j))
5788           if (itypj.eq.ntyp1) cycle
5789 C Uncomment following three lines for SC-p interactions
5790 c         xj=c(1,nres+j)-xi
5791 c         yj=c(2,nres+j)-yi
5792 c         zj=c(3,nres+j)-zi
5793 C Uncomment following three lines for Ca-p interactions
5794           xj=c(1,j)
5795           yj=c(2,j)
5796           zj=c(3,j)
5797           xj=mod(xj,boxxsize)
5798           if (xj.lt.0) xj=xj+boxxsize
5799           yj=mod(yj,boxysize)
5800           if (yj.lt.0) yj=yj+boxysize
5801           zj=mod(zj,boxzsize)
5802           if (zj.lt.0) zj=zj+boxzsize
5803 c  174   continue
5804 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5805 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5806 C Condition for being inside the proper box
5807 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5808 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5809 c        go to 174
5810 c        endif
5811 c  175   continue
5812 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5813 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5814 cC Condition for being inside the proper box
5815 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5816 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5817 c        go to 175
5818 c        endif
5819 c  176   continue
5820 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5821 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5822 C Condition for being inside the proper box
5823 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5824 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5825 c        go to 176
5826 c        endif
5827 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5828       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5829       xj_safe=xj
5830       yj_safe=yj
5831       zj_safe=zj
5832       subchap=0
5833       do xshift=-1,1
5834       do yshift=-1,1
5835       do zshift=-1,1
5836           xj=xj_safe+xshift*boxxsize
5837           yj=yj_safe+yshift*boxysize
5838           zj=zj_safe+zshift*boxzsize
5839           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5840           if(dist_temp.lt.dist_init) then
5841             dist_init=dist_temp
5842             xj_temp=xj
5843             yj_temp=yj
5844             zj_temp=zj
5845             subchap=1
5846           endif
5847        enddo
5848        enddo
5849        enddo
5850        if (subchap.eq.1) then
5851           xj=xj_temp-xi
5852           yj=yj_temp-yi
5853           zj=zj_temp-zi
5854        else
5855           xj=xj_safe-xi
5856           yj=yj_safe-yi
5857           zj=zj_safe-zi
5858        endif
5859 c          print *,xj,yj,zj,'polozenie j'
5860           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5861 c          print *,rrij
5862           sss=sscale(1.0d0/(dsqrt(rrij)))
5863 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5864 c          if (sss.eq.0) print *,'czasem jest OK'
5865           if (sss.le.0.0d0) cycle
5866           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5867           fac=rrij**expon2
5868           e1=fac*fac*aad(itypj,iteli)
5869           e2=fac*bad(itypj,iteli)
5870           if (iabs(j-i) .le. 2) then
5871             e1=scal14*e1
5872             e2=scal14*e2
5873             evdw2_14=evdw2_14+(e1+e2)*sss
5874           endif
5875           evdwij=e1+e2
5876           evdw2=evdw2+evdwij*sss
5877           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5878      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5879      &       bad(itypj,iteli)
5880 C
5881 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5882 C
5883           fac=-(evdwij+e1)*rrij*sss
5884           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5885           ggg(1)=xj*fac
5886           ggg(2)=yj*fac
5887           ggg(3)=zj*fac
5888 cgrad          if (j.lt.i) then
5889 cd          write (iout,*) 'j<i'
5890 C Uncomment following three lines for SC-p interactions
5891 c           do k=1,3
5892 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5893 c           enddo
5894 cgrad          else
5895 cd          write (iout,*) 'j>i'
5896 cgrad            do k=1,3
5897 cgrad              ggg(k)=-ggg(k)
5898 C Uncomment following line for SC-p interactions
5899 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5900 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5901 cgrad            enddo
5902 cgrad          endif
5903 cgrad          do k=1,3
5904 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5905 cgrad          enddo
5906 cgrad          kstart=min0(i+1,j)
5907 cgrad          kend=max0(i-1,j-1)
5908 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5909 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5910 cgrad          do k=kstart,kend
5911 cgrad            do l=1,3
5912 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5913 cgrad            enddo
5914 cgrad          enddo
5915           do k=1,3
5916             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5917             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5918           enddo
5919 c        endif !endif for sscale cutoff
5920         enddo ! j
5921
5922         enddo ! iint
5923       enddo ! i
5924 c      enddo !zshift
5925 c      enddo !yshift
5926 c      enddo !xshift
5927       do i=1,nct
5928         do j=1,3
5929           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5930           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5931           gradx_scp(j,i)=expon*gradx_scp(j,i)
5932         enddo
5933       enddo
5934 C******************************************************************************
5935 C
5936 C                              N O T E !!!
5937 C
5938 C To save time the factor EXPON has been extracted from ALL components
5939 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5940 C use!
5941 C
5942 C******************************************************************************
5943       return
5944       end
5945 C--------------------------------------------------------------------------
5946       subroutine edis(ehpb)
5947 C
5948 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5949 C
5950       implicit real*8 (a-h,o-z)
5951       include 'DIMENSIONS'
5952       include 'COMMON.SBRIDGE'
5953       include 'COMMON.CHAIN'
5954       include 'COMMON.DERIV'
5955       include 'COMMON.VAR'
5956       include 'COMMON.INTERACT'
5957       include 'COMMON.IOUNITS'
5958       include 'COMMON.CONTROL'
5959       dimension ggg(3)
5960       ehpb=0.0D0
5961       do i=1,3
5962        ggg(i)=0.0d0
5963       enddo
5964 C      write (iout,*) ,"link_end",link_end,constr_dist
5965 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5966 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5967       if (link_end.eq.0) return
5968       do i=link_start,link_end
5969 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5970 C CA-CA distance used in regularization of structure.
5971         ii=ihpb(i)
5972         jj=jhpb(i)
5973 C iii and jjj point to the residues for which the distance is assigned.
5974         if (ii.gt.nres) then
5975           iii=ii-nres
5976           jjj=jj-nres
5977         else
5978           iii=ii
5979           jjj=jj
5980         endif
5981 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5982 c     &    dhpb(i),dhpb1(i),forcon(i)
5983 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5984 C    distance and angle dependent SS bond potential.
5985 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5986 C     & iabs(itype(jjj)).eq.1) then
5987 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5988 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5989         if (.not.dyn_ss .and. i.le.nss) then
5990 C 15/02/13 CC dynamic SSbond - additional check
5991          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5992      & iabs(itype(jjj)).eq.1) then
5993           call ssbond_ene(iii,jjj,eij)
5994           ehpb=ehpb+2*eij
5995          endif
5996 cd          write (iout,*) "eij",eij
5997 cd   &   ' waga=',waga,' fac=',fac
5998         else if (ii.gt.nres .and. jj.gt.nres) then
5999 c Restraints from contact prediction
6000           dd=dist(ii,jj)
6001           if (constr_dist.eq.11) then
6002             ehpb=ehpb+fordepth(i)**4.0d0
6003      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6004             fac=fordepth(i)**4.0d0
6005      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6006           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6007      &    ehpb,fordepth(i),dd
6008            else
6009           if (dhpb1(i).gt.0.0d0) then
6010             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6011             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6012 c            write (iout,*) "beta nmr",
6013 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6014           else
6015             dd=dist(ii,jj)
6016             rdis=dd-dhpb(i)
6017 C Get the force constant corresponding to this distance.
6018             waga=forcon(i)
6019 C Calculate the contribution to energy.
6020             ehpb=ehpb+waga*rdis*rdis
6021 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6022 C
6023 C Evaluate gradient.
6024 C
6025             fac=waga*rdis/dd
6026           endif
6027           endif
6028           do j=1,3
6029             ggg(j)=fac*(c(j,jj)-c(j,ii))
6030           enddo
6031           do j=1,3
6032             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6033             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6034           enddo
6035           do k=1,3
6036             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6037             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6038           enddo
6039         else
6040 C Calculate the distance between the two points and its difference from the
6041 C target distance.
6042           dd=dist(ii,jj)
6043           if (constr_dist.eq.11) then
6044             ehpb=ehpb+fordepth(i)**4.0d0
6045      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6046             fac=fordepth(i)**4.0d0
6047      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6048           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6049      &    ehpb,fordepth(i),dd
6050            else
6051           if (dhpb1(i).gt.0.0d0) then
6052             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6053             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6054 c            write (iout,*) "alph nmr",
6055 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6056           else
6057             rdis=dd-dhpb(i)
6058 C Get the force constant corresponding to this distance.
6059             waga=forcon(i)
6060 C Calculate the contribution to energy.
6061             ehpb=ehpb+waga*rdis*rdis
6062 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6063 C
6064 C Evaluate gradient.
6065 C
6066             fac=waga*rdis/dd
6067           endif
6068           endif
6069             do j=1,3
6070               ggg(j)=fac*(c(j,jj)-c(j,ii))
6071             enddo
6072 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6073 C If this is a SC-SC distance, we need to calculate the contributions to the
6074 C Cartesian gradient in the SC vectors (ghpbx).
6075           if (iii.lt.ii) then
6076           do j=1,3
6077             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6078             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6079           enddo
6080           endif
6081 cgrad        do j=iii,jjj-1
6082 cgrad          do k=1,3
6083 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6084 cgrad          enddo
6085 cgrad        enddo
6086           do k=1,3
6087             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6088             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6089           enddo
6090         endif
6091       enddo
6092       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6093       return
6094       end
6095 C--------------------------------------------------------------------------
6096       subroutine ssbond_ene(i,j,eij)
6097 C
6098 C Calculate the distance and angle dependent SS-bond potential energy
6099 C using a free-energy function derived based on RHF/6-31G** ab initio
6100 C calculations of diethyl disulfide.
6101 C
6102 C A. Liwo and U. Kozlowska, 11/24/03
6103 C
6104       implicit real*8 (a-h,o-z)
6105       include 'DIMENSIONS'
6106       include 'COMMON.SBRIDGE'
6107       include 'COMMON.CHAIN'
6108       include 'COMMON.DERIV'
6109       include 'COMMON.LOCAL'
6110       include 'COMMON.INTERACT'
6111       include 'COMMON.VAR'
6112       include 'COMMON.IOUNITS'
6113       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6114       itypi=iabs(itype(i))
6115       xi=c(1,nres+i)
6116       yi=c(2,nres+i)
6117       zi=c(3,nres+i)
6118       dxi=dc_norm(1,nres+i)
6119       dyi=dc_norm(2,nres+i)
6120       dzi=dc_norm(3,nres+i)
6121 c      dsci_inv=dsc_inv(itypi)
6122       dsci_inv=vbld_inv(nres+i)
6123       itypj=iabs(itype(j))
6124 c      dscj_inv=dsc_inv(itypj)
6125       dscj_inv=vbld_inv(nres+j)
6126       xj=c(1,nres+j)-xi
6127       yj=c(2,nres+j)-yi
6128       zj=c(3,nres+j)-zi
6129       dxj=dc_norm(1,nres+j)
6130       dyj=dc_norm(2,nres+j)
6131       dzj=dc_norm(3,nres+j)
6132       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6133       rij=dsqrt(rrij)
6134       erij(1)=xj*rij
6135       erij(2)=yj*rij
6136       erij(3)=zj*rij
6137       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6138       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6139       om12=dxi*dxj+dyi*dyj+dzi*dzj
6140       do k=1,3
6141         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6142         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6143       enddo
6144       rij=1.0d0/rij
6145       deltad=rij-d0cm
6146       deltat1=1.0d0-om1
6147       deltat2=1.0d0+om2
6148       deltat12=om2-om1+2.0d0
6149       cosphi=om12-om1*om2
6150       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6151      &  +akct*deltad*deltat12
6152      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6153 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6154 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6155 c     &  " deltat12",deltat12," eij",eij
6156       ed=2*akcm*deltad+akct*deltat12
6157       pom1=akct*deltad
6158       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6159       eom1=-2*akth*deltat1-pom1-om2*pom2
6160       eom2= 2*akth*deltat2+pom1-om1*pom2
6161       eom12=pom2
6162       do k=1,3
6163         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6164         ghpbx(k,i)=ghpbx(k,i)-ggk
6165      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6166      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6167         ghpbx(k,j)=ghpbx(k,j)+ggk
6168      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6169      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6170         ghpbc(k,i)=ghpbc(k,i)-ggk
6171         ghpbc(k,j)=ghpbc(k,j)+ggk
6172       enddo
6173 C
6174 C Calculate the components of the gradient in DC and X
6175 C
6176 cgrad      do k=i,j-1
6177 cgrad        do l=1,3
6178 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6179 cgrad        enddo
6180 cgrad      enddo
6181       return
6182       end
6183 C--------------------------------------------------------------------------
6184       subroutine ebond(estr)
6185 c
6186 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6187 c
6188       implicit real*8 (a-h,o-z)
6189       include 'DIMENSIONS'
6190       include 'COMMON.LOCAL'
6191       include 'COMMON.GEO'
6192       include 'COMMON.INTERACT'
6193       include 'COMMON.DERIV'
6194       include 'COMMON.VAR'
6195       include 'COMMON.CHAIN'
6196       include 'COMMON.IOUNITS'
6197       include 'COMMON.NAMES'
6198       include 'COMMON.FFIELD'
6199       include 'COMMON.CONTROL'
6200       include 'COMMON.SETUP'
6201       double precision u(3),ud(3)
6202       estr=0.0d0
6203       estr1=0.0d0
6204       do i=ibondp_start,ibondp_end
6205         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6206 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6207 c          do j=1,3
6208 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6209 c     &      *dc(j,i-1)/vbld(i)
6210 c          enddo
6211 c          if (energy_dec) write(iout,*)
6212 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6213 c        else
6214 C       Checking if it involves dummy (NH3+ or COO-) group
6215          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6216 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6217         diff = vbld(i)-vbldpDUM
6218         if (energy_dec) write(iout,*) "dum_bond",i,diff
6219          else
6220 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6221         diff = vbld(i)-vbldp0
6222          endif
6223         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6224      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6225         estr=estr+diff*diff
6226         do j=1,3
6227           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6228         enddo
6229 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6230 c        endif
6231       enddo
6232
6233       estr=0.5d0*AKP*estr+estr1
6234 c
6235 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6236 c
6237       do i=ibond_start,ibond_end
6238         iti=iabs(itype(i))
6239         if (iti.ne.10 .and. iti.ne.ntyp1) then
6240           nbi=nbondterm(iti)
6241           if (nbi.eq.1) then
6242             diff=vbld(i+nres)-vbldsc0(1,iti)
6243             if (energy_dec)  write (iout,*)
6244      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6245      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6246             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6247             do j=1,3
6248               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6249             enddo
6250           else
6251             do j=1,nbi
6252               diff=vbld(i+nres)-vbldsc0(j,iti)
6253               ud(j)=aksc(j,iti)*diff
6254               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6255             enddo
6256             uprod=u(1)
6257             do j=2,nbi
6258               uprod=uprod*u(j)
6259             enddo
6260             usum=0.0d0
6261             usumsqder=0.0d0
6262             do j=1,nbi
6263               uprod1=1.0d0
6264               uprod2=1.0d0
6265               do k=1,nbi
6266                 if (k.ne.j) then
6267                   uprod1=uprod1*u(k)
6268                   uprod2=uprod2*u(k)*u(k)
6269                 endif
6270               enddo
6271               usum=usum+uprod1
6272               usumsqder=usumsqder+ud(j)*uprod2
6273             enddo
6274             estr=estr+uprod/usum
6275             do j=1,3
6276              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6277             enddo
6278           endif
6279         endif
6280       enddo
6281       return
6282       end
6283 #ifdef CRYST_THETA
6284 C--------------------------------------------------------------------------
6285       subroutine ebend(etheta,ethetacnstr)
6286 C
6287 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6288 C angles gamma and its derivatives in consecutive thetas and gammas.
6289 C
6290       implicit real*8 (a-h,o-z)
6291       include 'DIMENSIONS'
6292       include 'COMMON.LOCAL'
6293       include 'COMMON.GEO'
6294       include 'COMMON.INTERACT'
6295       include 'COMMON.DERIV'
6296       include 'COMMON.VAR'
6297       include 'COMMON.CHAIN'
6298       include 'COMMON.IOUNITS'
6299       include 'COMMON.NAMES'
6300       include 'COMMON.FFIELD'
6301       include 'COMMON.CONTROL'
6302       include 'COMMON.TORCNSTR'
6303       common /calcthet/ term1,term2,termm,diffak,ratak,
6304      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6305      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6306       double precision y(2),z(2)
6307       delta=0.02d0*pi
6308 c      time11=dexp(-2*time)
6309 c      time12=1.0d0
6310       etheta=0.0D0
6311 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6312       do i=ithet_start,ithet_end
6313         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6314      &  .or.itype(i).eq.ntyp1) cycle
6315 C Zero the energy function and its derivative at 0 or pi.
6316         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6317         it=itype(i-1)
6318         ichir1=isign(1,itype(i-2))
6319         ichir2=isign(1,itype(i))
6320          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6321          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6322          if (itype(i-1).eq.10) then
6323           itype1=isign(10,itype(i-2))
6324           ichir11=isign(1,itype(i-2))
6325           ichir12=isign(1,itype(i-2))
6326           itype2=isign(10,itype(i))
6327           ichir21=isign(1,itype(i))
6328           ichir22=isign(1,itype(i))
6329          endif
6330
6331         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6332 #ifdef OSF
6333           phii=phi(i)
6334           if (phii.ne.phii) phii=150.0
6335 #else
6336           phii=phi(i)
6337 #endif
6338           y(1)=dcos(phii)
6339           y(2)=dsin(phii)
6340         else
6341           y(1)=0.0D0
6342           y(2)=0.0D0
6343         endif
6344         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6345 #ifdef OSF
6346           phii1=phi(i+1)
6347           if (phii1.ne.phii1) phii1=150.0
6348           phii1=pinorm(phii1)
6349           z(1)=cos(phii1)
6350 #else
6351           phii1=phi(i+1)
6352 #endif
6353           z(1)=dcos(phii1)
6354           z(2)=dsin(phii1)
6355         else
6356           z(1)=0.0D0
6357           z(2)=0.0D0
6358         endif
6359 C Calculate the "mean" value of theta from the part of the distribution
6360 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6361 C In following comments this theta will be referred to as t_c.
6362         thet_pred_mean=0.0d0
6363         do k=1,2
6364             athetk=athet(k,it,ichir1,ichir2)
6365             bthetk=bthet(k,it,ichir1,ichir2)
6366           if (it.eq.10) then
6367              athetk=athet(k,itype1,ichir11,ichir12)
6368              bthetk=bthet(k,itype2,ichir21,ichir22)
6369           endif
6370          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6371 c         write(iout,*) 'chuj tu', y(k),z(k)
6372         enddo
6373         dthett=thet_pred_mean*ssd
6374         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6375 C Derivatives of the "mean" values in gamma1 and gamma2.
6376         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6377      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6378          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6379      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6380          if (it.eq.10) then
6381       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6382      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6383         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6384      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6385          endif
6386         if (theta(i).gt.pi-delta) then
6387           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6388      &         E_tc0)
6389           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6390           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6391           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6392      &        E_theta)
6393           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6394      &        E_tc)
6395         else if (theta(i).lt.delta) then
6396           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6397           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6398           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6399      &        E_theta)
6400           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6401           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6402      &        E_tc)
6403         else
6404           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6405      &        E_theta,E_tc)
6406         endif
6407         etheta=etheta+ethetai
6408         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6409      &      'ebend',i,ethetai,theta(i),itype(i)
6410         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6411         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6412         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6413       enddo
6414       ethetacnstr=0.0d0
6415 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6416       do i=ithetaconstr_start,ithetaconstr_end
6417         itheta=itheta_constr(i)
6418         thetiii=theta(itheta)
6419         difi=pinorm(thetiii-theta_constr0(i))
6420         if (difi.gt.theta_drange(i)) then
6421           difi=difi-theta_drange(i)
6422           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6423           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6424      &    +for_thet_constr(i)*difi**3
6425         else if (difi.lt.-drange(i)) then
6426           difi=difi+drange(i)
6427           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6428           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6429      &    +for_thet_constr(i)*difi**3
6430         else
6431           difi=0.0
6432         endif
6433        if (energy_dec) then
6434         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6435      &    i,itheta,rad2deg*thetiii,
6436      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6437      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6438      &    gloc(itheta+nphi-2,icg)
6439         endif
6440       enddo
6441
6442 C Ufff.... We've done all this!!!
6443       return
6444       end
6445 C---------------------------------------------------------------------------
6446       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6447      &     E_tc)
6448       implicit real*8 (a-h,o-z)
6449       include 'DIMENSIONS'
6450       include 'COMMON.LOCAL'
6451       include 'COMMON.IOUNITS'
6452       common /calcthet/ term1,term2,termm,diffak,ratak,
6453      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6454      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6455 C Calculate the contributions to both Gaussian lobes.
6456 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6457 C The "polynomial part" of the "standard deviation" of this part of
6458 C the distributioni.
6459 ccc        write (iout,*) thetai,thet_pred_mean
6460         sig=polthet(3,it)
6461         do j=2,0,-1
6462           sig=sig*thet_pred_mean+polthet(j,it)
6463         enddo
6464 C Derivative of the "interior part" of the "standard deviation of the"
6465 C gamma-dependent Gaussian lobe in t_c.
6466         sigtc=3*polthet(3,it)
6467         do j=2,1,-1
6468           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6469         enddo
6470         sigtc=sig*sigtc
6471 C Set the parameters of both Gaussian lobes of the distribution.
6472 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6473         fac=sig*sig+sigc0(it)
6474         sigcsq=fac+fac
6475         sigc=1.0D0/sigcsq
6476 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6477         sigsqtc=-4.0D0*sigcsq*sigtc
6478 c       print *,i,sig,sigtc,sigsqtc
6479 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6480         sigtc=-sigtc/(fac*fac)
6481 C Following variable is sigma(t_c)**(-2)
6482         sigcsq=sigcsq*sigcsq
6483         sig0i=sig0(it)
6484         sig0inv=1.0D0/sig0i**2
6485         delthec=thetai-thet_pred_mean
6486         delthe0=thetai-theta0i
6487         term1=-0.5D0*sigcsq*delthec*delthec
6488         term2=-0.5D0*sig0inv*delthe0*delthe0
6489 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6490 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6491 C NaNs in taking the logarithm. We extract the largest exponent which is added
6492 C to the energy (this being the log of the distribution) at the end of energy
6493 C term evaluation for this virtual-bond angle.
6494         if (term1.gt.term2) then
6495           termm=term1
6496           term2=dexp(term2-termm)
6497           term1=1.0d0
6498         else
6499           termm=term2
6500           term1=dexp(term1-termm)
6501           term2=1.0d0
6502         endif
6503 C The ratio between the gamma-independent and gamma-dependent lobes of
6504 C the distribution is a Gaussian function of thet_pred_mean too.
6505         diffak=gthet(2,it)-thet_pred_mean
6506         ratak=diffak/gthet(3,it)**2
6507         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6508 C Let's differentiate it in thet_pred_mean NOW.
6509         aktc=ak*ratak
6510 C Now put together the distribution terms to make complete distribution.
6511         termexp=term1+ak*term2
6512         termpre=sigc+ak*sig0i
6513 C Contribution of the bending energy from this theta is just the -log of
6514 C the sum of the contributions from the two lobes and the pre-exponential
6515 C factor. Simple enough, isn't it?
6516         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6517 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6518 C NOW the derivatives!!!
6519 C 6/6/97 Take into account the deformation.
6520         E_theta=(delthec*sigcsq*term1
6521      &       +ak*delthe0*sig0inv*term2)/termexp
6522         E_tc=((sigtc+aktc*sig0i)/termpre
6523      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6524      &       aktc*term2)/termexp)
6525       return
6526       end
6527 c-----------------------------------------------------------------------------
6528       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6529       implicit real*8 (a-h,o-z)
6530       include 'DIMENSIONS'
6531       include 'COMMON.LOCAL'
6532       include 'COMMON.IOUNITS'
6533       common /calcthet/ term1,term2,termm,diffak,ratak,
6534      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6535      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6536       delthec=thetai-thet_pred_mean
6537       delthe0=thetai-theta0i
6538 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6539       t3 = thetai-thet_pred_mean
6540       t6 = t3**2
6541       t9 = term1
6542       t12 = t3*sigcsq
6543       t14 = t12+t6*sigsqtc
6544       t16 = 1.0d0
6545       t21 = thetai-theta0i
6546       t23 = t21**2
6547       t26 = term2
6548       t27 = t21*t26
6549       t32 = termexp
6550       t40 = t32**2
6551       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6552      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6553      & *(-t12*t9-ak*sig0inv*t27)
6554       return
6555       end
6556 #else
6557 C--------------------------------------------------------------------------
6558       subroutine ebend(etheta,ethetacnstr)
6559 C
6560 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6561 C angles gamma and its derivatives in consecutive thetas and gammas.
6562 C ab initio-derived potentials from
6563 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6564 C
6565       implicit real*8 (a-h,o-z)
6566       include 'DIMENSIONS'
6567       include 'COMMON.LOCAL'
6568       include 'COMMON.GEO'
6569       include 'COMMON.INTERACT'
6570       include 'COMMON.DERIV'
6571       include 'COMMON.VAR'
6572       include 'COMMON.CHAIN'
6573       include 'COMMON.IOUNITS'
6574       include 'COMMON.NAMES'
6575       include 'COMMON.FFIELD'
6576       include 'COMMON.CONTROL'
6577       include 'COMMON.TORCNSTR'
6578       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6579      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6580      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6581      & sinph1ph2(maxdouble,maxdouble)
6582       logical lprn /.false./, lprn1 /.false./
6583       etheta=0.0D0
6584       do i=ithet_start,ithet_end
6585 c        print *,i,itype(i-1),itype(i),itype(i-2)
6586         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6587      &  .or.itype(i).eq.ntyp1) cycle
6588 C        print *,i,theta(i)
6589         if (iabs(itype(i+1)).eq.20) iblock=2
6590         if (iabs(itype(i+1)).ne.20) iblock=1
6591         dethetai=0.0d0
6592         dephii=0.0d0
6593         dephii1=0.0d0
6594         theti2=0.5d0*theta(i)
6595         ityp2=ithetyp((itype(i-1)))
6596         do k=1,nntheterm
6597           coskt(k)=dcos(k*theti2)
6598           sinkt(k)=dsin(k*theti2)
6599         enddo
6600 C        print *,ethetai
6601         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6602 #ifdef OSF
6603           phii=phi(i)
6604           if (phii.ne.phii) phii=150.0
6605 #else
6606           phii=phi(i)
6607 #endif
6608           ityp1=ithetyp((itype(i-2)))
6609 C propagation of chirality for glycine type
6610           do k=1,nsingle
6611             cosph1(k)=dcos(k*phii)
6612             sinph1(k)=dsin(k*phii)
6613           enddo
6614         else
6615           phii=0.0d0
6616           do k=1,nsingle
6617           ityp1=ithetyp((itype(i-2)))
6618             cosph1(k)=0.0d0
6619             sinph1(k)=0.0d0
6620           enddo
6621         endif
6622         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6623 #ifdef OSF
6624           phii1=phi(i+1)
6625           if (phii1.ne.phii1) phii1=150.0
6626           phii1=pinorm(phii1)
6627 #else
6628           phii1=phi(i+1)
6629 #endif
6630           ityp3=ithetyp((itype(i)))
6631           do k=1,nsingle
6632             cosph2(k)=dcos(k*phii1)
6633             sinph2(k)=dsin(k*phii1)
6634           enddo
6635         else
6636           phii1=0.0d0
6637           ityp3=ithetyp((itype(i)))
6638           do k=1,nsingle
6639             cosph2(k)=0.0d0
6640             sinph2(k)=0.0d0
6641           enddo
6642         endif
6643         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6644         do k=1,ndouble
6645           do l=1,k-1
6646             ccl=cosph1(l)*cosph2(k-l)
6647             ssl=sinph1(l)*sinph2(k-l)
6648             scl=sinph1(l)*cosph2(k-l)
6649             csl=cosph1(l)*sinph2(k-l)
6650             cosph1ph2(l,k)=ccl-ssl
6651             cosph1ph2(k,l)=ccl+ssl
6652             sinph1ph2(l,k)=scl+csl
6653             sinph1ph2(k,l)=scl-csl
6654           enddo
6655         enddo
6656         if (lprn) then
6657         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6658      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6659         write (iout,*) "coskt and sinkt"
6660         do k=1,nntheterm
6661           write (iout,*) k,coskt(k),sinkt(k)
6662         enddo
6663         endif
6664         do k=1,ntheterm
6665           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6666           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6667      &      *coskt(k)
6668           if (lprn)
6669      &    write (iout,*) "k",k,"
6670      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6671      &     " ethetai",ethetai
6672         enddo
6673         if (lprn) then
6674         write (iout,*) "cosph and sinph"
6675         do k=1,nsingle
6676           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6677         enddo
6678         write (iout,*) "cosph1ph2 and sinph2ph2"
6679         do k=2,ndouble
6680           do l=1,k-1
6681             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6682      &         sinph1ph2(l,k),sinph1ph2(k,l)
6683           enddo
6684         enddo
6685         write(iout,*) "ethetai",ethetai
6686         endif
6687 C       print *,ethetai
6688         do m=1,ntheterm2
6689           do k=1,nsingle
6690             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6691      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6692      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6693      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6694             ethetai=ethetai+sinkt(m)*aux
6695             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6696             dephii=dephii+k*sinkt(m)*(
6697      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6698      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6699             dephii1=dephii1+k*sinkt(m)*(
6700      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6701      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6702             if (lprn)
6703      &      write (iout,*) "m",m," k",k," bbthet",
6704      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6705      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6706      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6707      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6708 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6709           enddo
6710         enddo
6711 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6712 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6713 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6714 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6715         if (lprn)
6716      &  write(iout,*) "ethetai",ethetai
6717 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6718         do m=1,ntheterm3
6719           do k=2,ndouble
6720             do l=1,k-1
6721               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6722      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6723      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6724      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6725               ethetai=ethetai+sinkt(m)*aux
6726               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6727               dephii=dephii+l*sinkt(m)*(
6728      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6729      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6730      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6731      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6732               dephii1=dephii1+(k-l)*sinkt(m)*(
6733      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6734      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6735      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6736      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6737               if (lprn) then
6738               write (iout,*) "m",m," k",k," l",l," ffthet",
6739      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6740      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6741      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6742      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6743      &            " ethetai",ethetai
6744               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6745      &            cosph1ph2(k,l)*sinkt(m),
6746      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6747               endif
6748             enddo
6749           enddo
6750         enddo
6751 10      continue
6752 c        lprn1=.true.
6753 C        print *,ethetai
6754         if (lprn1)
6755      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6756      &   i,theta(i)*rad2deg,phii*rad2deg,
6757      &   phii1*rad2deg,ethetai
6758 c        lprn1=.false.
6759         etheta=etheta+ethetai
6760         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6761         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6762         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6763       enddo
6764 C now constrains
6765       ethetacnstr=0.0d0
6766 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6767       do i=ithetaconstr_start,ithetaconstr_end
6768         itheta=itheta_constr(i)
6769         thetiii=theta(itheta)
6770         difi=pinorm(thetiii-theta_constr0(i))
6771         if (difi.gt.theta_drange(i)) then
6772           difi=difi-theta_drange(i)
6773           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6774           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6775      &    +for_thet_constr(i)*difi**3
6776         else if (difi.lt.-drange(i)) then
6777           difi=difi+drange(i)
6778           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6779           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6780      &    +for_thet_constr(i)*difi**3
6781         else
6782           difi=0.0
6783         endif
6784        if (energy_dec) then
6785         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6786      &    i,itheta,rad2deg*thetiii,
6787      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6788      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6789      &    gloc(itheta+nphi-2,icg)
6790         endif
6791       enddo
6792
6793       return
6794       end
6795 #endif
6796 #ifdef CRYST_SC
6797 c-----------------------------------------------------------------------------
6798       subroutine esc(escloc)
6799 C Calculate the local energy of a side chain and its derivatives in the
6800 C corresponding virtual-bond valence angles THETA and the spherical angles
6801 C ALPHA and OMEGA.
6802       implicit real*8 (a-h,o-z)
6803       include 'DIMENSIONS'
6804       include 'COMMON.GEO'
6805       include 'COMMON.LOCAL'
6806       include 'COMMON.VAR'
6807       include 'COMMON.INTERACT'
6808       include 'COMMON.DERIV'
6809       include 'COMMON.CHAIN'
6810       include 'COMMON.IOUNITS'
6811       include 'COMMON.NAMES'
6812       include 'COMMON.FFIELD'
6813       include 'COMMON.CONTROL'
6814       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6815      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6816       common /sccalc/ time11,time12,time112,theti,it,nlobit
6817       delta=0.02d0*pi
6818       escloc=0.0D0
6819 c     write (iout,'(a)') 'ESC'
6820       do i=loc_start,loc_end
6821         it=itype(i)
6822         if (it.eq.ntyp1) cycle
6823         if (it.eq.10) goto 1
6824         nlobit=nlob(iabs(it))
6825 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6826 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6827         theti=theta(i+1)-pipol
6828         x(1)=dtan(theti)
6829         x(2)=alph(i)
6830         x(3)=omeg(i)
6831
6832         if (x(2).gt.pi-delta) then
6833           xtemp(1)=x(1)
6834           xtemp(2)=pi-delta
6835           xtemp(3)=x(3)
6836           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6837           xtemp(2)=pi
6838           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6839           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6840      &        escloci,dersc(2))
6841           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6842      &        ddersc0(1),dersc(1))
6843           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6844      &        ddersc0(3),dersc(3))
6845           xtemp(2)=pi-delta
6846           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6847           xtemp(2)=pi
6848           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6849           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6850      &            dersc0(2),esclocbi,dersc02)
6851           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6852      &            dersc12,dersc01)
6853           call splinthet(x(2),0.5d0*delta,ss,ssd)
6854           dersc0(1)=dersc01
6855           dersc0(2)=dersc02
6856           dersc0(3)=0.0d0
6857           do k=1,3
6858             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6859           enddo
6860           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6861 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6862 c    &             esclocbi,ss,ssd
6863           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6864 c         escloci=esclocbi
6865 c         write (iout,*) escloci
6866         else if (x(2).lt.delta) then
6867           xtemp(1)=x(1)
6868           xtemp(2)=delta
6869           xtemp(3)=x(3)
6870           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6871           xtemp(2)=0.0d0
6872           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6873           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6874      &        escloci,dersc(2))
6875           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6876      &        ddersc0(1),dersc(1))
6877           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6878      &        ddersc0(3),dersc(3))
6879           xtemp(2)=delta
6880           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6881           xtemp(2)=0.0d0
6882           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6883           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6884      &            dersc0(2),esclocbi,dersc02)
6885           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6886      &            dersc12,dersc01)
6887           dersc0(1)=dersc01
6888           dersc0(2)=dersc02
6889           dersc0(3)=0.0d0
6890           call splinthet(x(2),0.5d0*delta,ss,ssd)
6891           do k=1,3
6892             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6893           enddo
6894           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6895 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6896 c    &             esclocbi,ss,ssd
6897           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6898 c         write (iout,*) escloci
6899         else
6900           call enesc(x,escloci,dersc,ddummy,.false.)
6901         endif
6902
6903         escloc=escloc+escloci
6904         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6905      &     'escloc',i,escloci
6906 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6907
6908         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6909      &   wscloc*dersc(1)
6910         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6911         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6912     1   continue
6913       enddo
6914       return
6915       end
6916 C---------------------------------------------------------------------------
6917       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6918       implicit real*8 (a-h,o-z)
6919       include 'DIMENSIONS'
6920       include 'COMMON.GEO'
6921       include 'COMMON.LOCAL'
6922       include 'COMMON.IOUNITS'
6923       common /sccalc/ time11,time12,time112,theti,it,nlobit
6924       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6925       double precision contr(maxlob,-1:1)
6926       logical mixed
6927 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6928         escloc_i=0.0D0
6929         do j=1,3
6930           dersc(j)=0.0D0
6931           if (mixed) ddersc(j)=0.0d0
6932         enddo
6933         x3=x(3)
6934
6935 C Because of periodicity of the dependence of the SC energy in omega we have
6936 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6937 C To avoid underflows, first compute & store the exponents.
6938
6939         do iii=-1,1
6940
6941           x(3)=x3+iii*dwapi
6942
6943           do j=1,nlobit
6944             do k=1,3
6945               z(k)=x(k)-censc(k,j,it)
6946             enddo
6947             do k=1,3
6948               Axk=0.0D0
6949               do l=1,3
6950                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6951               enddo
6952               Ax(k,j,iii)=Axk
6953             enddo
6954             expfac=0.0D0
6955             do k=1,3
6956               expfac=expfac+Ax(k,j,iii)*z(k)
6957             enddo
6958             contr(j,iii)=expfac
6959           enddo ! j
6960
6961         enddo ! iii
6962
6963         x(3)=x3
6964 C As in the case of ebend, we want to avoid underflows in exponentiation and
6965 C subsequent NaNs and INFs in energy calculation.
6966 C Find the largest exponent
6967         emin=contr(1,-1)
6968         do iii=-1,1
6969           do j=1,nlobit
6970             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6971           enddo
6972         enddo
6973         emin=0.5D0*emin
6974 cd      print *,'it=',it,' emin=',emin
6975
6976 C Compute the contribution to SC energy and derivatives
6977         do iii=-1,1
6978
6979           do j=1,nlobit
6980 #ifdef OSF
6981             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6982             if(adexp.ne.adexp) adexp=1.0
6983             expfac=dexp(adexp)
6984 #else
6985             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6986 #endif
6987 cd          print *,'j=',j,' expfac=',expfac
6988             escloc_i=escloc_i+expfac
6989             do k=1,3
6990               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6991             enddo
6992             if (mixed) then
6993               do k=1,3,2
6994                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6995      &            +gaussc(k,2,j,it))*expfac
6996               enddo
6997             endif
6998           enddo
6999
7000         enddo ! iii
7001
7002         dersc(1)=dersc(1)/cos(theti)**2
7003         ddersc(1)=ddersc(1)/cos(theti)**2
7004         ddersc(3)=ddersc(3)
7005
7006         escloci=-(dlog(escloc_i)-emin)
7007         do j=1,3
7008           dersc(j)=dersc(j)/escloc_i
7009         enddo
7010         if (mixed) then
7011           do j=1,3,2
7012             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7013           enddo
7014         endif
7015       return
7016       end
7017 C------------------------------------------------------------------------------
7018       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7019       implicit real*8 (a-h,o-z)
7020       include 'DIMENSIONS'
7021       include 'COMMON.GEO'
7022       include 'COMMON.LOCAL'
7023       include 'COMMON.IOUNITS'
7024       common /sccalc/ time11,time12,time112,theti,it,nlobit
7025       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7026       double precision contr(maxlob)
7027       logical mixed
7028
7029       escloc_i=0.0D0
7030
7031       do j=1,3
7032         dersc(j)=0.0D0
7033       enddo
7034
7035       do j=1,nlobit
7036         do k=1,2
7037           z(k)=x(k)-censc(k,j,it)
7038         enddo
7039         z(3)=dwapi
7040         do k=1,3
7041           Axk=0.0D0
7042           do l=1,3
7043             Axk=Axk+gaussc(l,k,j,it)*z(l)
7044           enddo
7045           Ax(k,j)=Axk
7046         enddo
7047         expfac=0.0D0
7048         do k=1,3
7049           expfac=expfac+Ax(k,j)*z(k)
7050         enddo
7051         contr(j)=expfac
7052       enddo ! j
7053
7054 C As in the case of ebend, we want to avoid underflows in exponentiation and
7055 C subsequent NaNs and INFs in energy calculation.
7056 C Find the largest exponent
7057       emin=contr(1)
7058       do j=1,nlobit
7059         if (emin.gt.contr(j)) emin=contr(j)
7060       enddo
7061       emin=0.5D0*emin
7062
7063 C Compute the contribution to SC energy and derivatives
7064
7065       dersc12=0.0d0
7066       do j=1,nlobit
7067         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7068         escloc_i=escloc_i+expfac
7069         do k=1,2
7070           dersc(k)=dersc(k)+Ax(k,j)*expfac
7071         enddo
7072         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7073      &            +gaussc(1,2,j,it))*expfac
7074         dersc(3)=0.0d0
7075       enddo
7076
7077       dersc(1)=dersc(1)/cos(theti)**2
7078       dersc12=dersc12/cos(theti)**2
7079       escloci=-(dlog(escloc_i)-emin)
7080       do j=1,2
7081         dersc(j)=dersc(j)/escloc_i
7082       enddo
7083       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7084       return
7085       end
7086 #else
7087 c----------------------------------------------------------------------------------
7088       subroutine esc(escloc)
7089 C Calculate the local energy of a side chain and its derivatives in the
7090 C corresponding virtual-bond valence angles THETA and the spherical angles
7091 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7092 C added by Urszula Kozlowska. 07/11/2007
7093 C
7094       implicit real*8 (a-h,o-z)
7095       include 'DIMENSIONS'
7096       include 'COMMON.GEO'
7097       include 'COMMON.LOCAL'
7098       include 'COMMON.VAR'
7099       include 'COMMON.SCROT'
7100       include 'COMMON.INTERACT'
7101       include 'COMMON.DERIV'
7102       include 'COMMON.CHAIN'
7103       include 'COMMON.IOUNITS'
7104       include 'COMMON.NAMES'
7105       include 'COMMON.FFIELD'
7106       include 'COMMON.CONTROL'
7107       include 'COMMON.VECTORS'
7108       double precision x_prime(3),y_prime(3),z_prime(3)
7109      &    , sumene,dsc_i,dp2_i,x(65),
7110      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7111      &    de_dxx,de_dyy,de_dzz,de_dt
7112       double precision s1_t,s1_6_t,s2_t,s2_6_t
7113       double precision
7114      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7115      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7116      & dt_dCi(3),dt_dCi1(3)
7117       common /sccalc/ time11,time12,time112,theti,it,nlobit
7118       delta=0.02d0*pi
7119       escloc=0.0D0
7120       do i=loc_start,loc_end
7121         if (itype(i).eq.ntyp1) cycle
7122         costtab(i+1) =dcos(theta(i+1))
7123         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7124         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7125         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7126         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7127         cosfac=dsqrt(cosfac2)
7128         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7129         sinfac=dsqrt(sinfac2)
7130         it=iabs(itype(i))
7131         if (it.eq.10) goto 1
7132 c
7133 C  Compute the axes of tghe local cartesian coordinates system; store in
7134 c   x_prime, y_prime and z_prime
7135 c
7136         do j=1,3
7137           x_prime(j) = 0.00
7138           y_prime(j) = 0.00
7139           z_prime(j) = 0.00
7140         enddo
7141 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7142 C     &   dc_norm(3,i+nres)
7143         do j = 1,3
7144           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7145           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7146         enddo
7147         do j = 1,3
7148           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7149         enddo
7150 c       write (2,*) "i",i
7151 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7152 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7153 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7154 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7155 c      & " xy",scalar(x_prime(1),y_prime(1)),
7156 c      & " xz",scalar(x_prime(1),z_prime(1)),
7157 c      & " yy",scalar(y_prime(1),y_prime(1)),
7158 c      & " yz",scalar(y_prime(1),z_prime(1)),
7159 c      & " zz",scalar(z_prime(1),z_prime(1))
7160 c
7161 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7162 C to local coordinate system. Store in xx, yy, zz.
7163 c
7164         xx=0.0d0
7165         yy=0.0d0
7166         zz=0.0d0
7167         do j = 1,3
7168           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7169           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7170           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7171         enddo
7172
7173         xxtab(i)=xx
7174         yytab(i)=yy
7175         zztab(i)=zz
7176 C
7177 C Compute the energy of the ith side cbain
7178 C
7179 c        write (2,*) "xx",xx," yy",yy," zz",zz
7180         it=iabs(itype(i))
7181         do j = 1,65
7182           x(j) = sc_parmin(j,it)
7183         enddo
7184 #ifdef CHECK_COORD
7185 Cc diagnostics - remove later
7186         xx1 = dcos(alph(2))
7187         yy1 = dsin(alph(2))*dcos(omeg(2))
7188         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7189         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7190      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7191      &    xx1,yy1,zz1
7192 C,"  --- ", xx_w,yy_w,zz_w
7193 c end diagnostics
7194 #endif
7195         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7196      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7197      &   + x(10)*yy*zz
7198         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7199      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7200      & + x(20)*yy*zz
7201         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7202      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7203      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7204      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7205      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7206      &  +x(40)*xx*yy*zz
7207         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7208      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7209      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7210      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7211      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7212      &  +x(60)*xx*yy*zz
7213         dsc_i   = 0.743d0+x(61)
7214         dp2_i   = 1.9d0+x(62)
7215         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7216      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7217         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7218      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7219         s1=(1+x(63))/(0.1d0 + dscp1)
7220         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7221         s2=(1+x(65))/(0.1d0 + dscp2)
7222         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7223         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7224      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7225 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7226 c     &   sumene4,
7227 c     &   dscp1,dscp2,sumene
7228 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7229         escloc = escloc + sumene
7230 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7231 c     & ,zz,xx,yy
7232 c#define DEBUG
7233 #ifdef DEBUG
7234 C
7235 C This section to check the numerical derivatives of the energy of ith side
7236 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7237 C #define DEBUG in the code to turn it on.
7238 C
7239         write (2,*) "sumene               =",sumene
7240         aincr=1.0d-7
7241         xxsave=xx
7242         xx=xx+aincr
7243         write (2,*) xx,yy,zz
7244         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7245         de_dxx_num=(sumenep-sumene)/aincr
7246         xx=xxsave
7247         write (2,*) "xx+ sumene from enesc=",sumenep
7248         yysave=yy
7249         yy=yy+aincr
7250         write (2,*) xx,yy,zz
7251         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7252         de_dyy_num=(sumenep-sumene)/aincr
7253         yy=yysave
7254         write (2,*) "yy+ sumene from enesc=",sumenep
7255         zzsave=zz
7256         zz=zz+aincr
7257         write (2,*) xx,yy,zz
7258         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7259         de_dzz_num=(sumenep-sumene)/aincr
7260         zz=zzsave
7261         write (2,*) "zz+ sumene from enesc=",sumenep
7262         costsave=cost2tab(i+1)
7263         sintsave=sint2tab(i+1)
7264         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7265         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7266         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7267         de_dt_num=(sumenep-sumene)/aincr
7268         write (2,*) " t+ sumene from enesc=",sumenep
7269         cost2tab(i+1)=costsave
7270         sint2tab(i+1)=sintsave
7271 C End of diagnostics section.
7272 #endif
7273 C
7274 C Compute the gradient of esc
7275 C
7276 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7277         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7278         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7279         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7280         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7281         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7282         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7283         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7284         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7285         pom1=(sumene3*sint2tab(i+1)+sumene1)
7286      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7287         pom2=(sumene4*cost2tab(i+1)+sumene2)
7288      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7289         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7290         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7291      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7292      &  +x(40)*yy*zz
7293         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7294         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7295      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7296      &  +x(60)*yy*zz
7297         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7298      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7299      &        +(pom1+pom2)*pom_dx
7300 #ifdef DEBUG
7301         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7302 #endif
7303 C
7304         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7305         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7306      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7307      &  +x(40)*xx*zz
7308         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7309         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7310      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7311      &  +x(59)*zz**2 +x(60)*xx*zz
7312         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7313      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7314      &        +(pom1-pom2)*pom_dy
7315 #ifdef DEBUG
7316         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7317 #endif
7318 C
7319         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7320      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7321      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7322      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7323      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7324      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7325      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7326      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7327 #ifdef DEBUG
7328         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7329 #endif
7330 C
7331         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7332      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7333      &  +pom1*pom_dt1+pom2*pom_dt2
7334 #ifdef DEBUG
7335         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7336 #endif
7337 c#undef DEBUG
7338 c
7339 C
7340        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7341        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7342        cosfac2xx=cosfac2*xx
7343        sinfac2yy=sinfac2*yy
7344        do k = 1,3
7345          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7346      &      vbld_inv(i+1)
7347          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7348      &      vbld_inv(i)
7349          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7350          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7351 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7352 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7353 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7354 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7355          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7356          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7357          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7358          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7359          dZZ_Ci1(k)=0.0d0
7360          dZZ_Ci(k)=0.0d0
7361          do j=1,3
7362            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7363      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7364            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7365      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7366          enddo
7367
7368          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7369          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7370          dZZ_XYZ(k)=vbld_inv(i+nres)*
7371      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7372 c
7373          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7374          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7375        enddo
7376
7377        do k=1,3
7378          dXX_Ctab(k,i)=dXX_Ci(k)
7379          dXX_C1tab(k,i)=dXX_Ci1(k)
7380          dYY_Ctab(k,i)=dYY_Ci(k)
7381          dYY_C1tab(k,i)=dYY_Ci1(k)
7382          dZZ_Ctab(k,i)=dZZ_Ci(k)
7383          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7384          dXX_XYZtab(k,i)=dXX_XYZ(k)
7385          dYY_XYZtab(k,i)=dYY_XYZ(k)
7386          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7387        enddo
7388
7389        do k = 1,3
7390 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7391 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7392 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7393 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7394 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7395 c     &    dt_dci(k)
7396 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7397 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7398          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7399      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7400          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7401      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7402          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7403      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7404        enddo
7405 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7406 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7407
7408 C to check gradient call subroutine check_grad
7409
7410     1 continue
7411       enddo
7412       return
7413       end
7414 c------------------------------------------------------------------------------
7415       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7416       implicit none
7417       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7418      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7419       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7420      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7421      &   + x(10)*yy*zz
7422       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7423      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7424      & + x(20)*yy*zz
7425       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7426      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7427      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7428      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7429      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7430      &  +x(40)*xx*yy*zz
7431       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7432      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7433      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7434      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7435      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7436      &  +x(60)*xx*yy*zz
7437       dsc_i   = 0.743d0+x(61)
7438       dp2_i   = 1.9d0+x(62)
7439       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7440      &          *(xx*cost2+yy*sint2))
7441       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7442      &          *(xx*cost2-yy*sint2))
7443       s1=(1+x(63))/(0.1d0 + dscp1)
7444       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7445       s2=(1+x(65))/(0.1d0 + dscp2)
7446       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7447       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7448      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7449       enesc=sumene
7450       return
7451       end
7452 #endif
7453 c------------------------------------------------------------------------------
7454       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7455 C
7456 C This procedure calculates two-body contact function g(rij) and its derivative:
7457 C
7458 C           eps0ij                                     !       x < -1
7459 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7460 C            0                                         !       x > 1
7461 C
7462 C where x=(rij-r0ij)/delta
7463 C
7464 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7465 C
7466       implicit none
7467       double precision rij,r0ij,eps0ij,fcont,fprimcont
7468       double precision x,x2,x4,delta
7469 c     delta=0.02D0*r0ij
7470 c      delta=0.2D0*r0ij
7471       x=(rij-r0ij)/delta
7472       if (x.lt.-1.0D0) then
7473         fcont=eps0ij
7474         fprimcont=0.0D0
7475       else if (x.le.1.0D0) then
7476         x2=x*x
7477         x4=x2*x2
7478         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7479         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7480       else
7481         fcont=0.0D0
7482         fprimcont=0.0D0
7483       endif
7484       return
7485       end
7486 c------------------------------------------------------------------------------
7487       subroutine splinthet(theti,delta,ss,ssder)
7488       implicit real*8 (a-h,o-z)
7489       include 'DIMENSIONS'
7490       include 'COMMON.VAR'
7491       include 'COMMON.GEO'
7492       thetup=pi-delta
7493       thetlow=delta
7494       if (theti.gt.pipol) then
7495         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7496       else
7497         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7498         ssder=-ssder
7499       endif
7500       return
7501       end
7502 c------------------------------------------------------------------------------
7503       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7504       implicit none
7505       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7506       double precision ksi,ksi2,ksi3,a1,a2,a3
7507       a1=fprim0*delta/(f1-f0)
7508       a2=3.0d0-2.0d0*a1
7509       a3=a1-2.0d0
7510       ksi=(x-x0)/delta
7511       ksi2=ksi*ksi
7512       ksi3=ksi2*ksi
7513       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7514       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7515       return
7516       end
7517 c------------------------------------------------------------------------------
7518       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7519       implicit none
7520       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7521       double precision ksi,ksi2,ksi3,a1,a2,a3
7522       ksi=(x-x0)/delta
7523       ksi2=ksi*ksi
7524       ksi3=ksi2*ksi
7525       a1=fprim0x*delta
7526       a2=3*(f1x-f0x)-2*fprim0x*delta
7527       a3=fprim0x*delta-2*(f1x-f0x)
7528       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7529       return
7530       end
7531 C-----------------------------------------------------------------------------
7532 #ifdef CRYST_TOR
7533 C-----------------------------------------------------------------------------
7534       subroutine etor(etors,edihcnstr)
7535       implicit real*8 (a-h,o-z)
7536       include 'DIMENSIONS'
7537       include 'COMMON.VAR'
7538       include 'COMMON.GEO'
7539       include 'COMMON.LOCAL'
7540       include 'COMMON.TORSION'
7541       include 'COMMON.INTERACT'
7542       include 'COMMON.DERIV'
7543       include 'COMMON.CHAIN'
7544       include 'COMMON.NAMES'
7545       include 'COMMON.IOUNITS'
7546       include 'COMMON.FFIELD'
7547       include 'COMMON.TORCNSTR'
7548       include 'COMMON.CONTROL'
7549       logical lprn
7550 C Set lprn=.true. for debugging
7551       lprn=.false.
7552 c      lprn=.true.
7553       etors=0.0D0
7554       do i=iphi_start,iphi_end
7555       etors_ii=0.0D0
7556         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7557      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7558         itori=itortyp(itype(i-2))
7559         itori1=itortyp(itype(i-1))
7560         phii=phi(i)
7561         gloci=0.0D0
7562 C Proline-Proline pair is a special case...
7563         if (itori.eq.3 .and. itori1.eq.3) then
7564           if (phii.gt.-dwapi3) then
7565             cosphi=dcos(3*phii)
7566             fac=1.0D0/(1.0D0-cosphi)
7567             etorsi=v1(1,3,3)*fac
7568             etorsi=etorsi+etorsi
7569             etors=etors+etorsi-v1(1,3,3)
7570             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7571             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7572           endif
7573           do j=1,3
7574             v1ij=v1(j+1,itori,itori1)
7575             v2ij=v2(j+1,itori,itori1)
7576             cosphi=dcos(j*phii)
7577             sinphi=dsin(j*phii)
7578             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7579             if (energy_dec) etors_ii=etors_ii+
7580      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7581             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7582           enddo
7583         else
7584           do j=1,nterm_old
7585             v1ij=v1(j,itori,itori1)
7586             v2ij=v2(j,itori,itori1)
7587             cosphi=dcos(j*phii)
7588             sinphi=dsin(j*phii)
7589             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7590             if (energy_dec) etors_ii=etors_ii+
7591      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7592             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7593           enddo
7594         endif
7595         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7596              'etor',i,etors_ii
7597         if (lprn)
7598      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7599      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7600      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7601         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7602 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7603       enddo
7604 ! 6/20/98 - dihedral angle constraints
7605       edihcnstr=0.0d0
7606       do i=1,ndih_constr
7607         itori=idih_constr(i)
7608         phii=phi(itori)
7609         difi=phii-phi0(i)
7610         if (difi.gt.drange(i)) then
7611           difi=difi-drange(i)
7612           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7613           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7614         else if (difi.lt.-drange(i)) then
7615           difi=difi+drange(i)
7616           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7617           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7618         endif
7619 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7620 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7621       enddo
7622 !      write (iout,*) 'edihcnstr',edihcnstr
7623       return
7624       end
7625 c------------------------------------------------------------------------------
7626       subroutine etor_d(etors_d)
7627       etors_d=0.0d0
7628       return
7629       end
7630 c----------------------------------------------------------------------------
7631 #else
7632       subroutine etor(etors,edihcnstr)
7633       implicit real*8 (a-h,o-z)
7634       include 'DIMENSIONS'
7635       include 'COMMON.VAR'
7636       include 'COMMON.GEO'
7637       include 'COMMON.LOCAL'
7638       include 'COMMON.TORSION'
7639       include 'COMMON.INTERACT'
7640       include 'COMMON.DERIV'
7641       include 'COMMON.CHAIN'
7642       include 'COMMON.NAMES'
7643       include 'COMMON.IOUNITS'
7644       include 'COMMON.FFIELD'
7645       include 'COMMON.TORCNSTR'
7646       include 'COMMON.CONTROL'
7647       logical lprn
7648 C Set lprn=.true. for debugging
7649       lprn=.false.
7650 c     lprn=.true.
7651       etors=0.0D0
7652       do i=iphi_start,iphi_end
7653 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7654 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7655 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7656 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7657         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7658      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7659 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7660 C For introducing the NH3+ and COO- group please check the etor_d for reference
7661 C and guidance
7662         etors_ii=0.0D0
7663          if (iabs(itype(i)).eq.20) then
7664          iblock=2
7665          else
7666          iblock=1
7667          endif
7668         itori=itortyp(itype(i-2))
7669         itori1=itortyp(itype(i-1))
7670         phii=phi(i)
7671         gloci=0.0D0
7672 C Regular cosine and sine terms
7673         do j=1,nterm(itori,itori1,iblock)
7674           v1ij=v1(j,itori,itori1,iblock)
7675           v2ij=v2(j,itori,itori1,iblock)
7676           cosphi=dcos(j*phii)
7677           sinphi=dsin(j*phii)
7678           etors=etors+v1ij*cosphi+v2ij*sinphi
7679           if (energy_dec) etors_ii=etors_ii+
7680      &                v1ij*cosphi+v2ij*sinphi
7681           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7682         enddo
7683 C Lorentz terms
7684 C                         v1
7685 C  E = SUM ----------------------------------- - v1
7686 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7687 C
7688         cosphi=dcos(0.5d0*phii)
7689         sinphi=dsin(0.5d0*phii)
7690         do j=1,nlor(itori,itori1,iblock)
7691           vl1ij=vlor1(j,itori,itori1)
7692           vl2ij=vlor2(j,itori,itori1)
7693           vl3ij=vlor3(j,itori,itori1)
7694           pom=vl2ij*cosphi+vl3ij*sinphi
7695           pom1=1.0d0/(pom*pom+1.0d0)
7696           etors=etors+vl1ij*pom1
7697           if (energy_dec) etors_ii=etors_ii+
7698      &                vl1ij*pom1
7699           pom=-pom*pom1*pom1
7700           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7701         enddo
7702 C Subtract the constant term
7703         etors=etors-v0(itori,itori1,iblock)
7704           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7705      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7706         if (lprn)
7707      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7708      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7709      &  (v1(j,itori,itori1,iblock),j=1,6),
7710      &  (v2(j,itori,itori1,iblock),j=1,6)
7711         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7712 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7713       enddo
7714 ! 6/20/98 - dihedral angle constraints
7715       edihcnstr=0.0d0
7716 c      do i=1,ndih_constr
7717       do i=idihconstr_start,idihconstr_end
7718         itori=idih_constr(i)
7719         phii=phi(itori)
7720         difi=pinorm(phii-phi0(i))
7721         if (difi.gt.drange(i)) then
7722           difi=difi-drange(i)
7723           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7724           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7725         else if (difi.lt.-drange(i)) then
7726           difi=difi+drange(i)
7727           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7728           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7729         else
7730           difi=0.0
7731         endif
7732        if (energy_dec) then
7733         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7734      &    i,itori,rad2deg*phii,
7735      &    rad2deg*phi0(i),  rad2deg*drange(i),
7736      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7737         endif
7738       enddo
7739 cd       write (iout,*) 'edihcnstr',edihcnstr
7740       return
7741       end
7742 c----------------------------------------------------------------------------
7743       subroutine etor_d(etors_d)
7744 C 6/23/01 Compute double torsional energy
7745       implicit real*8 (a-h,o-z)
7746       include 'DIMENSIONS'
7747       include 'COMMON.VAR'
7748       include 'COMMON.GEO'
7749       include 'COMMON.LOCAL'
7750       include 'COMMON.TORSION'
7751       include 'COMMON.INTERACT'
7752       include 'COMMON.DERIV'
7753       include 'COMMON.CHAIN'
7754       include 'COMMON.NAMES'
7755       include 'COMMON.IOUNITS'
7756       include 'COMMON.FFIELD'
7757       include 'COMMON.TORCNSTR'
7758       logical lprn
7759 C Set lprn=.true. for debugging
7760       lprn=.false.
7761 c     lprn=.true.
7762       etors_d=0.0D0
7763 c      write(iout,*) "a tu??"
7764       do i=iphid_start,iphid_end
7765 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7766 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7767 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7768 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7769 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7770          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7771      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7772      &  (itype(i+1).eq.ntyp1)) cycle
7773 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7774         itori=itortyp(itype(i-2))
7775         itori1=itortyp(itype(i-1))
7776         itori2=itortyp(itype(i))
7777         phii=phi(i)
7778         phii1=phi(i+1)
7779         gloci1=0.0D0
7780         gloci2=0.0D0
7781         iblock=1
7782         if (iabs(itype(i+1)).eq.20) iblock=2
7783 C Iblock=2 Proline type
7784 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7785 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7786 C        if (itype(i+1).eq.ntyp1) iblock=3
7787 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7788 C IS or IS NOT need for this
7789 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7790 C        is (itype(i-3).eq.ntyp1) ntblock=2
7791 C        ntblock is N-terminal blocking group
7792
7793 C Regular cosine and sine terms
7794         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7795 C Example of changes for NH3+ blocking group
7796 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7797 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7798           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7799           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7800           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7801           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7802           cosphi1=dcos(j*phii)
7803           sinphi1=dsin(j*phii)
7804           cosphi2=dcos(j*phii1)
7805           sinphi2=dsin(j*phii1)
7806           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7807      &     v2cij*cosphi2+v2sij*sinphi2
7808           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7809           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7810         enddo
7811         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7812           do l=1,k-1
7813             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7814             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7815             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7816             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7817             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7818             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7819             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7820             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7821             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7822      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7823             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7824      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7825             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7826      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7827           enddo
7828         enddo
7829         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7830         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7831       enddo
7832       return
7833       end
7834 #endif
7835 C----------------------------------------------------------------------------------
7836 C The rigorous attempt to derive energy function
7837       subroutine etor_kcc(etors,edihcnstr)
7838       implicit real*8 (a-h,o-z)
7839       include 'DIMENSIONS'
7840       include 'COMMON.VAR'
7841       include 'COMMON.GEO'
7842       include 'COMMON.LOCAL'
7843       include 'COMMON.TORSION'
7844       include 'COMMON.INTERACT'
7845       include 'COMMON.DERIV'
7846       include 'COMMON.CHAIN'
7847       include 'COMMON.NAMES'
7848       include 'COMMON.IOUNITS'
7849       include 'COMMON.FFIELD'
7850       include 'COMMON.TORCNSTR'
7851       include 'COMMON.CONTROL'
7852       logical lprn
7853 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7854 C Set lprn=.true. for debugging
7855       lprn=.false.
7856 c     lprn=.true.
7857 C      print *,"wchodze kcc"
7858       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7859       if (tor_mode.ne.2) then
7860       etors=0.0D0
7861       endif
7862       do i=iphi_start,iphi_end
7863 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7864 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7865 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7866 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7867         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7868      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7869         itori=itortyp_kcc(itype(i-2))
7870         itori1=itortyp_kcc(itype(i-1))
7871         phii=phi(i)
7872         glocig=0.0D0
7873         glocit1=0.0d0
7874         glocit2=0.0d0
7875         sumnonchebyshev=0.0d0
7876         sumchebyshev=0.0d0
7877 C to avoid multiple devision by 2
7878 c        theti22=0.5d0*theta(i)
7879 C theta 12 is the theta_1 /2
7880 C theta 22 is theta_2 /2
7881 c        theti12=0.5d0*theta(i-1)
7882 C and appropriate sinus function
7883         sinthet1=dsin(theta(i-1))
7884         sinthet2=dsin(theta(i))
7885         costhet1=dcos(theta(i-1))
7886         costhet2=dcos(theta(i))
7887 c Cosines of halves thetas
7888         costheti12=0.5d0*(1.0d0+costhet1)
7889         costheti22=0.5d0*(1.0d0+costhet2)
7890 C to speed up lets store its mutliplication
7891         sint1t2=sinthet2*sinthet1
7892         sint1t2n=1.0d0
7893 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7894 C +d_n*sin(n*gamma)) *
7895 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7896 C we have two sum 1) Non-Chebyshev which is with n and gamma
7897         etori=0.0d0
7898         do j=1,nterm_kcc(itori,itori1)
7899
7900           nval=nterm_kcc_Tb(itori,itori1)
7901           v1ij=v1_kcc(j,itori,itori1)
7902           v2ij=v2_kcc(j,itori,itori1)
7903 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7904 C v1ij is c_n and d_n in euation above
7905           cosphi=dcos(j*phii)
7906           sinphi=dsin(j*phii)
7907           sint1t2n1=sint1t2n
7908           sint1t2n=sint1t2n*sint1t2
7909           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7910      &        costheti12)
7911           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7912      &        v11_chyb(1,j,itori,itori1),costheti12)
7913 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7914 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7915           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7916      &        costheti22)
7917           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7918      &        v21_chyb(1,j,itori,itori1),costheti22)
7919 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7920 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7921           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7922      &        costheti12)
7923           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7924      &        v12_chyb(1,j,itori,itori1),costheti12)
7925 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7926 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7927           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7928      &        costheti22)
7929           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7930      &        v22_chyb(1,j,itori,itori1),costheti22)
7931 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7932 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7933 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7934 C          if (energy_dec) etors_ii=etors_ii+
7935 C     &                v1ij*cosphi+v2ij*sinphi
7936 C glocig is the gradient local i site in gamma
7937           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7938           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7939           etori=etori+sint1t2n*(actval1+actval2)
7940           glocig=glocig+
7941      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7942      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7943 C now gradient over theta_1
7944           glocit1=glocit1+
7945      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7946      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7947           glocit2=glocit2+
7948      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7949      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7950
7951 C now the Czebyshev polinominal sum
7952 c        do k=1,nterm_kcc_Tb(itori,itori1)
7953 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7954 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7955 C         thybt1(k)=0.0
7956 C         thybt2(k)=0.0
7957 c        enddo
7958 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7959 C     &         gradtschebyshev
7960 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7961 C     &         dcos(theti22)**2),
7962 C     &         dsin(theti22)
7963
7964 C now overal sumation
7965 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7966         enddo ! j
7967         etors=etors+etori
7968 C derivative over gamma
7969         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7970 C derivative over theta1
7971         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7972 C now derivative over theta2
7973         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7974         if (lprn)
7975      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7976      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7977       enddo
7978 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7979 ! 6/20/98 - dihedral angle constraints
7980       if (tor_mode.ne.2) then
7981       edihcnstr=0.0d0
7982 c      do i=1,ndih_constr
7983       do i=idihconstr_start,idihconstr_end
7984         itori=idih_constr(i)
7985         phii=phi(itori)
7986         difi=pinorm(phii-phi0(i))
7987         if (difi.gt.drange(i)) then
7988           difi=difi-drange(i)
7989           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7990           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7991         else if (difi.lt.-drange(i)) then
7992           difi=difi+drange(i)
7993           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7994           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7995         else
7996           difi=0.0
7997         endif
7998        enddo
7999        endif
8000       return
8001       end
8002
8003 C The rigorous attempt to derive energy function
8004       subroutine ebend_kcc(etheta,ethetacnstr)
8005
8006       implicit real*8 (a-h,o-z)
8007       include 'DIMENSIONS'
8008       include 'COMMON.VAR'
8009       include 'COMMON.GEO'
8010       include 'COMMON.LOCAL'
8011       include 'COMMON.TORSION'
8012       include 'COMMON.INTERACT'
8013       include 'COMMON.DERIV'
8014       include 'COMMON.CHAIN'
8015       include 'COMMON.NAMES'
8016       include 'COMMON.IOUNITS'
8017       include 'COMMON.FFIELD'
8018       include 'COMMON.TORCNSTR'
8019       include 'COMMON.CONTROL'
8020       logical lprn
8021       double precision thybt1(maxtermkcc)
8022 C Set lprn=.true. for debugging
8023       lprn=.false.
8024 c     lprn=.true.
8025 C      print *,"wchodze kcc"
8026       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8027       if (tor_mode.ne.2) etheta=0.0D0
8028       do i=ithet_start,ithet_end
8029 c        print *,i,itype(i-1),itype(i),itype(i-2)
8030         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8031      &  .or.itype(i).eq.ntyp1) cycle
8032          iti=itortyp_kcc(itype(i-1))
8033         sinthet=dsin(theta(i)/2.0d0)
8034         costhet=dcos(theta(i)/2.0d0)
8035          do j=1,nbend_kcc_Tb(iti)
8036           thybt1(j)=v1bend_chyb(j,iti)
8037          enddo
8038          sumth1thyb=tschebyshev
8039      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8040         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8041      &    sumth1thyb
8042         ihelp=nbend_kcc_Tb(iti)-1
8043         gradthybt1=gradtschebyshev
8044      &         (0,ihelp,thybt1(1),costhet)
8045         etheta=etheta+sumth1thyb
8046 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8047         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8048      &   gradthybt1*sinthet*(-0.5d0)
8049       enddo
8050       if (tor_mode.ne.2) then
8051       ethetacnstr=0.0d0
8052 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8053       do i=ithetaconstr_start,ithetaconstr_end
8054         itheta=itheta_constr(i)
8055         thetiii=theta(itheta)
8056         difi=pinorm(thetiii-theta_constr0(i))
8057         if (difi.gt.theta_drange(i)) then
8058           difi=difi-theta_drange(i)
8059           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8060           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8061      &    +for_thet_constr(i)*difi**3
8062         else if (difi.lt.-drange(i)) then
8063           difi=difi+drange(i)
8064           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8065           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8066      &    +for_thet_constr(i)*difi**3
8067         else
8068           difi=0.0
8069         endif
8070        if (energy_dec) then
8071         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8072      &    i,itheta,rad2deg*thetiii,
8073      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8074      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8075      &    gloc(itheta+nphi-2,icg)
8076         endif
8077       enddo
8078       endif
8079       return
8080       end
8081 c------------------------------------------------------------------------------
8082       subroutine eback_sc_corr(esccor)
8083 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8084 c        conformational states; temporarily implemented as differences
8085 c        between UNRES torsional potentials (dependent on three types of
8086 c        residues) and the torsional potentials dependent on all 20 types
8087 c        of residues computed from AM1  energy surfaces of terminally-blocked
8088 c        amino-acid residues.
8089       implicit real*8 (a-h,o-z)
8090       include 'DIMENSIONS'
8091       include 'COMMON.VAR'
8092       include 'COMMON.GEO'
8093       include 'COMMON.LOCAL'
8094       include 'COMMON.TORSION'
8095       include 'COMMON.SCCOR'
8096       include 'COMMON.INTERACT'
8097       include 'COMMON.DERIV'
8098       include 'COMMON.CHAIN'
8099       include 'COMMON.NAMES'
8100       include 'COMMON.IOUNITS'
8101       include 'COMMON.FFIELD'
8102       include 'COMMON.CONTROL'
8103       logical lprn
8104 C Set lprn=.true. for debugging
8105       lprn=.false.
8106 c      lprn=.true.
8107 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8108       esccor=0.0D0
8109       do i=itau_start,itau_end
8110         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8111         esccor_ii=0.0D0
8112         isccori=isccortyp(itype(i-2))
8113         isccori1=isccortyp(itype(i-1))
8114 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8115         phii=phi(i)
8116         do intertyp=1,3 !intertyp
8117 cc Added 09 May 2012 (Adasko)
8118 cc  Intertyp means interaction type of backbone mainchain correlation:
8119 c   1 = SC...Ca...Ca...Ca
8120 c   2 = Ca...Ca...Ca...SC
8121 c   3 = SC...Ca...Ca...SCi
8122         gloci=0.0D0
8123         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8124      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8125      &      (itype(i-1).eq.ntyp1)))
8126      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8127      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8128      &     .or.(itype(i).eq.ntyp1)))
8129      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8130      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8131      &      (itype(i-3).eq.ntyp1)))) cycle
8132         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8133         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8134      & cycle
8135        do j=1,nterm_sccor(isccori,isccori1)
8136           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8137           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8138           cosphi=dcos(j*tauangle(intertyp,i))
8139           sinphi=dsin(j*tauangle(intertyp,i))
8140           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8141           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8142         enddo
8143 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8144         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8145         if (lprn)
8146      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8147      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8148      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8149      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8150         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8151        enddo !intertyp
8152       enddo
8153
8154       return
8155       end
8156 c----------------------------------------------------------------------------
8157       subroutine multibody(ecorr)
8158 C This subroutine calculates multi-body contributions to energy following
8159 C the idea of Skolnick et al. If side chains I and J make a contact and
8160 C at the same time side chains I+1 and J+1 make a contact, an extra
8161 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8162       implicit real*8 (a-h,o-z)
8163       include 'DIMENSIONS'
8164       include 'COMMON.IOUNITS'
8165       include 'COMMON.DERIV'
8166       include 'COMMON.INTERACT'
8167       include 'COMMON.CONTACTS'
8168       double precision gx(3),gx1(3)
8169       logical lprn
8170
8171 C Set lprn=.true. for debugging
8172       lprn=.false.
8173
8174       if (lprn) then
8175         write (iout,'(a)') 'Contact function values:'
8176         do i=nnt,nct-2
8177           write (iout,'(i2,20(1x,i2,f10.5))')
8178      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8179         enddo
8180       endif
8181       ecorr=0.0D0
8182       do i=nnt,nct
8183         do j=1,3
8184           gradcorr(j,i)=0.0D0
8185           gradxorr(j,i)=0.0D0
8186         enddo
8187       enddo
8188       do i=nnt,nct-2
8189
8190         DO ISHIFT = 3,4
8191
8192         i1=i+ishift
8193         num_conti=num_cont(i)
8194         num_conti1=num_cont(i1)
8195         do jj=1,num_conti
8196           j=jcont(jj,i)
8197           do kk=1,num_conti1
8198             j1=jcont(kk,i1)
8199             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8200 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8201 cd   &                   ' ishift=',ishift
8202 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8203 C The system gains extra energy.
8204               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8205             endif   ! j1==j+-ishift
8206           enddo     ! kk
8207         enddo       ! jj
8208
8209         ENDDO ! ISHIFT
8210
8211       enddo         ! i
8212       return
8213       end
8214 c------------------------------------------------------------------------------
8215       double precision function esccorr(i,j,k,l,jj,kk)
8216       implicit real*8 (a-h,o-z)
8217       include 'DIMENSIONS'
8218       include 'COMMON.IOUNITS'
8219       include 'COMMON.DERIV'
8220       include 'COMMON.INTERACT'
8221       include 'COMMON.CONTACTS'
8222       include 'COMMON.SHIELD'
8223       double precision gx(3),gx1(3)
8224       logical lprn
8225       lprn=.false.
8226       eij=facont(jj,i)
8227       ekl=facont(kk,k)
8228 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8229 C Calculate the multi-body contribution to energy.
8230 C Calculate multi-body contributions to the gradient.
8231 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8232 cd   & k,l,(gacont(m,kk,k),m=1,3)
8233       do m=1,3
8234         gx(m) =ekl*gacont(m,jj,i)
8235         gx1(m)=eij*gacont(m,kk,k)
8236         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8237         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8238         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8239         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8240       enddo
8241       do m=i,j-1
8242         do ll=1,3
8243           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8244         enddo
8245       enddo
8246       do m=k,l-1
8247         do ll=1,3
8248           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8249         enddo
8250       enddo
8251       esccorr=-eij*ekl
8252       return
8253       end
8254 c------------------------------------------------------------------------------
8255       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8256 C This subroutine calculates multi-body contributions to hydrogen-bonding
8257       implicit real*8 (a-h,o-z)
8258       include 'DIMENSIONS'
8259       include 'COMMON.IOUNITS'
8260 #ifdef MPI
8261       include "mpif.h"
8262       parameter (max_cont=maxconts)
8263       parameter (max_dim=26)
8264       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8265       double precision zapas(max_dim,maxconts,max_fg_procs),
8266      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8267       common /przechowalnia/ zapas
8268       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8269      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8270 #endif
8271       include 'COMMON.SETUP'
8272       include 'COMMON.FFIELD'
8273       include 'COMMON.DERIV'
8274       include 'COMMON.INTERACT'
8275       include 'COMMON.CONTACTS'
8276       include 'COMMON.CONTROL'
8277       include 'COMMON.LOCAL'
8278       double precision gx(3),gx1(3),time00
8279       logical lprn,ldone
8280
8281 C Set lprn=.true. for debugging
8282       lprn=.false.
8283 #ifdef MPI
8284       n_corr=0
8285       n_corr1=0
8286       if (nfgtasks.le.1) goto 30
8287       if (lprn) then
8288         write (iout,'(a)') 'Contact function values before RECEIVE:'
8289         do i=nnt,nct-2
8290           write (iout,'(2i3,50(1x,i2,f5.2))')
8291      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8292      &    j=1,num_cont_hb(i))
8293         enddo
8294       endif
8295       call flush(iout)
8296       do i=1,ntask_cont_from
8297         ncont_recv(i)=0
8298       enddo
8299       do i=1,ntask_cont_to
8300         ncont_sent(i)=0
8301       enddo
8302 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8303 c     & ntask_cont_to
8304 C Make the list of contacts to send to send to other procesors
8305 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8306 c      call flush(iout)
8307       do i=iturn3_start,iturn3_end
8308 c        write (iout,*) "make contact list turn3",i," num_cont",
8309 c     &    num_cont_hb(i)
8310         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8311       enddo
8312       do i=iturn4_start,iturn4_end
8313 c        write (iout,*) "make contact list turn4",i," num_cont",
8314 c     &   num_cont_hb(i)
8315         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8316       enddo
8317       do ii=1,nat_sent
8318         i=iat_sent(ii)
8319 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8320 c     &    num_cont_hb(i)
8321         do j=1,num_cont_hb(i)
8322         do k=1,4
8323           jjc=jcont_hb(j,i)
8324           iproc=iint_sent_local(k,jjc,ii)
8325 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8326           if (iproc.gt.0) then
8327             ncont_sent(iproc)=ncont_sent(iproc)+1
8328             nn=ncont_sent(iproc)
8329             zapas(1,nn,iproc)=i
8330             zapas(2,nn,iproc)=jjc
8331             zapas(3,nn,iproc)=facont_hb(j,i)
8332             zapas(4,nn,iproc)=ees0p(j,i)
8333             zapas(5,nn,iproc)=ees0m(j,i)
8334             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8335             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8336             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8337             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8338             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8339             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8340             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8341             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8342             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8343             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8344             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8345             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8346             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8347             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8348             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8349             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8350             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8351             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8352             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8353             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8354             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8355           endif
8356         enddo
8357         enddo
8358       enddo
8359       if (lprn) then
8360       write (iout,*)
8361      &  "Numbers of contacts to be sent to other processors",
8362      &  (ncont_sent(i),i=1,ntask_cont_to)
8363       write (iout,*) "Contacts sent"
8364       do ii=1,ntask_cont_to
8365         nn=ncont_sent(ii)
8366         iproc=itask_cont_to(ii)
8367         write (iout,*) nn," contacts to processor",iproc,
8368      &   " of CONT_TO_COMM group"
8369         do i=1,nn
8370           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8371         enddo
8372       enddo
8373       call flush(iout)
8374       endif
8375       CorrelType=477
8376       CorrelID=fg_rank+1
8377       CorrelType1=478
8378       CorrelID1=nfgtasks+fg_rank+1
8379       ireq=0
8380 C Receive the numbers of needed contacts from other processors
8381       do ii=1,ntask_cont_from
8382         iproc=itask_cont_from(ii)
8383         ireq=ireq+1
8384         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8385      &    FG_COMM,req(ireq),IERR)
8386       enddo
8387 c      write (iout,*) "IRECV ended"
8388 c      call flush(iout)
8389 C Send the number of contacts needed by other processors
8390       do ii=1,ntask_cont_to
8391         iproc=itask_cont_to(ii)
8392         ireq=ireq+1
8393         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8394      &    FG_COMM,req(ireq),IERR)
8395       enddo
8396 c      write (iout,*) "ISEND ended"
8397 c      write (iout,*) "number of requests (nn)",ireq
8398       call flush(iout)
8399       if (ireq.gt.0)
8400      &  call MPI_Waitall(ireq,req,status_array,ierr)
8401 c      write (iout,*)
8402 c     &  "Numbers of contacts to be received from other processors",
8403 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8404 c      call flush(iout)
8405 C Receive contacts
8406       ireq=0
8407       do ii=1,ntask_cont_from
8408         iproc=itask_cont_from(ii)
8409         nn=ncont_recv(ii)
8410 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8411 c     &   " of CONT_TO_COMM group"
8412         call flush(iout)
8413         if (nn.gt.0) then
8414           ireq=ireq+1
8415           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8416      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8417 c          write (iout,*) "ireq,req",ireq,req(ireq)
8418         endif
8419       enddo
8420 C Send the contacts to processors that need them
8421       do ii=1,ntask_cont_to
8422         iproc=itask_cont_to(ii)
8423         nn=ncont_sent(ii)
8424 c        write (iout,*) nn," contacts to processor",iproc,
8425 c     &   " of CONT_TO_COMM group"
8426         if (nn.gt.0) then
8427           ireq=ireq+1
8428           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8429      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8430 c          write (iout,*) "ireq,req",ireq,req(ireq)
8431 c          do i=1,nn
8432 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8433 c          enddo
8434         endif
8435       enddo
8436 c      write (iout,*) "number of requests (contacts)",ireq
8437 c      write (iout,*) "req",(req(i),i=1,4)
8438 c      call flush(iout)
8439       if (ireq.gt.0)
8440      & call MPI_Waitall(ireq,req,status_array,ierr)
8441       do iii=1,ntask_cont_from
8442         iproc=itask_cont_from(iii)
8443         nn=ncont_recv(iii)
8444         if (lprn) then
8445         write (iout,*) "Received",nn," contacts from processor",iproc,
8446      &   " of CONT_FROM_COMM group"
8447         call flush(iout)
8448         do i=1,nn
8449           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8450         enddo
8451         call flush(iout)
8452         endif
8453         do i=1,nn
8454           ii=zapas_recv(1,i,iii)
8455 c Flag the received contacts to prevent double-counting
8456           jj=-zapas_recv(2,i,iii)
8457 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8458 c          call flush(iout)
8459           nnn=num_cont_hb(ii)+1
8460           num_cont_hb(ii)=nnn
8461           jcont_hb(nnn,ii)=jj
8462           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8463           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8464           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8465           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8466           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8467           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8468           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8469           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8470           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8471           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8472           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8473           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8474           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8475           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8476           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8477           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8478           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8479           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8480           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8481           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8482           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8483           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8484           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8485           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8486         enddo
8487       enddo
8488       call flush(iout)
8489       if (lprn) then
8490         write (iout,'(a)') 'Contact function values after receive:'
8491         do i=nnt,nct-2
8492           write (iout,'(2i3,50(1x,i3,f5.2))')
8493      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8494      &    j=1,num_cont_hb(i))
8495         enddo
8496         call flush(iout)
8497       endif
8498    30 continue
8499 #endif
8500       if (lprn) then
8501         write (iout,'(a)') 'Contact function values:'
8502         do i=nnt,nct-2
8503           write (iout,'(2i3,50(1x,i3,f5.2))')
8504      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8505      &    j=1,num_cont_hb(i))
8506         enddo
8507       endif
8508       ecorr=0.0D0
8509 C Remove the loop below after debugging !!!
8510       do i=nnt,nct
8511         do j=1,3
8512           gradcorr(j,i)=0.0D0
8513           gradxorr(j,i)=0.0D0
8514         enddo
8515       enddo
8516 C Calculate the local-electrostatic correlation terms
8517       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8518         i1=i+1
8519         num_conti=num_cont_hb(i)
8520         num_conti1=num_cont_hb(i+1)
8521         do jj=1,num_conti
8522           j=jcont_hb(jj,i)
8523           jp=iabs(j)
8524           do kk=1,num_conti1
8525             j1=jcont_hb(kk,i1)
8526             jp1=iabs(j1)
8527 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8528 c     &         ' jj=',jj,' kk=',kk
8529             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8530      &          .or. j.lt.0 .and. j1.gt.0) .and.
8531      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8532 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8533 C The system gains extra energy.
8534               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8535               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8536      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8537               n_corr=n_corr+1
8538             else if (j1.eq.j) then
8539 C Contacts I-J and I-(J+1) occur simultaneously.
8540 C The system loses extra energy.
8541 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8542             endif
8543           enddo ! kk
8544           do kk=1,num_conti
8545             j1=jcont_hb(kk,i)
8546 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8547 c    &         ' jj=',jj,' kk=',kk
8548             if (j1.eq.j+1) then
8549 C Contacts I-J and (I+1)-J occur simultaneously.
8550 C The system loses extra energy.
8551 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8552             endif ! j1==j+1
8553           enddo ! kk
8554         enddo ! jj
8555       enddo ! i
8556       return
8557       end
8558 c------------------------------------------------------------------------------
8559       subroutine add_hb_contact(ii,jj,itask)
8560       implicit real*8 (a-h,o-z)
8561       include "DIMENSIONS"
8562       include "COMMON.IOUNITS"
8563       integer max_cont
8564       integer max_dim
8565       parameter (max_cont=maxconts)
8566       parameter (max_dim=26)
8567       include "COMMON.CONTACTS"
8568       double precision zapas(max_dim,maxconts,max_fg_procs),
8569      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8570       common /przechowalnia/ zapas
8571       integer i,j,ii,jj,iproc,itask(4),nn
8572 c      write (iout,*) "itask",itask
8573       do i=1,2
8574         iproc=itask(i)
8575         if (iproc.gt.0) then
8576           do j=1,num_cont_hb(ii)
8577             jjc=jcont_hb(j,ii)
8578 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8579             if (jjc.eq.jj) then
8580               ncont_sent(iproc)=ncont_sent(iproc)+1
8581               nn=ncont_sent(iproc)
8582               zapas(1,nn,iproc)=ii
8583               zapas(2,nn,iproc)=jjc
8584               zapas(3,nn,iproc)=facont_hb(j,ii)
8585               zapas(4,nn,iproc)=ees0p(j,ii)
8586               zapas(5,nn,iproc)=ees0m(j,ii)
8587               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8588               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8589               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8590               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8591               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8592               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8593               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8594               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8595               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8596               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8597               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8598               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8599               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8600               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8601               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8602               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8603               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8604               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8605               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8606               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8607               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8608               exit
8609             endif
8610           enddo
8611         endif
8612       enddo
8613       return
8614       end
8615 c------------------------------------------------------------------------------
8616       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8617      &  n_corr1)
8618 C This subroutine calculates multi-body contributions to hydrogen-bonding
8619       implicit real*8 (a-h,o-z)
8620       include 'DIMENSIONS'
8621       include 'COMMON.IOUNITS'
8622 #ifdef MPI
8623       include "mpif.h"
8624       parameter (max_cont=maxconts)
8625       parameter (max_dim=70)
8626       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8627       double precision zapas(max_dim,maxconts,max_fg_procs),
8628      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8629       common /przechowalnia/ zapas
8630       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8631      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8632 #endif
8633       include 'COMMON.SETUP'
8634       include 'COMMON.FFIELD'
8635       include 'COMMON.DERIV'
8636       include 'COMMON.LOCAL'
8637       include 'COMMON.INTERACT'
8638       include 'COMMON.CONTACTS'
8639       include 'COMMON.CHAIN'
8640       include 'COMMON.CONTROL'
8641       include 'COMMON.SHIELD'
8642       double precision gx(3),gx1(3)
8643       integer num_cont_hb_old(maxres)
8644       logical lprn,ldone
8645       double precision eello4,eello5,eelo6,eello_turn6
8646       external eello4,eello5,eello6,eello_turn6
8647 C Set lprn=.true. for debugging
8648       lprn=.false.
8649       eturn6=0.0d0
8650 #ifdef MPI
8651       do i=1,nres
8652         num_cont_hb_old(i)=num_cont_hb(i)
8653       enddo
8654       n_corr=0
8655       n_corr1=0
8656       if (nfgtasks.le.1) goto 30
8657       if (lprn) then
8658         write (iout,'(a)') 'Contact function values before RECEIVE:'
8659         do i=nnt,nct-2
8660           write (iout,'(2i3,50(1x,i2,f5.2))')
8661      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8662      &    j=1,num_cont_hb(i))
8663         enddo
8664       endif
8665       call flush(iout)
8666       do i=1,ntask_cont_from
8667         ncont_recv(i)=0
8668       enddo
8669       do i=1,ntask_cont_to
8670         ncont_sent(i)=0
8671       enddo
8672 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8673 c     & ntask_cont_to
8674 C Make the list of contacts to send to send to other procesors
8675       do i=iturn3_start,iturn3_end
8676 c        write (iout,*) "make contact list turn3",i," num_cont",
8677 c     &    num_cont_hb(i)
8678         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8679       enddo
8680       do i=iturn4_start,iturn4_end
8681 c        write (iout,*) "make contact list turn4",i," num_cont",
8682 c     &   num_cont_hb(i)
8683         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8684       enddo
8685       do ii=1,nat_sent
8686         i=iat_sent(ii)
8687 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8688 c     &    num_cont_hb(i)
8689         do j=1,num_cont_hb(i)
8690         do k=1,4
8691           jjc=jcont_hb(j,i)
8692           iproc=iint_sent_local(k,jjc,ii)
8693 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8694           if (iproc.ne.0) then
8695             ncont_sent(iproc)=ncont_sent(iproc)+1
8696             nn=ncont_sent(iproc)
8697             zapas(1,nn,iproc)=i
8698             zapas(2,nn,iproc)=jjc
8699             zapas(3,nn,iproc)=d_cont(j,i)
8700             ind=3
8701             do kk=1,3
8702               ind=ind+1
8703               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8704             enddo
8705             do kk=1,2
8706               do ll=1,2
8707                 ind=ind+1
8708                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8709               enddo
8710             enddo
8711             do jj=1,5
8712               do kk=1,3
8713                 do ll=1,2
8714                   do mm=1,2
8715                     ind=ind+1
8716                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8717                   enddo
8718                 enddo
8719               enddo
8720             enddo
8721           endif
8722         enddo
8723         enddo
8724       enddo
8725       if (lprn) then
8726       write (iout,*)
8727      &  "Numbers of contacts to be sent to other processors",
8728      &  (ncont_sent(i),i=1,ntask_cont_to)
8729       write (iout,*) "Contacts sent"
8730       do ii=1,ntask_cont_to
8731         nn=ncont_sent(ii)
8732         iproc=itask_cont_to(ii)
8733         write (iout,*) nn," contacts to processor",iproc,
8734      &   " of CONT_TO_COMM group"
8735         do i=1,nn
8736           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8737         enddo
8738       enddo
8739       call flush(iout)
8740       endif
8741       CorrelType=477
8742       CorrelID=fg_rank+1
8743       CorrelType1=478
8744       CorrelID1=nfgtasks+fg_rank+1
8745       ireq=0
8746 C Receive the numbers of needed contacts from other processors
8747       do ii=1,ntask_cont_from
8748         iproc=itask_cont_from(ii)
8749         ireq=ireq+1
8750         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8751      &    FG_COMM,req(ireq),IERR)
8752       enddo
8753 c      write (iout,*) "IRECV ended"
8754 c      call flush(iout)
8755 C Send the number of contacts needed by other processors
8756       do ii=1,ntask_cont_to
8757         iproc=itask_cont_to(ii)
8758         ireq=ireq+1
8759         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8760      &    FG_COMM,req(ireq),IERR)
8761       enddo
8762 c      write (iout,*) "ISEND ended"
8763 c      write (iout,*) "number of requests (nn)",ireq
8764       call flush(iout)
8765       if (ireq.gt.0)
8766      &  call MPI_Waitall(ireq,req,status_array,ierr)
8767 c      write (iout,*)
8768 c     &  "Numbers of contacts to be received from other processors",
8769 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8770 c      call flush(iout)
8771 C Receive contacts
8772       ireq=0
8773       do ii=1,ntask_cont_from
8774         iproc=itask_cont_from(ii)
8775         nn=ncont_recv(ii)
8776 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8777 c     &   " of CONT_TO_COMM group"
8778         call flush(iout)
8779         if (nn.gt.0) then
8780           ireq=ireq+1
8781           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8782      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8783 c          write (iout,*) "ireq,req",ireq,req(ireq)
8784         endif
8785       enddo
8786 C Send the contacts to processors that need them
8787       do ii=1,ntask_cont_to
8788         iproc=itask_cont_to(ii)
8789         nn=ncont_sent(ii)
8790 c        write (iout,*) nn," contacts to processor",iproc,
8791 c     &   " of CONT_TO_COMM group"
8792         if (nn.gt.0) then
8793           ireq=ireq+1
8794           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8795      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8796 c          write (iout,*) "ireq,req",ireq,req(ireq)
8797 c          do i=1,nn
8798 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8799 c          enddo
8800         endif
8801       enddo
8802 c      write (iout,*) "number of requests (contacts)",ireq
8803 c      write (iout,*) "req",(req(i),i=1,4)
8804 c      call flush(iout)
8805       if (ireq.gt.0)
8806      & call MPI_Waitall(ireq,req,status_array,ierr)
8807       do iii=1,ntask_cont_from
8808         iproc=itask_cont_from(iii)
8809         nn=ncont_recv(iii)
8810         if (lprn) then
8811         write (iout,*) "Received",nn," contacts from processor",iproc,
8812      &   " of CONT_FROM_COMM group"
8813         call flush(iout)
8814         do i=1,nn
8815           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8816         enddo
8817         call flush(iout)
8818         endif
8819         do i=1,nn
8820           ii=zapas_recv(1,i,iii)
8821 c Flag the received contacts to prevent double-counting
8822           jj=-zapas_recv(2,i,iii)
8823 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8824 c          call flush(iout)
8825           nnn=num_cont_hb(ii)+1
8826           num_cont_hb(ii)=nnn
8827           jcont_hb(nnn,ii)=jj
8828           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8829           ind=3
8830           do kk=1,3
8831             ind=ind+1
8832             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8833           enddo
8834           do kk=1,2
8835             do ll=1,2
8836               ind=ind+1
8837               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8838             enddo
8839           enddo
8840           do jj=1,5
8841             do kk=1,3
8842               do ll=1,2
8843                 do mm=1,2
8844                   ind=ind+1
8845                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8846                 enddo
8847               enddo
8848             enddo
8849           enddo
8850         enddo
8851       enddo
8852       call flush(iout)
8853       if (lprn) then
8854         write (iout,'(a)') 'Contact function values after receive:'
8855         do i=nnt,nct-2
8856           write (iout,'(2i3,50(1x,i3,5f6.3))')
8857      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8858      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8859         enddo
8860         call flush(iout)
8861       endif
8862    30 continue
8863 #endif
8864       if (lprn) then
8865         write (iout,'(a)') 'Contact function values:'
8866         do i=nnt,nct-2
8867           write (iout,'(2i3,50(1x,i2,5f6.3))')
8868      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8869      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8870         enddo
8871       endif
8872       ecorr=0.0D0
8873       ecorr5=0.0d0
8874       ecorr6=0.0d0
8875 C Remove the loop below after debugging !!!
8876       do i=nnt,nct
8877         do j=1,3
8878           gradcorr(j,i)=0.0D0
8879           gradxorr(j,i)=0.0D0
8880         enddo
8881       enddo
8882 C Calculate the dipole-dipole interaction energies
8883       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8884       do i=iatel_s,iatel_e+1
8885         num_conti=num_cont_hb(i)
8886         do jj=1,num_conti
8887           j=jcont_hb(jj,i)
8888 #ifdef MOMENT
8889           call dipole(i,j,jj)
8890 #endif
8891         enddo
8892       enddo
8893       endif
8894 C Calculate the local-electrostatic correlation terms
8895 c                write (iout,*) "gradcorr5 in eello5 before loop"
8896 c                do iii=1,nres
8897 c                  write (iout,'(i5,3f10.5)')
8898 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8899 c                enddo
8900       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8901 c        write (iout,*) "corr loop i",i
8902         i1=i+1
8903         num_conti=num_cont_hb(i)
8904         num_conti1=num_cont_hb(i+1)
8905         do jj=1,num_conti
8906           j=jcont_hb(jj,i)
8907           jp=iabs(j)
8908           do kk=1,num_conti1
8909             j1=jcont_hb(kk,i1)
8910             jp1=iabs(j1)
8911 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8912 c     &         ' jj=',jj,' kk=',kk
8913 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8914             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8915      &          .or. j.lt.0 .and. j1.gt.0) .and.
8916      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8917 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8918 C The system gains extra energy.
8919               n_corr=n_corr+1
8920               sqd1=dsqrt(d_cont(jj,i))
8921               sqd2=dsqrt(d_cont(kk,i1))
8922               sred_geom = sqd1*sqd2
8923               IF (sred_geom.lt.cutoff_corr) THEN
8924                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8925      &            ekont,fprimcont)
8926 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8927 cd     &         ' jj=',jj,' kk=',kk
8928                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8929                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8930                 do l=1,3
8931                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8932                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8933                 enddo
8934                 n_corr1=n_corr1+1
8935 cd               write (iout,*) 'sred_geom=',sred_geom,
8936 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8937 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8938 cd               write (iout,*) "g_contij",g_contij
8939 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8940 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8941                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8942                 if (wcorr4.gt.0.0d0)
8943      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8944 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8945                   if (energy_dec.and.wcorr4.gt.0.0d0)
8946      1                 write (iout,'(a6,4i5,0pf7.3)')
8947      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8948 c                write (iout,*) "gradcorr5 before eello5"
8949 c                do iii=1,nres
8950 c                  write (iout,'(i5,3f10.5)')
8951 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8952 c                enddo
8953                 if (wcorr5.gt.0.0d0)
8954      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8955 c                write (iout,*) "gradcorr5 after eello5"
8956 c                do iii=1,nres
8957 c                  write (iout,'(i5,3f10.5)')
8958 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8959 c                enddo
8960                   if (energy_dec.and.wcorr5.gt.0.0d0)
8961      1                 write (iout,'(a6,4i5,0pf7.3)')
8962      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8963 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8964 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8965                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8966      &               .or. wturn6.eq.0.0d0))then
8967 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8968                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8969                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8970      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8971 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8972 cd     &            'ecorr6=',ecorr6
8973 cd                write (iout,'(4e15.5)') sred_geom,
8974 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8975 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8976 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8977                 else if (wturn6.gt.0.0d0
8978      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8979 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8980                   eturn6=eturn6+eello_turn6(i,jj,kk)
8981                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8982      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8983 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8984                 endif
8985               ENDIF
8986 1111          continue
8987             endif
8988           enddo ! kk
8989         enddo ! jj
8990       enddo ! i
8991       do i=1,nres
8992         num_cont_hb(i)=num_cont_hb_old(i)
8993       enddo
8994 c                write (iout,*) "gradcorr5 in eello5"
8995 c                do iii=1,nres
8996 c                  write (iout,'(i5,3f10.5)')
8997 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8998 c                enddo
8999       return
9000       end
9001 c------------------------------------------------------------------------------
9002       subroutine add_hb_contact_eello(ii,jj,itask)
9003       implicit real*8 (a-h,o-z)
9004       include "DIMENSIONS"
9005       include "COMMON.IOUNITS"
9006       integer max_cont
9007       integer max_dim
9008       parameter (max_cont=maxconts)
9009       parameter (max_dim=70)
9010       include "COMMON.CONTACTS"
9011       double precision zapas(max_dim,maxconts,max_fg_procs),
9012      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9013       common /przechowalnia/ zapas
9014       integer i,j,ii,jj,iproc,itask(4),nn
9015 c      write (iout,*) "itask",itask
9016       do i=1,2
9017         iproc=itask(i)
9018         if (iproc.gt.0) then
9019           do j=1,num_cont_hb(ii)
9020             jjc=jcont_hb(j,ii)
9021 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9022             if (jjc.eq.jj) then
9023               ncont_sent(iproc)=ncont_sent(iproc)+1
9024               nn=ncont_sent(iproc)
9025               zapas(1,nn,iproc)=ii
9026               zapas(2,nn,iproc)=jjc
9027               zapas(3,nn,iproc)=d_cont(j,ii)
9028               ind=3
9029               do kk=1,3
9030                 ind=ind+1
9031                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9032               enddo
9033               do kk=1,2
9034                 do ll=1,2
9035                   ind=ind+1
9036                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9037                 enddo
9038               enddo
9039               do jj=1,5
9040                 do kk=1,3
9041                   do ll=1,2
9042                     do mm=1,2
9043                       ind=ind+1
9044                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9045                     enddo
9046                   enddo
9047                 enddo
9048               enddo
9049               exit
9050             endif
9051           enddo
9052         endif
9053       enddo
9054       return
9055       end
9056 c------------------------------------------------------------------------------
9057       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9058       implicit real*8 (a-h,o-z)
9059       include 'DIMENSIONS'
9060       include 'COMMON.IOUNITS'
9061       include 'COMMON.DERIV'
9062       include 'COMMON.INTERACT'
9063       include 'COMMON.CONTACTS'
9064       include 'COMMON.SHIELD'
9065       include 'COMMON.CONTROL'
9066       double precision gx(3),gx1(3)
9067       logical lprn
9068       lprn=.false.
9069 C      print *,"wchodze",fac_shield(i),shield_mode
9070       eij=facont_hb(jj,i)
9071       ekl=facont_hb(kk,k)
9072       ees0pij=ees0p(jj,i)
9073       ees0pkl=ees0p(kk,k)
9074       ees0mij=ees0m(jj,i)
9075       ees0mkl=ees0m(kk,k)
9076       ekont=eij*ekl
9077       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9078 C*
9079 C     & fac_shield(i)**2*fac_shield(j)**2
9080 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9081 C Following 4 lines for diagnostics.
9082 cd    ees0pkl=0.0D0
9083 cd    ees0pij=1.0D0
9084 cd    ees0mkl=0.0D0
9085 cd    ees0mij=1.0D0
9086 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9087 c     & 'Contacts ',i,j,
9088 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9089 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9090 c     & 'gradcorr_long'
9091 C Calculate the multi-body contribution to energy.
9092 C      ecorr=ecorr+ekont*ees
9093 C Calculate multi-body contributions to the gradient.
9094       coeffpees0pij=coeffp*ees0pij
9095       coeffmees0mij=coeffm*ees0mij
9096       coeffpees0pkl=coeffp*ees0pkl
9097       coeffmees0mkl=coeffm*ees0mkl
9098       do ll=1,3
9099 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9100         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9101      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9102      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9103         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9104      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9105      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9106 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9107         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9108      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9109      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9110         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9111      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9112      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9113         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9114      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9115      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9116         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9117         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9118         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9119      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9120      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9121         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9122         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9123 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9124       enddo
9125 c      write (iout,*)
9126 cgrad      do m=i+1,j-1
9127 cgrad        do ll=1,3
9128 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9129 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9130 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9131 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9132 cgrad        enddo
9133 cgrad      enddo
9134 cgrad      do m=k+1,l-1
9135 cgrad        do ll=1,3
9136 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9137 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9138 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9139 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9140 cgrad        enddo
9141 cgrad      enddo
9142 c      write (iout,*) "ehbcorr",ekont*ees
9143 C      print *,ekont,ees,i,k
9144       ehbcorr=ekont*ees
9145 C now gradient over shielding
9146 C      return
9147       if (shield_mode.gt.0) then
9148        j=ees0plist(jj,i)
9149        l=ees0plist(kk,k)
9150 C        print *,i,j,fac_shield(i),fac_shield(j),
9151 C     &fac_shield(k),fac_shield(l)
9152         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9153      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9154           do ilist=1,ishield_list(i)
9155            iresshield=shield_list(ilist,i)
9156            do m=1,3
9157            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9158 C     &      *2.0
9159            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9160      &              rlocshield
9161      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9162             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9163      &+rlocshield
9164            enddo
9165           enddo
9166           do ilist=1,ishield_list(j)
9167            iresshield=shield_list(ilist,j)
9168            do m=1,3
9169            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9170 C     &     *2.0
9171            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9172      &              rlocshield
9173      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9174            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9175      &     +rlocshield
9176            enddo
9177           enddo
9178
9179           do ilist=1,ishield_list(k)
9180            iresshield=shield_list(ilist,k)
9181            do m=1,3
9182            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9183 C     &     *2.0
9184            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9185      &              rlocshield
9186      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9187            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9188      &     +rlocshield
9189            enddo
9190           enddo
9191           do ilist=1,ishield_list(l)
9192            iresshield=shield_list(ilist,l)
9193            do m=1,3
9194            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9195 C     &     *2.0
9196            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9197      &              rlocshield
9198      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9199            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9200      &     +rlocshield
9201            enddo
9202           enddo
9203 C          print *,gshieldx(m,iresshield)
9204           do m=1,3
9205             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9206      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9207             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9208      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9209             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9210      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9211             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9212      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9213
9214             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9215      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9216             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9217      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9218             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9219      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9220             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9221      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9222
9223            enddo
9224       endif
9225       endif
9226       return
9227       end
9228 #ifdef MOMENT
9229 C---------------------------------------------------------------------------
9230       subroutine dipole(i,j,jj)
9231       implicit real*8 (a-h,o-z)
9232       include 'DIMENSIONS'
9233       include 'COMMON.IOUNITS'
9234       include 'COMMON.CHAIN'
9235       include 'COMMON.FFIELD'
9236       include 'COMMON.DERIV'
9237       include 'COMMON.INTERACT'
9238       include 'COMMON.CONTACTS'
9239       include 'COMMON.TORSION'
9240       include 'COMMON.VAR'
9241       include 'COMMON.GEO'
9242       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9243      &  auxmat(2,2)
9244       iti1 = itortyp(itype(i+1))
9245       if (j.lt.nres-1) then
9246         itj1 = itype2loc(itype(j+1))
9247       else
9248         itj1=nloctyp
9249       endif
9250       do iii=1,2
9251         dipi(iii,1)=Ub2(iii,i)
9252         dipderi(iii)=Ub2der(iii,i)
9253         dipi(iii,2)=b1(iii,i+1)
9254         dipj(iii,1)=Ub2(iii,j)
9255         dipderj(iii)=Ub2der(iii,j)
9256         dipj(iii,2)=b1(iii,j+1)
9257       enddo
9258       kkk=0
9259       do iii=1,2
9260         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9261         do jjj=1,2
9262           kkk=kkk+1
9263           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9264         enddo
9265       enddo
9266       do kkk=1,5
9267         do lll=1,3
9268           mmm=0
9269           do iii=1,2
9270             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9271      &        auxvec(1))
9272             do jjj=1,2
9273               mmm=mmm+1
9274               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9275             enddo
9276           enddo
9277         enddo
9278       enddo
9279       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9280       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9281       do iii=1,2
9282         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9283       enddo
9284       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9285       do iii=1,2
9286         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9287       enddo
9288       return
9289       end
9290 #endif
9291 C---------------------------------------------------------------------------
9292       subroutine calc_eello(i,j,k,l,jj,kk)
9293 C
9294 C This subroutine computes matrices and vectors needed to calculate
9295 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9296 C
9297       implicit real*8 (a-h,o-z)
9298       include 'DIMENSIONS'
9299       include 'COMMON.IOUNITS'
9300       include 'COMMON.CHAIN'
9301       include 'COMMON.DERIV'
9302       include 'COMMON.INTERACT'
9303       include 'COMMON.CONTACTS'
9304       include 'COMMON.TORSION'
9305       include 'COMMON.VAR'
9306       include 'COMMON.GEO'
9307       include 'COMMON.FFIELD'
9308       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9309      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9310       logical lprn
9311       common /kutas/ lprn
9312 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9313 cd     & ' jj=',jj,' kk=',kk
9314 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9315 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9316 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9317       do iii=1,2
9318         do jjj=1,2
9319           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9320           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9321         enddo
9322       enddo
9323       call transpose2(aa1(1,1),aa1t(1,1))
9324       call transpose2(aa2(1,1),aa2t(1,1))
9325       do kkk=1,5
9326         do lll=1,3
9327           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9328      &      aa1tder(1,1,lll,kkk))
9329           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9330      &      aa2tder(1,1,lll,kkk))
9331         enddo
9332       enddo
9333       if (l.eq.j+1) then
9334 C parallel orientation of the two CA-CA-CA frames.
9335         if (i.gt.1) then
9336           iti=itype2loc(itype(i))
9337         else
9338           iti=nloctyp
9339         endif
9340         itk1=itype2loc(itype(k+1))
9341         itj=itype2loc(itype(j))
9342         if (l.lt.nres-1) then
9343           itl1=itype2loc(itype(l+1))
9344         else
9345           itl1=nloctyp
9346         endif
9347 C A1 kernel(j+1) A2T
9348 cd        do iii=1,2
9349 cd          write (iout,'(3f10.5,5x,3f10.5)')
9350 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9351 cd        enddo
9352         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9353      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9354      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9355 C Following matrices are needed only for 6-th order cumulants
9356         IF (wcorr6.gt.0.0d0) THEN
9357         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9358      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9359      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9360         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9361      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9362      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9363      &   ADtEAderx(1,1,1,1,1,1))
9364         lprn=.false.
9365         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9366      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9367      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9368      &   ADtEA1derx(1,1,1,1,1,1))
9369         ENDIF
9370 C End 6-th order cumulants
9371 cd        lprn=.false.
9372 cd        if (lprn) then
9373 cd        write (2,*) 'In calc_eello6'
9374 cd        do iii=1,2
9375 cd          write (2,*) 'iii=',iii
9376 cd          do kkk=1,5
9377 cd            write (2,*) 'kkk=',kkk
9378 cd            do jjj=1,2
9379 cd              write (2,'(3(2f10.5),5x)')
9380 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9381 cd            enddo
9382 cd          enddo
9383 cd        enddo
9384 cd        endif
9385         call transpose2(EUgder(1,1,k),auxmat(1,1))
9386         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9387         call transpose2(EUg(1,1,k),auxmat(1,1))
9388         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9389         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9390         do iii=1,2
9391           do kkk=1,5
9392             do lll=1,3
9393               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9394      &          EAEAderx(1,1,lll,kkk,iii,1))
9395             enddo
9396           enddo
9397         enddo
9398 C A1T kernel(i+1) A2
9399         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9400      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9401      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9402 C Following matrices are needed only for 6-th order cumulants
9403         IF (wcorr6.gt.0.0d0) THEN
9404         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9405      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9406      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9407         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9408      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9409      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9410      &   ADtEAderx(1,1,1,1,1,2))
9411         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9412      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9413      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9414      &   ADtEA1derx(1,1,1,1,1,2))
9415         ENDIF
9416 C End 6-th order cumulants
9417         call transpose2(EUgder(1,1,l),auxmat(1,1))
9418         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9419         call transpose2(EUg(1,1,l),auxmat(1,1))
9420         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9421         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9422         do iii=1,2
9423           do kkk=1,5
9424             do lll=1,3
9425               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9426      &          EAEAderx(1,1,lll,kkk,iii,2))
9427             enddo
9428           enddo
9429         enddo
9430 C AEAb1 and AEAb2
9431 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9432 C They are needed only when the fifth- or the sixth-order cumulants are
9433 C indluded.
9434         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9435         call transpose2(AEA(1,1,1),auxmat(1,1))
9436         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9437         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9438         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9439         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9440         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9441         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9442         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9443         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9444         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9445         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9446         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9447         call transpose2(AEA(1,1,2),auxmat(1,1))
9448         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9449         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9450         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9451         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9452         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9453         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9454         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9455         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9456         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9457         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9458         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9459 C Calculate the Cartesian derivatives of the vectors.
9460         do iii=1,2
9461           do kkk=1,5
9462             do lll=1,3
9463               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9464               call matvec2(auxmat(1,1),b1(1,i),
9465      &          AEAb1derx(1,lll,kkk,iii,1,1))
9466               call matvec2(auxmat(1,1),Ub2(1,i),
9467      &          AEAb2derx(1,lll,kkk,iii,1,1))
9468               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9469      &          AEAb1derx(1,lll,kkk,iii,2,1))
9470               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9471      &          AEAb2derx(1,lll,kkk,iii,2,1))
9472               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9473               call matvec2(auxmat(1,1),b1(1,j),
9474      &          AEAb1derx(1,lll,kkk,iii,1,2))
9475               call matvec2(auxmat(1,1),Ub2(1,j),
9476      &          AEAb2derx(1,lll,kkk,iii,1,2))
9477               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9478      &          AEAb1derx(1,lll,kkk,iii,2,2))
9479               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9480      &          AEAb2derx(1,lll,kkk,iii,2,2))
9481             enddo
9482           enddo
9483         enddo
9484         ENDIF
9485 C End vectors
9486       else
9487 C Antiparallel orientation of the two CA-CA-CA frames.
9488         if (i.gt.1) then
9489           iti=itype2loc(itype(i))
9490         else
9491           iti=nloctyp
9492         endif
9493         itk1=itype2loc(itype(k+1))
9494         itl=itype2loc(itype(l))
9495         itj=itype2loc(itype(j))
9496         if (j.lt.nres-1) then
9497           itj1=itype2loc(itype(j+1))
9498         else
9499           itj1=nloctyp
9500         endif
9501 C A2 kernel(j-1)T A1T
9502         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9503      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9504      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9505 C Following matrices are needed only for 6-th order cumulants
9506         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9507      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9508         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9509      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9510      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9511         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9512      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9513      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9514      &   ADtEAderx(1,1,1,1,1,1))
9515         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9516      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9517      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9518      &   ADtEA1derx(1,1,1,1,1,1))
9519         ENDIF
9520 C End 6-th order cumulants
9521         call transpose2(EUgder(1,1,k),auxmat(1,1))
9522         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9523         call transpose2(EUg(1,1,k),auxmat(1,1))
9524         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9525         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9526         do iii=1,2
9527           do kkk=1,5
9528             do lll=1,3
9529               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9530      &          EAEAderx(1,1,lll,kkk,iii,1))
9531             enddo
9532           enddo
9533         enddo
9534 C A2T kernel(i+1)T A1
9535         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9536      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9537      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9538 C Following matrices are needed only for 6-th order cumulants
9539         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9540      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9541         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9542      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9543      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9544         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9545      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9546      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9547      &   ADtEAderx(1,1,1,1,1,2))
9548         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9549      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9550      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9551      &   ADtEA1derx(1,1,1,1,1,2))
9552         ENDIF
9553 C End 6-th order cumulants
9554         call transpose2(EUgder(1,1,j),auxmat(1,1))
9555         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9556         call transpose2(EUg(1,1,j),auxmat(1,1))
9557         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9558         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9559         do iii=1,2
9560           do kkk=1,5
9561             do lll=1,3
9562               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9563      &          EAEAderx(1,1,lll,kkk,iii,2))
9564             enddo
9565           enddo
9566         enddo
9567 C AEAb1 and AEAb2
9568 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9569 C They are needed only when the fifth- or the sixth-order cumulants are
9570 C indluded.
9571         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9572      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9573         call transpose2(AEA(1,1,1),auxmat(1,1))
9574         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9575         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9576         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9577         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9578         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9579         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9580         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9581         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9582         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9583         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9584         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9585         call transpose2(AEA(1,1,2),auxmat(1,1))
9586         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9587         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9588         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9589         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9590         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9591         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9592         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9593         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9594         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9595         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9596         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9597 C Calculate the Cartesian derivatives of the vectors.
9598         do iii=1,2
9599           do kkk=1,5
9600             do lll=1,3
9601               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9602               call matvec2(auxmat(1,1),b1(1,i),
9603      &          AEAb1derx(1,lll,kkk,iii,1,1))
9604               call matvec2(auxmat(1,1),Ub2(1,i),
9605      &          AEAb2derx(1,lll,kkk,iii,1,1))
9606               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9607      &          AEAb1derx(1,lll,kkk,iii,2,1))
9608               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9609      &          AEAb2derx(1,lll,kkk,iii,2,1))
9610               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9611               call matvec2(auxmat(1,1),b1(1,l),
9612      &          AEAb1derx(1,lll,kkk,iii,1,2))
9613               call matvec2(auxmat(1,1),Ub2(1,l),
9614      &          AEAb2derx(1,lll,kkk,iii,1,2))
9615               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9616      &          AEAb1derx(1,lll,kkk,iii,2,2))
9617               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9618      &          AEAb2derx(1,lll,kkk,iii,2,2))
9619             enddo
9620           enddo
9621         enddo
9622         ENDIF
9623 C End vectors
9624       endif
9625       return
9626       end
9627 C---------------------------------------------------------------------------
9628       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9629      &  KK,KKderg,AKA,AKAderg,AKAderx)
9630       implicit none
9631       integer nderg
9632       logical transp
9633       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9634      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9635      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9636       integer iii,kkk,lll
9637       integer jjj,mmm
9638       logical lprn
9639       common /kutas/ lprn
9640       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9641       do iii=1,nderg
9642         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9643      &    AKAderg(1,1,iii))
9644       enddo
9645 cd      if (lprn) write (2,*) 'In kernel'
9646       do kkk=1,5
9647 cd        if (lprn) write (2,*) 'kkk=',kkk
9648         do lll=1,3
9649           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9650      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9651 cd          if (lprn) then
9652 cd            write (2,*) 'lll=',lll
9653 cd            write (2,*) 'iii=1'
9654 cd            do jjj=1,2
9655 cd              write (2,'(3(2f10.5),5x)')
9656 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9657 cd            enddo
9658 cd          endif
9659           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9660      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9661 cd          if (lprn) then
9662 cd            write (2,*) 'lll=',lll
9663 cd            write (2,*) 'iii=2'
9664 cd            do jjj=1,2
9665 cd              write (2,'(3(2f10.5),5x)')
9666 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9667 cd            enddo
9668 cd          endif
9669         enddo
9670       enddo
9671       return
9672       end
9673 C---------------------------------------------------------------------------
9674       double precision function eello4(i,j,k,l,jj,kk)
9675       implicit real*8 (a-h,o-z)
9676       include 'DIMENSIONS'
9677       include 'COMMON.IOUNITS'
9678       include 'COMMON.CHAIN'
9679       include 'COMMON.DERIV'
9680       include 'COMMON.INTERACT'
9681       include 'COMMON.CONTACTS'
9682       include 'COMMON.TORSION'
9683       include 'COMMON.VAR'
9684       include 'COMMON.GEO'
9685       double precision pizda(2,2),ggg1(3),ggg2(3)
9686 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9687 cd        eello4=0.0d0
9688 cd        return
9689 cd      endif
9690 cd      print *,'eello4:',i,j,k,l,jj,kk
9691 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9692 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9693 cold      eij=facont_hb(jj,i)
9694 cold      ekl=facont_hb(kk,k)
9695 cold      ekont=eij*ekl
9696       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9697 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9698       gcorr_loc(k-1)=gcorr_loc(k-1)
9699      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9700       if (l.eq.j+1) then
9701         gcorr_loc(l-1)=gcorr_loc(l-1)
9702      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9703       else
9704         gcorr_loc(j-1)=gcorr_loc(j-1)
9705      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9706       endif
9707       do iii=1,2
9708         do kkk=1,5
9709           do lll=1,3
9710             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9711      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9712 cd            derx(lll,kkk,iii)=0.0d0
9713           enddo
9714         enddo
9715       enddo
9716 cd      gcorr_loc(l-1)=0.0d0
9717 cd      gcorr_loc(j-1)=0.0d0
9718 cd      gcorr_loc(k-1)=0.0d0
9719 cd      eel4=1.0d0
9720 cd      write (iout,*)'Contacts have occurred for peptide groups',
9721 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9722 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9723       if (j.lt.nres-1) then
9724         j1=j+1
9725         j2=j-1
9726       else
9727         j1=j-1
9728         j2=j-2
9729       endif
9730       if (l.lt.nres-1) then
9731         l1=l+1
9732         l2=l-1
9733       else
9734         l1=l-1
9735         l2=l-2
9736       endif
9737       do ll=1,3
9738 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9739 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9740         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9741         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9742 cgrad        ghalf=0.5d0*ggg1(ll)
9743         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9744         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9745         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9746         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9747         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9748         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9749 cgrad        ghalf=0.5d0*ggg2(ll)
9750         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9751         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9752         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9753         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9754         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9755         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9756       enddo
9757 cgrad      do m=i+1,j-1
9758 cgrad        do ll=1,3
9759 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9760 cgrad        enddo
9761 cgrad      enddo
9762 cgrad      do m=k+1,l-1
9763 cgrad        do ll=1,3
9764 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9765 cgrad        enddo
9766 cgrad      enddo
9767 cgrad      do m=i+2,j2
9768 cgrad        do ll=1,3
9769 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9770 cgrad        enddo
9771 cgrad      enddo
9772 cgrad      do m=k+2,l2
9773 cgrad        do ll=1,3
9774 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9775 cgrad        enddo
9776 cgrad      enddo
9777 cd      do iii=1,nres-3
9778 cd        write (2,*) iii,gcorr_loc(iii)
9779 cd      enddo
9780       eello4=ekont*eel4
9781 cd      write (2,*) 'ekont',ekont
9782 cd      write (iout,*) 'eello4',ekont*eel4
9783       return
9784       end
9785 C---------------------------------------------------------------------------
9786       double precision function eello5(i,j,k,l,jj,kk)
9787       implicit real*8 (a-h,o-z)
9788       include 'DIMENSIONS'
9789       include 'COMMON.IOUNITS'
9790       include 'COMMON.CHAIN'
9791       include 'COMMON.DERIV'
9792       include 'COMMON.INTERACT'
9793       include 'COMMON.CONTACTS'
9794       include 'COMMON.TORSION'
9795       include 'COMMON.VAR'
9796       include 'COMMON.GEO'
9797       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9798       double precision ggg1(3),ggg2(3)
9799 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9800 C                                                                              C
9801 C                            Parallel chains                                   C
9802 C                                                                              C
9803 C          o             o                   o             o                   C
9804 C         /l\           / \             \   / \           / \   /              C
9805 C        /   \         /   \             \ /   \         /   \ /               C
9806 C       j| o |l1       | o |              o| o |         | o |o                C
9807 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9808 C      \i/   \         /   \ /             /   \         /   \                 C
9809 C       o    k1             o                                                  C
9810 C         (I)          (II)                (III)          (IV)                 C
9811 C                                                                              C
9812 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9813 C                                                                              C
9814 C                            Antiparallel chains                               C
9815 C                                                                              C
9816 C          o             o                   o             o                   C
9817 C         /j\           / \             \   / \           / \   /              C
9818 C        /   \         /   \             \ /   \         /   \ /               C
9819 C      j1| o |l        | o |              o| o |         | o |o                C
9820 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9821 C      \i/   \         /   \ /             /   \         /   \                 C
9822 C       o     k1            o                                                  C
9823 C         (I)          (II)                (III)          (IV)                 C
9824 C                                                                              C
9825 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9826 C                                                                              C
9827 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9828 C                                                                              C
9829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9830 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9831 cd        eello5=0.0d0
9832 cd        return
9833 cd      endif
9834 cd      write (iout,*)
9835 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9836 cd     &   ' and',k,l
9837       itk=itype2loc(itype(k))
9838       itl=itype2loc(itype(l))
9839       itj=itype2loc(itype(j))
9840       eello5_1=0.0d0
9841       eello5_2=0.0d0
9842       eello5_3=0.0d0
9843       eello5_4=0.0d0
9844 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9845 cd     &   eel5_3_num,eel5_4_num)
9846       do iii=1,2
9847         do kkk=1,5
9848           do lll=1,3
9849             derx(lll,kkk,iii)=0.0d0
9850           enddo
9851         enddo
9852       enddo
9853 cd      eij=facont_hb(jj,i)
9854 cd      ekl=facont_hb(kk,k)
9855 cd      ekont=eij*ekl
9856 cd      write (iout,*)'Contacts have occurred for peptide groups',
9857 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9858 cd      goto 1111
9859 C Contribution from the graph I.
9860 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9861 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9862       call transpose2(EUg(1,1,k),auxmat(1,1))
9863       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9864       vv(1)=pizda(1,1)-pizda(2,2)
9865       vv(2)=pizda(1,2)+pizda(2,1)
9866       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9867      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9868 C Explicit gradient in virtual-dihedral angles.
9869       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9870      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9871      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9872       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9873       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9874       vv(1)=pizda(1,1)-pizda(2,2)
9875       vv(2)=pizda(1,2)+pizda(2,1)
9876       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9877      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9878      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9879       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9880       vv(1)=pizda(1,1)-pizda(2,2)
9881       vv(2)=pizda(1,2)+pizda(2,1)
9882       if (l.eq.j+1) then
9883         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9884      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9885      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9886       else
9887         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9888      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9889      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9890       endif
9891 C Cartesian gradient
9892       do iii=1,2
9893         do kkk=1,5
9894           do lll=1,3
9895             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9896      &        pizda(1,1))
9897             vv(1)=pizda(1,1)-pizda(2,2)
9898             vv(2)=pizda(1,2)+pizda(2,1)
9899             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9900      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9901      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9902           enddo
9903         enddo
9904       enddo
9905 c      goto 1112
9906 c1111  continue
9907 C Contribution from graph II
9908       call transpose2(EE(1,1,k),auxmat(1,1))
9909       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9910       vv(1)=pizda(1,1)+pizda(2,2)
9911       vv(2)=pizda(2,1)-pizda(1,2)
9912       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9913      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9914 C Explicit gradient in virtual-dihedral angles.
9915       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9916      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9917       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9918       vv(1)=pizda(1,1)+pizda(2,2)
9919       vv(2)=pizda(2,1)-pizda(1,2)
9920       if (l.eq.j+1) then
9921         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9922      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9923      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9924       else
9925         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9926      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9927      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9928       endif
9929 C Cartesian gradient
9930       do iii=1,2
9931         do kkk=1,5
9932           do lll=1,3
9933             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9934      &        pizda(1,1))
9935             vv(1)=pizda(1,1)+pizda(2,2)
9936             vv(2)=pizda(2,1)-pizda(1,2)
9937             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9938      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9939      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9940           enddo
9941         enddo
9942       enddo
9943 cd      goto 1112
9944 cd1111  continue
9945       if (l.eq.j+1) then
9946 cd        goto 1110
9947 C Parallel orientation
9948 C Contribution from graph III
9949         call transpose2(EUg(1,1,l),auxmat(1,1))
9950         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9951         vv(1)=pizda(1,1)-pizda(2,2)
9952         vv(2)=pizda(1,2)+pizda(2,1)
9953         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9954      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9955 C Explicit gradient in virtual-dihedral angles.
9956         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9957      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9958      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9959         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9960         vv(1)=pizda(1,1)-pizda(2,2)
9961         vv(2)=pizda(1,2)+pizda(2,1)
9962         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9963      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9964      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9965         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9966         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9967         vv(1)=pizda(1,1)-pizda(2,2)
9968         vv(2)=pizda(1,2)+pizda(2,1)
9969         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9970      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9971      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9972 C Cartesian gradient
9973         do iii=1,2
9974           do kkk=1,5
9975             do lll=1,3
9976               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9977      &          pizda(1,1))
9978               vv(1)=pizda(1,1)-pizda(2,2)
9979               vv(2)=pizda(1,2)+pizda(2,1)
9980               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9981      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9982      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9983             enddo
9984           enddo
9985         enddo
9986 cd        goto 1112
9987 C Contribution from graph IV
9988 cd1110    continue
9989         call transpose2(EE(1,1,l),auxmat(1,1))
9990         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9991         vv(1)=pizda(1,1)+pizda(2,2)
9992         vv(2)=pizda(2,1)-pizda(1,2)
9993         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9994      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9995 C Explicit gradient in virtual-dihedral angles.
9996         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9997      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9998         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9999         vv(1)=pizda(1,1)+pizda(2,2)
10000         vv(2)=pizda(2,1)-pizda(1,2)
10001         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10002      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10003      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10004 C Cartesian gradient
10005         do iii=1,2
10006           do kkk=1,5
10007             do lll=1,3
10008               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10009      &          pizda(1,1))
10010               vv(1)=pizda(1,1)+pizda(2,2)
10011               vv(2)=pizda(2,1)-pizda(1,2)
10012               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10013      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10014      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10015             enddo
10016           enddo
10017         enddo
10018       else
10019 C Antiparallel orientation
10020 C Contribution from graph III
10021 c        goto 1110
10022         call transpose2(EUg(1,1,j),auxmat(1,1))
10023         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10024         vv(1)=pizda(1,1)-pizda(2,2)
10025         vv(2)=pizda(1,2)+pizda(2,1)
10026         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10027      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10028 C Explicit gradient in virtual-dihedral angles.
10029         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10030      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10031      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10032         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10033         vv(1)=pizda(1,1)-pizda(2,2)
10034         vv(2)=pizda(1,2)+pizda(2,1)
10035         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10036      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10037      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10038         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10039         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10040         vv(1)=pizda(1,1)-pizda(2,2)
10041         vv(2)=pizda(1,2)+pizda(2,1)
10042         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10043      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10044      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10045 C Cartesian gradient
10046         do iii=1,2
10047           do kkk=1,5
10048             do lll=1,3
10049               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10050      &          pizda(1,1))
10051               vv(1)=pizda(1,1)-pizda(2,2)
10052               vv(2)=pizda(1,2)+pizda(2,1)
10053               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10054      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10055      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10056             enddo
10057           enddo
10058         enddo
10059 cd        goto 1112
10060 C Contribution from graph IV
10061 1110    continue
10062         call transpose2(EE(1,1,j),auxmat(1,1))
10063         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10064         vv(1)=pizda(1,1)+pizda(2,2)
10065         vv(2)=pizda(2,1)-pizda(1,2)
10066         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10067      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10068 C Explicit gradient in virtual-dihedral angles.
10069         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10070      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10071         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10072         vv(1)=pizda(1,1)+pizda(2,2)
10073         vv(2)=pizda(2,1)-pizda(1,2)
10074         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10075      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10076      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10077 C Cartesian gradient
10078         do iii=1,2
10079           do kkk=1,5
10080             do lll=1,3
10081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10082      &          pizda(1,1))
10083               vv(1)=pizda(1,1)+pizda(2,2)
10084               vv(2)=pizda(2,1)-pizda(1,2)
10085               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10086      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10087      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10088             enddo
10089           enddo
10090         enddo
10091       endif
10092 1112  continue
10093       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10094 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10095 cd        write (2,*) 'ijkl',i,j,k,l
10096 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10097 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10098 cd      endif
10099 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10100 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10101 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10102 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10103       if (j.lt.nres-1) then
10104         j1=j+1
10105         j2=j-1
10106       else
10107         j1=j-1
10108         j2=j-2
10109       endif
10110       if (l.lt.nres-1) then
10111         l1=l+1
10112         l2=l-1
10113       else
10114         l1=l-1
10115         l2=l-2
10116       endif
10117 cd      eij=1.0d0
10118 cd      ekl=1.0d0
10119 cd      ekont=1.0d0
10120 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10121 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10122 C        summed up outside the subrouine as for the other subroutines
10123 C        handling long-range interactions. The old code is commented out
10124 C        with "cgrad" to keep track of changes.
10125       do ll=1,3
10126 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10127 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10128         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10129         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10130 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10131 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10132 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10133 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10134 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10135 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10136 c     &   gradcorr5ij,
10137 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10138 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10139 cgrad        ghalf=0.5d0*ggg1(ll)
10140 cd        ghalf=0.0d0
10141         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10142         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10143         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10144         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10145         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10146         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10147 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10148 cgrad        ghalf=0.5d0*ggg2(ll)
10149 cd        ghalf=0.0d0
10150         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10151         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10152         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10153         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10154         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10155         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10156       enddo
10157 cd      goto 1112
10158 cgrad      do m=i+1,j-1
10159 cgrad        do ll=1,3
10160 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10161 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10162 cgrad        enddo
10163 cgrad      enddo
10164 cgrad      do m=k+1,l-1
10165 cgrad        do ll=1,3
10166 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10167 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10168 cgrad        enddo
10169 cgrad      enddo
10170 c1112  continue
10171 cgrad      do m=i+2,j2
10172 cgrad        do ll=1,3
10173 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10174 cgrad        enddo
10175 cgrad      enddo
10176 cgrad      do m=k+2,l2
10177 cgrad        do ll=1,3
10178 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10179 cgrad        enddo
10180 cgrad      enddo
10181 cd      do iii=1,nres-3
10182 cd        write (2,*) iii,g_corr5_loc(iii)
10183 cd      enddo
10184       eello5=ekont*eel5
10185 cd      write (2,*) 'ekont',ekont
10186 cd      write (iout,*) 'eello5',ekont*eel5
10187       return
10188       end
10189 c--------------------------------------------------------------------------
10190       double precision function eello6(i,j,k,l,jj,kk)
10191       implicit real*8 (a-h,o-z)
10192       include 'DIMENSIONS'
10193       include 'COMMON.IOUNITS'
10194       include 'COMMON.CHAIN'
10195       include 'COMMON.DERIV'
10196       include 'COMMON.INTERACT'
10197       include 'COMMON.CONTACTS'
10198       include 'COMMON.TORSION'
10199       include 'COMMON.VAR'
10200       include 'COMMON.GEO'
10201       include 'COMMON.FFIELD'
10202       double precision ggg1(3),ggg2(3)
10203 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10204 cd        eello6=0.0d0
10205 cd        return
10206 cd      endif
10207 cd      write (iout,*)
10208 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10209 cd     &   ' and',k,l
10210       eello6_1=0.0d0
10211       eello6_2=0.0d0
10212       eello6_3=0.0d0
10213       eello6_4=0.0d0
10214       eello6_5=0.0d0
10215       eello6_6=0.0d0
10216 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10217 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10218       do iii=1,2
10219         do kkk=1,5
10220           do lll=1,3
10221             derx(lll,kkk,iii)=0.0d0
10222           enddo
10223         enddo
10224       enddo
10225 cd      eij=facont_hb(jj,i)
10226 cd      ekl=facont_hb(kk,k)
10227 cd      ekont=eij*ekl
10228 cd      eij=1.0d0
10229 cd      ekl=1.0d0
10230 cd      ekont=1.0d0
10231       if (l.eq.j+1) then
10232         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10233         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10234         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10235         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10236         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10237         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10238       else
10239         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10240         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10241         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10242         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10243         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10244           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10245         else
10246           eello6_5=0.0d0
10247         endif
10248         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10249       endif
10250 C If turn contributions are considered, they will be handled separately.
10251       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10252 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10253 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10254 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10255 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10256 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10257 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10258 cd      goto 1112
10259       if (j.lt.nres-1) then
10260         j1=j+1
10261         j2=j-1
10262       else
10263         j1=j-1
10264         j2=j-2
10265       endif
10266       if (l.lt.nres-1) then
10267         l1=l+1
10268         l2=l-1
10269       else
10270         l1=l-1
10271         l2=l-2
10272       endif
10273       do ll=1,3
10274 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10275 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10276 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10277 cgrad        ghalf=0.5d0*ggg1(ll)
10278 cd        ghalf=0.0d0
10279         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10280         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10281         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10282         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10283         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10284         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10285         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10286         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10287 cgrad        ghalf=0.5d0*ggg2(ll)
10288 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10289 cd        ghalf=0.0d0
10290         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10291         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10292         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10293         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10294         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10295         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10296       enddo
10297 cd      goto 1112
10298 cgrad      do m=i+1,j-1
10299 cgrad        do ll=1,3
10300 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10301 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10302 cgrad        enddo
10303 cgrad      enddo
10304 cgrad      do m=k+1,l-1
10305 cgrad        do ll=1,3
10306 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10307 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10308 cgrad        enddo
10309 cgrad      enddo
10310 cgrad1112  continue
10311 cgrad      do m=i+2,j2
10312 cgrad        do ll=1,3
10313 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10314 cgrad        enddo
10315 cgrad      enddo
10316 cgrad      do m=k+2,l2
10317 cgrad        do ll=1,3
10318 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10319 cgrad        enddo
10320 cgrad      enddo
10321 cd      do iii=1,nres-3
10322 cd        write (2,*) iii,g_corr6_loc(iii)
10323 cd      enddo
10324       eello6=ekont*eel6
10325 cd      write (2,*) 'ekont',ekont
10326 cd      write (iout,*) 'eello6',ekont*eel6
10327       return
10328       end
10329 c--------------------------------------------------------------------------
10330       double precision function eello6_graph1(i,j,k,l,imat,swap)
10331       implicit real*8 (a-h,o-z)
10332       include 'DIMENSIONS'
10333       include 'COMMON.IOUNITS'
10334       include 'COMMON.CHAIN'
10335       include 'COMMON.DERIV'
10336       include 'COMMON.INTERACT'
10337       include 'COMMON.CONTACTS'
10338       include 'COMMON.TORSION'
10339       include 'COMMON.VAR'
10340       include 'COMMON.GEO'
10341       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10342       logical swap
10343       logical lprn
10344       common /kutas/ lprn
10345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10346 C                                                                              C
10347 C      Parallel       Antiparallel                                             C
10348 C                                                                              C
10349 C          o             o                                                     C
10350 C         /l\           /j\                                                    C
10351 C        /   \         /   \                                                   C
10352 C       /| o |         | o |\                                                  C
10353 C     \ j|/k\|  /   \  |/k\|l /                                                C
10354 C      \ /   \ /     \ /   \ /                                                 C
10355 C       o     o       o     o                                                  C
10356 C       i             i                                                        C
10357 C                                                                              C
10358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10359       itk=itype2loc(itype(k))
10360       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10361       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10362       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10363       call transpose2(EUgC(1,1,k),auxmat(1,1))
10364       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10365       vv1(1)=pizda1(1,1)-pizda1(2,2)
10366       vv1(2)=pizda1(1,2)+pizda1(2,1)
10367       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10368       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10369       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10370       s5=scalar2(vv(1),Dtobr2(1,i))
10371 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10372       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10373       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10374      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10375      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10376      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10377      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10378      & +scalar2(vv(1),Dtobr2der(1,i)))
10379       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10380       vv1(1)=pizda1(1,1)-pizda1(2,2)
10381       vv1(2)=pizda1(1,2)+pizda1(2,1)
10382       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10383       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10384       if (l.eq.j+1) then
10385         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10386      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10387      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10388      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10389      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10390       else
10391         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10392      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10393      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10394      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10395      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10396       endif
10397       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10398       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10399       vv1(1)=pizda1(1,1)-pizda1(2,2)
10400       vv1(2)=pizda1(1,2)+pizda1(2,1)
10401       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10402      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10403      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10404      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10405       do iii=1,2
10406         if (swap) then
10407           ind=3-iii
10408         else
10409           ind=iii
10410         endif
10411         do kkk=1,5
10412           do lll=1,3
10413             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10414             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10415             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10416             call transpose2(EUgC(1,1,k),auxmat(1,1))
10417             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10418      &        pizda1(1,1))
10419             vv1(1)=pizda1(1,1)-pizda1(2,2)
10420             vv1(2)=pizda1(1,2)+pizda1(2,1)
10421             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10422             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10423      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10424             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10425      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10426             s5=scalar2(vv(1),Dtobr2(1,i))
10427             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10428           enddo
10429         enddo
10430       enddo
10431       return
10432       end
10433 c----------------------------------------------------------------------------
10434       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10435       implicit real*8 (a-h,o-z)
10436       include 'DIMENSIONS'
10437       include 'COMMON.IOUNITS'
10438       include 'COMMON.CHAIN'
10439       include 'COMMON.DERIV'
10440       include 'COMMON.INTERACT'
10441       include 'COMMON.CONTACTS'
10442       include 'COMMON.TORSION'
10443       include 'COMMON.VAR'
10444       include 'COMMON.GEO'
10445       logical swap
10446       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10447      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10448       logical lprn
10449       common /kutas/ lprn
10450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10451 C                                                                              C
10452 C      Parallel       Antiparallel                                             C
10453 C                                                                              C
10454 C          o             o                                                     C
10455 C     \   /l\           /j\   /                                                C
10456 C      \ /   \         /   \ /                                                 C
10457 C       o| o |         | o |o                                                  C
10458 C     \ j|/k\|      \  |/k\|l                                                  C
10459 C      \ /   \       \ /   \                                                   C
10460 C       o             o                                                        C
10461 C       i             i                                                        C
10462 C                                                                              C
10463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10464 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10465 C AL 7/4/01 s1 would occur in the sixth-order moment,
10466 C           but not in a cluster cumulant
10467 #ifdef MOMENT
10468       s1=dip(1,jj,i)*dip(1,kk,k)
10469 #endif
10470       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10471       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10472       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10473       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10474       call transpose2(EUg(1,1,k),auxmat(1,1))
10475       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10476       vv(1)=pizda(1,1)-pizda(2,2)
10477       vv(2)=pizda(1,2)+pizda(2,1)
10478       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10479 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10480 #ifdef MOMENT
10481       eello6_graph2=-(s1+s2+s3+s4)
10482 #else
10483       eello6_graph2=-(s2+s3+s4)
10484 #endif
10485 c      eello6_graph2=-s3
10486 C Derivatives in gamma(i-1)
10487       if (i.gt.1) then
10488 #ifdef MOMENT
10489         s1=dipderg(1,jj,i)*dip(1,kk,k)
10490 #endif
10491         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10492         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10493         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10494         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10495 #ifdef MOMENT
10496         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10497 #else
10498         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10499 #endif
10500 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10501       endif
10502 C Derivatives in gamma(k-1)
10503 #ifdef MOMENT
10504       s1=dip(1,jj,i)*dipderg(1,kk,k)
10505 #endif
10506       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10507       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10508       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10509       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10510       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10511       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10512       vv(1)=pizda(1,1)-pizda(2,2)
10513       vv(2)=pizda(1,2)+pizda(2,1)
10514       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10515 #ifdef MOMENT
10516       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10517 #else
10518       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10519 #endif
10520 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10521 C Derivatives in gamma(j-1) or gamma(l-1)
10522       if (j.gt.1) then
10523 #ifdef MOMENT
10524         s1=dipderg(3,jj,i)*dip(1,kk,k)
10525 #endif
10526         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10527         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10528         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10529         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10530         vv(1)=pizda(1,1)-pizda(2,2)
10531         vv(2)=pizda(1,2)+pizda(2,1)
10532         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10533 #ifdef MOMENT
10534         if (swap) then
10535           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10536         else
10537           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10538         endif
10539 #endif
10540         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10541 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10542       endif
10543 C Derivatives in gamma(l-1) or gamma(j-1)
10544       if (l.gt.1) then
10545 #ifdef MOMENT
10546         s1=dip(1,jj,i)*dipderg(3,kk,k)
10547 #endif
10548         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10549         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10550         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10551         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10552         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10553         vv(1)=pizda(1,1)-pizda(2,2)
10554         vv(2)=pizda(1,2)+pizda(2,1)
10555         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10556 #ifdef MOMENT
10557         if (swap) then
10558           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10559         else
10560           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10561         endif
10562 #endif
10563         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10564 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10565       endif
10566 C Cartesian derivatives.
10567       if (lprn) then
10568         write (2,*) 'In eello6_graph2'
10569         do iii=1,2
10570           write (2,*) 'iii=',iii
10571           do kkk=1,5
10572             write (2,*) 'kkk=',kkk
10573             do jjj=1,2
10574               write (2,'(3(2f10.5),5x)')
10575      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10576             enddo
10577           enddo
10578         enddo
10579       endif
10580       do iii=1,2
10581         do kkk=1,5
10582           do lll=1,3
10583 #ifdef MOMENT
10584             if (iii.eq.1) then
10585               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10586             else
10587               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10588             endif
10589 #endif
10590             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10591      &        auxvec(1))
10592             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10593             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10594      &        auxvec(1))
10595             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10596             call transpose2(EUg(1,1,k),auxmat(1,1))
10597             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10598      &        pizda(1,1))
10599             vv(1)=pizda(1,1)-pizda(2,2)
10600             vv(2)=pizda(1,2)+pizda(2,1)
10601             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10602 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10603 #ifdef MOMENT
10604             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10605 #else
10606             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10607 #endif
10608             if (swap) then
10609               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10610             else
10611               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10612             endif
10613           enddo
10614         enddo
10615       enddo
10616       return
10617       end
10618 c----------------------------------------------------------------------------
10619       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10620       implicit real*8 (a-h,o-z)
10621       include 'DIMENSIONS'
10622       include 'COMMON.IOUNITS'
10623       include 'COMMON.CHAIN'
10624       include 'COMMON.DERIV'
10625       include 'COMMON.INTERACT'
10626       include 'COMMON.CONTACTS'
10627       include 'COMMON.TORSION'
10628       include 'COMMON.VAR'
10629       include 'COMMON.GEO'
10630       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10631       logical swap
10632 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10633 C                                                                              C
10634 C      Parallel       Antiparallel                                             C
10635 C                                                                              C
10636 C          o             o                                                     C
10637 C         /l\   /   \   /j\                                                    C
10638 C        /   \ /     \ /   \                                                   C
10639 C       /| o |o       o| o |\                                                  C
10640 C       j|/k\|  /      |/k\|l /                                                C
10641 C        /   \ /       /   \ /                                                 C
10642 C       /     o       /     o                                                  C
10643 C       i             i                                                        C
10644 C                                                                              C
10645 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10646 C
10647 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10648 C           energy moment and not to the cluster cumulant.
10649       iti=itortyp(itype(i))
10650       if (j.lt.nres-1) then
10651         itj1=itype2loc(itype(j+1))
10652       else
10653         itj1=nloctyp
10654       endif
10655       itk=itype2loc(itype(k))
10656       itk1=itype2loc(itype(k+1))
10657       if (l.lt.nres-1) then
10658         itl1=itype2loc(itype(l+1))
10659       else
10660         itl1=nloctyp
10661       endif
10662 #ifdef MOMENT
10663       s1=dip(4,jj,i)*dip(4,kk,k)
10664 #endif
10665       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10666       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10667       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10668       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10669       call transpose2(EE(1,1,k),auxmat(1,1))
10670       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10671       vv(1)=pizda(1,1)+pizda(2,2)
10672       vv(2)=pizda(2,1)-pizda(1,2)
10673       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10674 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10675 cd     & "sum",-(s2+s3+s4)
10676 #ifdef MOMENT
10677       eello6_graph3=-(s1+s2+s3+s4)
10678 #else
10679       eello6_graph3=-(s2+s3+s4)
10680 #endif
10681 c      eello6_graph3=-s4
10682 C Derivatives in gamma(k-1)
10683       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10684       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10685       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10686       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10687 C Derivatives in gamma(l-1)
10688       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10689       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10690       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10691       vv(1)=pizda(1,1)+pizda(2,2)
10692       vv(2)=pizda(2,1)-pizda(1,2)
10693       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10694       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10695 C Cartesian derivatives.
10696       do iii=1,2
10697         do kkk=1,5
10698           do lll=1,3
10699 #ifdef MOMENT
10700             if (iii.eq.1) then
10701               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10702             else
10703               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10704             endif
10705 #endif
10706             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10707      &        auxvec(1))
10708             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10709             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10710      &        auxvec(1))
10711             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10712             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10713      &        pizda(1,1))
10714             vv(1)=pizda(1,1)+pizda(2,2)
10715             vv(2)=pizda(2,1)-pizda(1,2)
10716             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10717 #ifdef MOMENT
10718             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10719 #else
10720             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10721 #endif
10722             if (swap) then
10723               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10724             else
10725               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10726             endif
10727 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10728           enddo
10729         enddo
10730       enddo
10731       return
10732       end
10733 c----------------------------------------------------------------------------
10734       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10735       implicit real*8 (a-h,o-z)
10736       include 'DIMENSIONS'
10737       include 'COMMON.IOUNITS'
10738       include 'COMMON.CHAIN'
10739       include 'COMMON.DERIV'
10740       include 'COMMON.INTERACT'
10741       include 'COMMON.CONTACTS'
10742       include 'COMMON.TORSION'
10743       include 'COMMON.VAR'
10744       include 'COMMON.GEO'
10745       include 'COMMON.FFIELD'
10746       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10747      & auxvec1(2),auxmat1(2,2)
10748       logical swap
10749 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10750 C                                                                              C
10751 C      Parallel       Antiparallel                                             C
10752 C                                                                              C
10753 C          o             o                                                     C
10754 C         /l\   /   \   /j\                                                    C
10755 C        /   \ /     \ /   \                                                   C
10756 C       /| o |o       o| o |\                                                  C
10757 C     \ j|/k\|      \  |/k\|l                                                  C
10758 C      \ /   \       \ /   \                                                   C
10759 C       o     \       o     \                                                  C
10760 C       i             i                                                        C
10761 C                                                                              C
10762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10763 C
10764 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10765 C           energy moment and not to the cluster cumulant.
10766 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10767       iti=itype2loc(itype(i))
10768       itj=itype2loc(itype(j))
10769       if (j.lt.nres-1) then
10770         itj1=itype2loc(itype(j+1))
10771       else
10772         itj1=nloctyp
10773       endif
10774       itk=itype2loc(itype(k))
10775       if (k.lt.nres-1) then
10776         itk1=itype2loc(itype(k+1))
10777       else
10778         itk1=nloctyp
10779       endif
10780       itl=itype2loc(itype(l))
10781       if (l.lt.nres-1) then
10782         itl1=itype2loc(itype(l+1))
10783       else
10784         itl1=nloctyp
10785       endif
10786 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10787 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10788 cd     & ' itl',itl,' itl1',itl1
10789 #ifdef MOMENT
10790       if (imat.eq.1) then
10791         s1=dip(3,jj,i)*dip(3,kk,k)
10792       else
10793         s1=dip(2,jj,j)*dip(2,kk,l)
10794       endif
10795 #endif
10796       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10797       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10798       if (j.eq.l+1) then
10799         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10800         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10801       else
10802         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10803         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10804       endif
10805       call transpose2(EUg(1,1,k),auxmat(1,1))
10806       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10807       vv(1)=pizda(1,1)-pizda(2,2)
10808       vv(2)=pizda(2,1)+pizda(1,2)
10809       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10810 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10811 #ifdef MOMENT
10812       eello6_graph4=-(s1+s2+s3+s4)
10813 #else
10814       eello6_graph4=-(s2+s3+s4)
10815 #endif
10816 C Derivatives in gamma(i-1)
10817       if (i.gt.1) then
10818 #ifdef MOMENT
10819         if (imat.eq.1) then
10820           s1=dipderg(2,jj,i)*dip(3,kk,k)
10821         else
10822           s1=dipderg(4,jj,j)*dip(2,kk,l)
10823         endif
10824 #endif
10825         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10826         if (j.eq.l+1) then
10827           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10828           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10829         else
10830           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10831           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10832         endif
10833         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10834         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10835 cd          write (2,*) 'turn6 derivatives'
10836 #ifdef MOMENT
10837           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10838 #else
10839           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10840 #endif
10841         else
10842 #ifdef MOMENT
10843           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10844 #else
10845           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10846 #endif
10847         endif
10848       endif
10849 C Derivatives in gamma(k-1)
10850 #ifdef MOMENT
10851       if (imat.eq.1) then
10852         s1=dip(3,jj,i)*dipderg(2,kk,k)
10853       else
10854         s1=dip(2,jj,j)*dipderg(4,kk,l)
10855       endif
10856 #endif
10857       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10858       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10859       if (j.eq.l+1) then
10860         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10861         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10862       else
10863         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10864         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10865       endif
10866       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10867       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10868       vv(1)=pizda(1,1)-pizda(2,2)
10869       vv(2)=pizda(2,1)+pizda(1,2)
10870       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10871       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10872 #ifdef MOMENT
10873         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10874 #else
10875         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10876 #endif
10877       else
10878 #ifdef MOMENT
10879         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10880 #else
10881         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10882 #endif
10883       endif
10884 C Derivatives in gamma(j-1) or gamma(l-1)
10885       if (l.eq.j+1 .and. l.gt.1) then
10886         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10887         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10888         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10889         vv(1)=pizda(1,1)-pizda(2,2)
10890         vv(2)=pizda(2,1)+pizda(1,2)
10891         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10892         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10893       else if (j.gt.1) then
10894         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10895         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10896         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10897         vv(1)=pizda(1,1)-pizda(2,2)
10898         vv(2)=pizda(2,1)+pizda(1,2)
10899         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10900         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10901           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10902         else
10903           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10904         endif
10905       endif
10906 C Cartesian derivatives.
10907       do iii=1,2
10908         do kkk=1,5
10909           do lll=1,3
10910 #ifdef MOMENT
10911             if (iii.eq.1) then
10912               if (imat.eq.1) then
10913                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10914               else
10915                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10916               endif
10917             else
10918               if (imat.eq.1) then
10919                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10920               else
10921                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10922               endif
10923             endif
10924 #endif
10925             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10926      &        auxvec(1))
10927             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10928             if (j.eq.l+1) then
10929               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10930      &          b1(1,j+1),auxvec(1))
10931               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10932             else
10933               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10934      &          b1(1,l+1),auxvec(1))
10935               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10936             endif
10937             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10938      &        pizda(1,1))
10939             vv(1)=pizda(1,1)-pizda(2,2)
10940             vv(2)=pizda(2,1)+pizda(1,2)
10941             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10942             if (swap) then
10943               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10944 #ifdef MOMENT
10945                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10946      &             -(s1+s2+s4)
10947 #else
10948                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10949      &             -(s2+s4)
10950 #endif
10951                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10952               else
10953 #ifdef MOMENT
10954                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10955 #else
10956                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10957 #endif
10958                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10959               endif
10960             else
10961 #ifdef MOMENT
10962               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10963 #else
10964               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10965 #endif
10966               if (l.eq.j+1) then
10967                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10968               else
10969                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10970               endif
10971             endif
10972           enddo
10973         enddo
10974       enddo
10975       return
10976       end
10977 c----------------------------------------------------------------------------
10978       double precision function eello_turn6(i,jj,kk)
10979       implicit real*8 (a-h,o-z)
10980       include 'DIMENSIONS'
10981       include 'COMMON.IOUNITS'
10982       include 'COMMON.CHAIN'
10983       include 'COMMON.DERIV'
10984       include 'COMMON.INTERACT'
10985       include 'COMMON.CONTACTS'
10986       include 'COMMON.TORSION'
10987       include 'COMMON.VAR'
10988       include 'COMMON.GEO'
10989       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10990      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10991      &  ggg1(3),ggg2(3)
10992       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10993      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10994 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10995 C           the respective energy moment and not to the cluster cumulant.
10996       s1=0.0d0
10997       s8=0.0d0
10998       s13=0.0d0
10999 c
11000       eello_turn6=0.0d0
11001       j=i+4
11002       k=i+1
11003       l=i+3
11004       iti=itype2loc(itype(i))
11005       itk=itype2loc(itype(k))
11006       itk1=itype2loc(itype(k+1))
11007       itl=itype2loc(itype(l))
11008       itj=itype2loc(itype(j))
11009 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11010 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11011 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11012 cd        eello6=0.0d0
11013 cd        return
11014 cd      endif
11015 cd      write (iout,*)
11016 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11017 cd     &   ' and',k,l
11018 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11019       do iii=1,2
11020         do kkk=1,5
11021           do lll=1,3
11022             derx_turn(lll,kkk,iii)=0.0d0
11023           enddo
11024         enddo
11025       enddo
11026 cd      eij=1.0d0
11027 cd      ekl=1.0d0
11028 cd      ekont=1.0d0
11029       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11030 cd      eello6_5=0.0d0
11031 cd      write (2,*) 'eello6_5',eello6_5
11032 #ifdef MOMENT
11033       call transpose2(AEA(1,1,1),auxmat(1,1))
11034       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11035       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11036       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11037 #endif
11038       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11039       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11040       s2 = scalar2(b1(1,k),vtemp1(1))
11041 #ifdef MOMENT
11042       call transpose2(AEA(1,1,2),atemp(1,1))
11043       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11044       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11045       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11046 #endif
11047       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11048       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11049       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11050 #ifdef MOMENT
11051       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11052       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11053       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11054       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11055       ss13 = scalar2(b1(1,k),vtemp4(1))
11056       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11057 #endif
11058 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11059 c      s1=0.0d0
11060 c      s2=0.0d0
11061 c      s8=0.0d0
11062 c      s12=0.0d0
11063 c      s13=0.0d0
11064       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11065 C Derivatives in gamma(i+2)
11066       s1d =0.0d0
11067       s8d =0.0d0
11068 #ifdef MOMENT
11069       call transpose2(AEA(1,1,1),auxmatd(1,1))
11070       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11071       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11072       call transpose2(AEAderg(1,1,2),atempd(1,1))
11073       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11074       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11075 #endif
11076       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11077       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11078       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11079 c      s1d=0.0d0
11080 c      s2d=0.0d0
11081 c      s8d=0.0d0
11082 c      s12d=0.0d0
11083 c      s13d=0.0d0
11084       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11085 C Derivatives in gamma(i+3)
11086 #ifdef MOMENT
11087       call transpose2(AEA(1,1,1),auxmatd(1,1))
11088       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11089       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11090       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11091 #endif
11092       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11093       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11094       s2d = scalar2(b1(1,k),vtemp1d(1))
11095 #ifdef MOMENT
11096       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11097       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11098 #endif
11099       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11100 #ifdef MOMENT
11101       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11102       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11103       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11104 #endif
11105 c      s1d=0.0d0
11106 c      s2d=0.0d0
11107 c      s8d=0.0d0
11108 c      s12d=0.0d0
11109 c      s13d=0.0d0
11110 #ifdef MOMENT
11111       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11112      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11113 #else
11114       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11115      &               -0.5d0*ekont*(s2d+s12d)
11116 #endif
11117 C Derivatives in gamma(i+4)
11118       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11119       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11120       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11121 #ifdef MOMENT
11122       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11123       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11124       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11125 #endif
11126 c      s1d=0.0d0
11127 c      s2d=0.0d0
11128 c      s8d=0.0d0
11129 C      s12d=0.0d0
11130 c      s13d=0.0d0
11131 #ifdef MOMENT
11132       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11133 #else
11134       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11135 #endif
11136 C Derivatives in gamma(i+5)
11137 #ifdef MOMENT
11138       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11139       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11140       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11141 #endif
11142       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11143       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11144       s2d = scalar2(b1(1,k),vtemp1d(1))
11145 #ifdef MOMENT
11146       call transpose2(AEA(1,1,2),atempd(1,1))
11147       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11148       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11149 #endif
11150       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11151       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11152 #ifdef MOMENT
11153       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11154       ss13d = scalar2(b1(1,k),vtemp4d(1))
11155       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11156 #endif
11157 c      s1d=0.0d0
11158 c      s2d=0.0d0
11159 c      s8d=0.0d0
11160 c      s12d=0.0d0
11161 c      s13d=0.0d0
11162 #ifdef MOMENT
11163       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11164      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11165 #else
11166       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11167      &               -0.5d0*ekont*(s2d+s12d)
11168 #endif
11169 C Cartesian derivatives
11170       do iii=1,2
11171         do kkk=1,5
11172           do lll=1,3
11173 #ifdef MOMENT
11174             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11175             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11176             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11177 #endif
11178             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11179             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11180      &          vtemp1d(1))
11181             s2d = scalar2(b1(1,k),vtemp1d(1))
11182 #ifdef MOMENT
11183             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11184             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11185             s8d = -(atempd(1,1)+atempd(2,2))*
11186      &           scalar2(cc(1,1,itl),vtemp2(1))
11187 #endif
11188             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11189      &           auxmatd(1,1))
11190             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11191             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11192 c      s1d=0.0d0
11193 c      s2d=0.0d0
11194 c      s8d=0.0d0
11195 c      s12d=0.0d0
11196 c      s13d=0.0d0
11197 #ifdef MOMENT
11198             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11199      &        - 0.5d0*(s1d+s2d)
11200 #else
11201             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11202      &        - 0.5d0*s2d
11203 #endif
11204 #ifdef MOMENT
11205             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11206      &        - 0.5d0*(s8d+s12d)
11207 #else
11208             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11209      &        - 0.5d0*s12d
11210 #endif
11211           enddo
11212         enddo
11213       enddo
11214 #ifdef MOMENT
11215       do kkk=1,5
11216         do lll=1,3
11217           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11218      &      achuj_tempd(1,1))
11219           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11220           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11221           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11222           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11223           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11224      &      vtemp4d(1))
11225           ss13d = scalar2(b1(1,k),vtemp4d(1))
11226           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11227           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11228         enddo
11229       enddo
11230 #endif
11231 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11232 cd     &  16*eel_turn6_num
11233 cd      goto 1112
11234       if (j.lt.nres-1) then
11235         j1=j+1
11236         j2=j-1
11237       else
11238         j1=j-1
11239         j2=j-2
11240       endif
11241       if (l.lt.nres-1) then
11242         l1=l+1
11243         l2=l-1
11244       else
11245         l1=l-1
11246         l2=l-2
11247       endif
11248       do ll=1,3
11249 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11250 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11251 cgrad        ghalf=0.5d0*ggg1(ll)
11252 cd        ghalf=0.0d0
11253         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11254         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11255         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11256      &    +ekont*derx_turn(ll,2,1)
11257         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11258         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11259      &    +ekont*derx_turn(ll,4,1)
11260         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11261         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11262         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11263 cgrad        ghalf=0.5d0*ggg2(ll)
11264 cd        ghalf=0.0d0
11265         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11266      &    +ekont*derx_turn(ll,2,2)
11267         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11268         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11269      &    +ekont*derx_turn(ll,4,2)
11270         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11271         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11272         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11273       enddo
11274 cd      goto 1112
11275 cgrad      do m=i+1,j-1
11276 cgrad        do ll=1,3
11277 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11278 cgrad        enddo
11279 cgrad      enddo
11280 cgrad      do m=k+1,l-1
11281 cgrad        do ll=1,3
11282 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11283 cgrad        enddo
11284 cgrad      enddo
11285 cgrad1112  continue
11286 cgrad      do m=i+2,j2
11287 cgrad        do ll=1,3
11288 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11289 cgrad        enddo
11290 cgrad      enddo
11291 cgrad      do m=k+2,l2
11292 cgrad        do ll=1,3
11293 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11294 cgrad        enddo
11295 cgrad      enddo
11296 cd      do iii=1,nres-3
11297 cd        write (2,*) iii,g_corr6_loc(iii)
11298 cd      enddo
11299       eello_turn6=ekont*eel_turn6
11300 cd      write (2,*) 'ekont',ekont
11301 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11302       return
11303       end
11304
11305 C-----------------------------------------------------------------------------
11306       double precision function scalar(u,v)
11307 !DIR$ INLINEALWAYS scalar
11308 #ifndef OSF
11309 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11310 #endif
11311       implicit none
11312       double precision u(3),v(3)
11313 cd      double precision sc
11314 cd      integer i
11315 cd      sc=0.0d0
11316 cd      do i=1,3
11317 cd        sc=sc+u(i)*v(i)
11318 cd      enddo
11319 cd      scalar=sc
11320
11321       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11322       return
11323       end
11324 crc-------------------------------------------------
11325       SUBROUTINE MATVEC2(A1,V1,V2)
11326 !DIR$ INLINEALWAYS MATVEC2
11327 #ifndef OSF
11328 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11329 #endif
11330       implicit real*8 (a-h,o-z)
11331       include 'DIMENSIONS'
11332       DIMENSION A1(2,2),V1(2),V2(2)
11333 c      DO 1 I=1,2
11334 c        VI=0.0
11335 c        DO 3 K=1,2
11336 c    3     VI=VI+A1(I,K)*V1(K)
11337 c        Vaux(I)=VI
11338 c    1 CONTINUE
11339
11340       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11341       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11342
11343       v2(1)=vaux1
11344       v2(2)=vaux2
11345       END
11346 C---------------------------------------
11347       SUBROUTINE MATMAT2(A1,A2,A3)
11348 #ifndef OSF
11349 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11350 #endif
11351       implicit real*8 (a-h,o-z)
11352       include 'DIMENSIONS'
11353       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11354 c      DIMENSION AI3(2,2)
11355 c        DO  J=1,2
11356 c          A3IJ=0.0
11357 c          DO K=1,2
11358 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11359 c          enddo
11360 c          A3(I,J)=A3IJ
11361 c       enddo
11362 c      enddo
11363
11364       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11365       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11366       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11367       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11368
11369       A3(1,1)=AI3_11
11370       A3(2,1)=AI3_21
11371       A3(1,2)=AI3_12
11372       A3(2,2)=AI3_22
11373       END
11374
11375 c-------------------------------------------------------------------------
11376       double precision function scalar2(u,v)
11377 !DIR$ INLINEALWAYS scalar2
11378       implicit none
11379       double precision u(2),v(2)
11380       double precision sc
11381       integer i
11382       scalar2=u(1)*v(1)+u(2)*v(2)
11383       return
11384       end
11385
11386 C-----------------------------------------------------------------------------
11387
11388       subroutine transpose2(a,at)
11389 !DIR$ INLINEALWAYS transpose2
11390 #ifndef OSF
11391 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11392 #endif
11393       implicit none
11394       double precision a(2,2),at(2,2)
11395       at(1,1)=a(1,1)
11396       at(1,2)=a(2,1)
11397       at(2,1)=a(1,2)
11398       at(2,2)=a(2,2)
11399       return
11400       end
11401 c--------------------------------------------------------------------------
11402       subroutine transpose(n,a,at)
11403       implicit none
11404       integer n,i,j
11405       double precision a(n,n),at(n,n)
11406       do i=1,n
11407         do j=1,n
11408           at(j,i)=a(i,j)
11409         enddo
11410       enddo
11411       return
11412       end
11413 C---------------------------------------------------------------------------
11414       subroutine prodmat3(a1,a2,kk,transp,prod)
11415 !DIR$ INLINEALWAYS prodmat3
11416 #ifndef OSF
11417 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11418 #endif
11419       implicit none
11420       integer i,j
11421       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11422       logical transp
11423 crc      double precision auxmat(2,2),prod_(2,2)
11424
11425       if (transp) then
11426 crc        call transpose2(kk(1,1),auxmat(1,1))
11427 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11428 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11429
11430            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11431      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11432            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11433      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11434            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11435      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11436            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11437      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11438
11439       else
11440 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11441 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11442
11443            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11444      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11445            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11446      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11447            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11448      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11449            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11450      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11451
11452       endif
11453 c      call transpose2(a2(1,1),a2t(1,1))
11454
11455 crc      print *,transp
11456 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11457 crc      print *,((prod(i,j),i=1,2),j=1,2)
11458
11459       return
11460       end
11461 CCC----------------------------------------------
11462       subroutine Eliptransfer(eliptran)
11463       implicit real*8 (a-h,o-z)
11464       include 'DIMENSIONS'
11465       include 'COMMON.GEO'
11466       include 'COMMON.VAR'
11467       include 'COMMON.LOCAL'
11468       include 'COMMON.CHAIN'
11469       include 'COMMON.DERIV'
11470       include 'COMMON.NAMES'
11471       include 'COMMON.INTERACT'
11472       include 'COMMON.IOUNITS'
11473       include 'COMMON.CALC'
11474       include 'COMMON.CONTROL'
11475       include 'COMMON.SPLITELE'
11476       include 'COMMON.SBRIDGE'
11477 C this is done by Adasko
11478 C      print *,"wchodze"
11479 C structure of box:
11480 C      water
11481 C--bordliptop-- buffore starts
11482 C--bufliptop--- here true lipid starts
11483 C      lipid
11484 C--buflipbot--- lipid ends buffore starts
11485 C--bordlipbot--buffore ends
11486       eliptran=0.0
11487       do i=ilip_start,ilip_end
11488 C       do i=1,1
11489         if (itype(i).eq.ntyp1) cycle
11490
11491         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11492         if (positi.le.0.0) positi=positi+boxzsize
11493 C        print *,i
11494 C first for peptide groups
11495 c for each residue check if it is in lipid or lipid water border area
11496        if ((positi.gt.bordlipbot)
11497      &.and.(positi.lt.bordliptop)) then
11498 C the energy transfer exist
11499         if (positi.lt.buflipbot) then
11500 C what fraction I am in
11501          fracinbuf=1.0d0-
11502      &        ((positi-bordlipbot)/lipbufthick)
11503 C lipbufthick is thickenes of lipid buffore
11504          sslip=sscalelip(fracinbuf)
11505          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11506          eliptran=eliptran+sslip*pepliptran
11507          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11508          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11509 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11510
11511 C        print *,"doing sccale for lower part"
11512 C         print *,i,sslip,fracinbuf,ssgradlip
11513         elseif (positi.gt.bufliptop) then
11514          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11515          sslip=sscalelip(fracinbuf)
11516          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11517          eliptran=eliptran+sslip*pepliptran
11518          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11519          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11520 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11521 C          print *, "doing sscalefor top part"
11522 C         print *,i,sslip,fracinbuf,ssgradlip
11523         else
11524          eliptran=eliptran+pepliptran
11525 C         print *,"I am in true lipid"
11526         endif
11527 C       else
11528 C       eliptran=elpitran+0.0 ! I am in water
11529        endif
11530        enddo
11531 C       print *, "nic nie bylo w lipidzie?"
11532 C now multiply all by the peptide group transfer factor
11533 C       eliptran=eliptran*pepliptran
11534 C now the same for side chains
11535 CV       do i=1,1
11536        do i=ilip_start,ilip_end
11537         if (itype(i).eq.ntyp1) cycle
11538         positi=(mod(c(3,i+nres),boxzsize))
11539         if (positi.le.0) positi=positi+boxzsize
11540 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11541 c for each residue check if it is in lipid or lipid water border area
11542 C       respos=mod(c(3,i+nres),boxzsize)
11543 C       print *,positi,bordlipbot,buflipbot
11544        if ((positi.gt.bordlipbot)
11545      & .and.(positi.lt.bordliptop)) then
11546 C the energy transfer exist
11547         if (positi.lt.buflipbot) then
11548          fracinbuf=1.0d0-
11549      &     ((positi-bordlipbot)/lipbufthick)
11550 C lipbufthick is thickenes of lipid buffore
11551          sslip=sscalelip(fracinbuf)
11552          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11553          eliptran=eliptran+sslip*liptranene(itype(i))
11554          gliptranx(3,i)=gliptranx(3,i)
11555      &+ssgradlip*liptranene(itype(i))
11556          gliptranc(3,i-1)= gliptranc(3,i-1)
11557      &+ssgradlip*liptranene(itype(i))
11558 C         print *,"doing sccale for lower part"
11559         elseif (positi.gt.bufliptop) then
11560          fracinbuf=1.0d0-
11561      &((bordliptop-positi)/lipbufthick)
11562          sslip=sscalelip(fracinbuf)
11563          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11564          eliptran=eliptran+sslip*liptranene(itype(i))
11565          gliptranx(3,i)=gliptranx(3,i)
11566      &+ssgradlip*liptranene(itype(i))
11567          gliptranc(3,i-1)= gliptranc(3,i-1)
11568      &+ssgradlip*liptranene(itype(i))
11569 C          print *, "doing sscalefor top part",sslip,fracinbuf
11570         else
11571          eliptran=eliptran+liptranene(itype(i))
11572 C         print *,"I am in true lipid"
11573         endif
11574         endif ! if in lipid or buffor
11575 C       else
11576 C       eliptran=elpitran+0.0 ! I am in water
11577        enddo
11578        return
11579        end
11580 C---------------------------------------------------------
11581 C AFM soubroutine for constant force
11582        subroutine AFMforce(Eafmforce)
11583        implicit real*8 (a-h,o-z)
11584       include 'DIMENSIONS'
11585       include 'COMMON.GEO'
11586       include 'COMMON.VAR'
11587       include 'COMMON.LOCAL'
11588       include 'COMMON.CHAIN'
11589       include 'COMMON.DERIV'
11590       include 'COMMON.NAMES'
11591       include 'COMMON.INTERACT'
11592       include 'COMMON.IOUNITS'
11593       include 'COMMON.CALC'
11594       include 'COMMON.CONTROL'
11595       include 'COMMON.SPLITELE'
11596       include 'COMMON.SBRIDGE'
11597       real*8 diffafm(3)
11598       dist=0.0d0
11599       Eafmforce=0.0d0
11600       do i=1,3
11601       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11602       dist=dist+diffafm(i)**2
11603       enddo
11604       dist=dsqrt(dist)
11605       Eafmforce=-forceAFMconst*(dist-distafminit)
11606       do i=1,3
11607       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11608       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11609       enddo
11610 C      print *,'AFM',Eafmforce
11611       return
11612       end
11613 C---------------------------------------------------------
11614 C AFM subroutine with pseudoconstant velocity
11615        subroutine AFMvel(Eafmforce)
11616        implicit real*8 (a-h,o-z)
11617       include 'DIMENSIONS'
11618       include 'COMMON.GEO'
11619       include 'COMMON.VAR'
11620       include 'COMMON.LOCAL'
11621       include 'COMMON.CHAIN'
11622       include 'COMMON.DERIV'
11623       include 'COMMON.NAMES'
11624       include 'COMMON.INTERACT'
11625       include 'COMMON.IOUNITS'
11626       include 'COMMON.CALC'
11627       include 'COMMON.CONTROL'
11628       include 'COMMON.SPLITELE'
11629       include 'COMMON.SBRIDGE'
11630       real*8 diffafm(3)
11631 C Only for check grad COMMENT if not used for checkgrad
11632 C      totT=3.0d0
11633 C--------------------------------------------------------
11634 C      print *,"wchodze"
11635       dist=0.0d0
11636       Eafmforce=0.0d0
11637       do i=1,3
11638       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11639       dist=dist+diffafm(i)**2
11640       enddo
11641       dist=dsqrt(dist)
11642       Eafmforce=0.5d0*forceAFMconst
11643      & *(distafminit+totTafm*velAFMconst-dist)**2
11644 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11645       do i=1,3
11646       gradafm(i,afmend-1)=-forceAFMconst*
11647      &(distafminit+totTafm*velAFMconst-dist)
11648      &*diffafm(i)/dist
11649       gradafm(i,afmbeg-1)=forceAFMconst*
11650      &(distafminit+totTafm*velAFMconst-dist)
11651      &*diffafm(i)/dist
11652       enddo
11653 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11654       return
11655       end
11656 C-----------------------------------------------------------
11657 C first for shielding is setting of function of side-chains
11658        subroutine set_shield_fac
11659       implicit real*8 (a-h,o-z)
11660       include 'DIMENSIONS'
11661       include 'COMMON.CHAIN'
11662       include 'COMMON.DERIV'
11663       include 'COMMON.IOUNITS'
11664       include 'COMMON.SHIELD'
11665       include 'COMMON.INTERACT'
11666 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11667       double precision div77_81/0.974996043d0/,
11668      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11669
11670 C the vector between center of side_chain and peptide group
11671        double precision pep_side(3),long,side_calf(3),
11672      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11673      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11674 C the line belowe needs to be changed for FGPROC>1
11675       do i=1,nres-1
11676       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11677       ishield_list(i)=0
11678 Cif there two consequtive dummy atoms there is no peptide group between them
11679 C the line below has to be changed for FGPROC>1
11680       VolumeTotal=0.0
11681       do k=1,nres
11682        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11683        dist_pep_side=0.0
11684        dist_side_calf=0.0
11685        do j=1,3
11686 C first lets set vector conecting the ithe side-chain with kth side-chain
11687       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11688 C      pep_side(j)=2.0d0
11689 C and vector conecting the side-chain with its proper calfa
11690       side_calf(j)=c(j,k+nres)-c(j,k)
11691 C      side_calf(j)=2.0d0
11692       pept_group(j)=c(j,i)-c(j,i+1)
11693 C lets have their lenght
11694       dist_pep_side=pep_side(j)**2+dist_pep_side
11695       dist_side_calf=dist_side_calf+side_calf(j)**2
11696       dist_pept_group=dist_pept_group+pept_group(j)**2
11697       enddo
11698        dist_pep_side=dsqrt(dist_pep_side)
11699        dist_pept_group=dsqrt(dist_pept_group)
11700        dist_side_calf=dsqrt(dist_side_calf)
11701       do j=1,3
11702         pep_side_norm(j)=pep_side(j)/dist_pep_side
11703         side_calf_norm(j)=dist_side_calf
11704       enddo
11705 C now sscale fraction
11706        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11707 C       print *,buff_shield,"buff"
11708 C now sscale
11709         if (sh_frac_dist.le.0.0) cycle
11710 C If we reach here it means that this side chain reaches the shielding sphere
11711 C Lets add him to the list for gradient
11712         ishield_list(i)=ishield_list(i)+1
11713 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11714 C this list is essential otherwise problem would be O3
11715         shield_list(ishield_list(i),i)=k
11716 C Lets have the sscale value
11717         if (sh_frac_dist.gt.1.0) then
11718          scale_fac_dist=1.0d0
11719          do j=1,3
11720          sh_frac_dist_grad(j)=0.0d0
11721          enddo
11722         else
11723          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11724      &                   *(2.0*sh_frac_dist-3.0d0)
11725          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11726      &                  /dist_pep_side/buff_shield*0.5
11727 C remember for the final gradient multiply sh_frac_dist_grad(j)
11728 C for side_chain by factor -2 !
11729          do j=1,3
11730          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11731 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11732 C     &                    sh_frac_dist_grad(j)
11733          enddo
11734         endif
11735 C        if ((i.eq.3).and.(k.eq.2)) then
11736 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11737 C     & ,"TU"
11738 C        endif
11739
11740 C this is what is now we have the distance scaling now volume...
11741       short=short_r_sidechain(itype(k))
11742       long=long_r_sidechain(itype(k))
11743       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11744 C now costhet_grad
11745 C       costhet=0.0d0
11746        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11747 C       costhet_fac=0.0d0
11748        do j=1,3
11749          costhet_grad(j)=costhet_fac*pep_side(j)
11750        enddo
11751 C remember for the final gradient multiply costhet_grad(j)
11752 C for side_chain by factor -2 !
11753 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11754 C pep_side0pept_group is vector multiplication
11755       pep_side0pept_group=0.0
11756       do j=1,3
11757       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11758       enddo
11759       cosalfa=(pep_side0pept_group/
11760      & (dist_pep_side*dist_side_calf))
11761       fac_alfa_sin=1.0-cosalfa**2
11762       fac_alfa_sin=dsqrt(fac_alfa_sin)
11763       rkprim=fac_alfa_sin*(long-short)+short
11764 C now costhet_grad
11765        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11766        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11767
11768        do j=1,3
11769          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11770      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11771      &*(long-short)/fac_alfa_sin*cosalfa/
11772      &((dist_pep_side*dist_side_calf))*
11773      &((side_calf(j))-cosalfa*
11774      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11775
11776         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11777      &*(long-short)/fac_alfa_sin*cosalfa
11778      &/((dist_pep_side*dist_side_calf))*
11779      &(pep_side(j)-
11780      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11781        enddo
11782
11783       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11784      &                    /VSolvSphere_div
11785      &                    *wshield
11786 C now the gradient...
11787 C grad_shield is gradient of Calfa for peptide groups
11788 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11789 C     &               costhet,cosphi
11790 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11791 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11792       do j=1,3
11793       grad_shield(j,i)=grad_shield(j,i)
11794 C gradient po skalowaniu
11795      &                +(sh_frac_dist_grad(j)
11796 C  gradient po costhet
11797      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11798      &-scale_fac_dist*(cosphi_grad_long(j))
11799      &/(1.0-cosphi) )*div77_81
11800      &*VofOverlap
11801 C grad_shield_side is Cbeta sidechain gradient
11802       grad_shield_side(j,ishield_list(i),i)=
11803      &        (sh_frac_dist_grad(j)*-2.0d0
11804      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11805      &       +scale_fac_dist*(cosphi_grad_long(j))
11806      &        *2.0d0/(1.0-cosphi))
11807      &        *div77_81*VofOverlap
11808
11809        grad_shield_loc(j,ishield_list(i),i)=
11810      &   scale_fac_dist*cosphi_grad_loc(j)
11811      &        *2.0d0/(1.0-cosphi)
11812      &        *div77_81*VofOverlap
11813       enddo
11814       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11815       enddo
11816       fac_shield(i)=VolumeTotal*div77_81+div4_81
11817 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11818       enddo
11819       return
11820       end
11821 C--------------------------------------------------------------------------
11822       double precision function tschebyshev(m,n,x,y)
11823       implicit none
11824       include "DIMENSIONS"
11825       integer i,m,n
11826       double precision x(n),y,yy(0:maxvar),aux
11827 c Tschebyshev polynomial. Note that the first term is omitted
11828 c m=0: the constant term is included
11829 c m=1: the constant term is not included
11830       yy(0)=1.0d0
11831       yy(1)=y
11832       do i=2,n
11833         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11834       enddo
11835       aux=0.0d0
11836       do i=m,n
11837         aux=aux+x(i)*yy(i)
11838       enddo
11839       tschebyshev=aux
11840       return
11841       end
11842 C--------------------------------------------------------------------------
11843       double precision function gradtschebyshev(m,n,x,y)
11844       implicit none
11845       include "DIMENSIONS"
11846       integer i,m,n
11847       double precision x(n+1),y,yy(0:maxvar),aux
11848 c Tschebyshev polynomial. Note that the first term is omitted
11849 c m=0: the constant term is included
11850 c m=1: the constant term is not included
11851       yy(0)=1.0d0
11852       yy(1)=2.0d0*y
11853       do i=2,n
11854         yy(i)=2*y*yy(i-1)-yy(i-2)
11855       enddo
11856       aux=0.0d0
11857       do i=m,n
11858         aux=aux+x(i+1)*yy(i)*(i+1)
11859 C        print *, x(i+1),yy(i),i
11860       enddo
11861       gradtschebyshev=aux
11862       return
11863       end
11864 C------------------------------------------------------------------------
11865 C first for shielding is setting of function of side-chains
11866        subroutine set_shield_fac2
11867       implicit real*8 (a-h,o-z)
11868       include 'DIMENSIONS'
11869       include 'COMMON.CHAIN'
11870       include 'COMMON.DERIV'
11871       include 'COMMON.IOUNITS'
11872       include 'COMMON.SHIELD'
11873       include 'COMMON.INTERACT'
11874       include 'COMMON.LOCAL'
11875
11876 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11877       double precision div77_81/0.974996043d0/,
11878      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11879
11880 C the vector between center of side_chain and peptide group
11881        double precision pep_side(3),long,side_calf(3),
11882      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11883      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11884 C      write(2,*) "ivec",ivec_start,ivec_end
11885       do i=1,nres
11886         fac_shield(i)=0.0d0
11887         do j=1,3
11888         grad_shield(j,i)=0.0d0
11889         enddo
11890       enddo
11891 C the line belowe needs to be changed for FGPROC>1
11892       do i=ivec_start,ivec_end
11893 C      do i=1,nres-1
11894 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11895       ishield_list(i)=0
11896       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11897 Cif there two consequtive dummy atoms there is no peptide group between them
11898 C the line below has to be changed for FGPROC>1
11899       VolumeTotal=0.0
11900       do k=1,nres
11901        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11902        dist_pep_side=0.0
11903        dist_side_calf=0.0
11904        do j=1,3
11905 C first lets set vector conecting the ithe side-chain with kth side-chain
11906       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11907 C      pep_side(j)=2.0d0
11908 C and vector conecting the side-chain with its proper calfa
11909       side_calf(j)=c(j,k+nres)-c(j,k)
11910 C      side_calf(j)=2.0d0
11911       pept_group(j)=c(j,i)-c(j,i+1)
11912 C lets have their lenght
11913       dist_pep_side=pep_side(j)**2+dist_pep_side
11914       dist_side_calf=dist_side_calf+side_calf(j)**2
11915       dist_pept_group=dist_pept_group+pept_group(j)**2
11916       enddo
11917        dist_pep_side=dsqrt(dist_pep_side)
11918        dist_pept_group=dsqrt(dist_pept_group)
11919        dist_side_calf=dsqrt(dist_side_calf)
11920       do j=1,3
11921         pep_side_norm(j)=pep_side(j)/dist_pep_side
11922         side_calf_norm(j)=dist_side_calf
11923       enddo
11924 C now sscale fraction
11925        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11926 C       print *,buff_shield,"buff"
11927 C now sscale
11928         if (sh_frac_dist.le.0.0) cycle
11929 C        print *,ishield_list(i),i
11930 C If we reach here it means that this side chain reaches the shielding sphere
11931 C Lets add him to the list for gradient
11932         ishield_list(i)=ishield_list(i)+1
11933 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11934 C this list is essential otherwise problem would be O3
11935         shield_list(ishield_list(i),i)=k
11936 C Lets have the sscale value
11937         if (sh_frac_dist.gt.1.0) then
11938          scale_fac_dist=1.0d0
11939          do j=1,3
11940          sh_frac_dist_grad(j)=0.0d0
11941          enddo
11942         else
11943          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11944      &                   *(2.0d0*sh_frac_dist-3.0d0)
11945          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11946      &                  /dist_pep_side/buff_shield*0.5d0
11947 C remember for the final gradient multiply sh_frac_dist_grad(j)
11948 C for side_chain by factor -2 !
11949          do j=1,3
11950          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11951 C         sh_frac_dist_grad(j)=0.0d0
11952 C         scale_fac_dist=1.0d0
11953 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11954 C     &                    sh_frac_dist_grad(j)
11955          enddo
11956         endif
11957 C this is what is now we have the distance scaling now volume...
11958       short=short_r_sidechain(itype(k))
11959       long=long_r_sidechain(itype(k))
11960       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11961       sinthet=short/dist_pep_side*costhet
11962 C now costhet_grad
11963 C       costhet=0.6d0
11964 C       sinthet=0.8
11965        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11966 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11967 C     &             -short/dist_pep_side**2/costhet)
11968 C       costhet_fac=0.0d0
11969        do j=1,3
11970          costhet_grad(j)=costhet_fac*pep_side(j)
11971        enddo
11972 C remember for the final gradient multiply costhet_grad(j)
11973 C for side_chain by factor -2 !
11974 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11975 C pep_side0pept_group is vector multiplication
11976       pep_side0pept_group=0.0d0
11977       do j=1,3
11978       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11979       enddo
11980       cosalfa=(pep_side0pept_group/
11981      & (dist_pep_side*dist_side_calf))
11982       fac_alfa_sin=1.0d0-cosalfa**2
11983       fac_alfa_sin=dsqrt(fac_alfa_sin)
11984       rkprim=fac_alfa_sin*(long-short)+short
11985 C      rkprim=short
11986
11987 C now costhet_grad
11988        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11989 C       cosphi=0.6
11990        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11991        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11992      &      dist_pep_side**2)
11993 C       sinphi=0.8
11994        do j=1,3
11995          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11996      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11997      &*(long-short)/fac_alfa_sin*cosalfa/
11998      &((dist_pep_side*dist_side_calf))*
11999      &((side_calf(j))-cosalfa*
12000      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12001 C       cosphi_grad_long(j)=0.0d0
12002         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12003      &*(long-short)/fac_alfa_sin*cosalfa
12004      &/((dist_pep_side*dist_side_calf))*
12005      &(pep_side(j)-
12006      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12007 C       cosphi_grad_loc(j)=0.0d0
12008        enddo
12009 C      print *,sinphi,sinthet
12010       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12011      &                    /VSolvSphere_div
12012 C     &                    *wshield
12013 C now the gradient...
12014       do j=1,3
12015       grad_shield(j,i)=grad_shield(j,i)
12016 C gradient po skalowaniu
12017      &                +(sh_frac_dist_grad(j)*VofOverlap
12018 C  gradient po costhet
12019      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12020      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12021      &       sinphi/sinthet*costhet*costhet_grad(j)
12022      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12023      & )*wshield
12024 C grad_shield_side is Cbeta sidechain gradient
12025       grad_shield_side(j,ishield_list(i),i)=
12026      &        (sh_frac_dist_grad(j)*-2.0d0
12027      &        *VofOverlap
12028      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12029      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12030      &       sinphi/sinthet*costhet*costhet_grad(j)
12031      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12032      &       )*wshield
12033
12034        grad_shield_loc(j,ishield_list(i),i)=
12035      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12036      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12037      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12038      &        ))
12039      &        *wshield
12040       enddo
12041       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12042       enddo
12043       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12044 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12045       enddo
12046       return
12047       end
12048 C-----------------------------------------------------------------------
12049 C-----------------------------------------------------------
12050 C This subroutine is to mimic the histone like structure but as well can be
12051 C utilizet to nanostructures (infinit) small modification has to be used to
12052 C make it finite (z gradient at the ends has to be changes as well as the x,y
12053 C gradient has to be modified at the ends
12054 C The energy function is Kihara potential
12055 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12056 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12057 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12058 C simple Kihara potential
12059       subroutine calctube(Etube)
12060        implicit real*8 (a-h,o-z)
12061       include 'DIMENSIONS'
12062       include 'COMMON.GEO'
12063       include 'COMMON.VAR'
12064       include 'COMMON.LOCAL'
12065       include 'COMMON.CHAIN'
12066       include 'COMMON.DERIV'
12067       include 'COMMON.NAMES'
12068       include 'COMMON.INTERACT'
12069       include 'COMMON.IOUNITS'
12070       include 'COMMON.CALC'
12071       include 'COMMON.CONTROL'
12072       include 'COMMON.SPLITELE'
12073       include 'COMMON.SBRIDGE'
12074       double precision tub_r,vectube(3),enetube(maxres*2)
12075       Etube=0.0d0
12076       do i=1,2*nres
12077         enetube(i)=0.0d0
12078       enddo
12079 C first we calculate the distance from tube center
12080 C first sugare-phosphate group for NARES this would be peptide group
12081 C for UNRES
12082       do i=1,nres
12083 C lets ommit dummy atoms for now
12084        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12085 C now calculate distance from center of tube and direction vectors
12086       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12087           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12088       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12089           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12090       vectube(1)=vectube(1)-tubecenter(1)
12091       vectube(2)=vectube(2)-tubecenter(2)
12092
12093 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12094 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12095
12096 C as the tube is infinity we do not calculate the Z-vector use of Z
12097 C as chosen axis
12098       vectube(3)=0.0d0
12099 C now calculte the distance
12100        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12101 C now normalize vector
12102       vectube(1)=vectube(1)/tub_r
12103       vectube(2)=vectube(2)/tub_r
12104 C calculte rdiffrence between r and r0
12105       rdiff=tub_r-tubeR0
12106 C and its 6 power
12107       rdiff6=rdiff**6.0d0
12108 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12109        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12110 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12111 C       print *,rdiff,rdiff6,pep_aa_tube
12112 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12113 C now we calculate gradient
12114        fac=(-12.0d0*pep_aa_tube/rdiff6+
12115      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12116 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12117 C     &rdiff,fac
12118
12119 C now direction of gg_tube vector
12120         do j=1,3
12121         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12122         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12123         enddo
12124         enddo
12125 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12126         do i=1,nres
12127 C Lets not jump over memory as we use many times iti
12128          iti=itype(i)
12129 C lets ommit dummy atoms for now
12130          if ((iti.eq.ntyp1)
12131 C in UNRES uncomment the line below as GLY has no side-chain...
12132 C      .or.(iti.eq.10)
12133      &   ) cycle
12134           vectube(1)=c(1,i+nres)
12135           vectube(1)=mod(vectube(1),boxxsize)
12136           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12137           vectube(2)=c(2,i+nres)
12138           vectube(2)=mod(vectube(2),boxysize)
12139           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12140
12141       vectube(1)=vectube(1)-tubecenter(1)
12142       vectube(2)=vectube(2)-tubecenter(2)
12143
12144 C as the tube is infinity we do not calculate the Z-vector use of Z
12145 C as chosen axis
12146       vectube(3)=0.0d0
12147 C now calculte the distance
12148        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12149 C now normalize vector
12150       vectube(1)=vectube(1)/tub_r
12151       vectube(2)=vectube(2)/tub_r
12152 C calculte rdiffrence between r and r0
12153       rdiff=tub_r-tubeR0
12154 C and its 6 power
12155       rdiff6=rdiff**6.0d0
12156 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12157        sc_aa_tube=sc_aa_tube_par(iti)
12158        sc_bb_tube=sc_bb_tube_par(iti)
12159        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12160 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12161 C now we calculate gradient
12162        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12163      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12164 C now direction of gg_tube vector
12165          do j=1,3
12166           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12167           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12168          enddo
12169         enddo
12170         do i=1,2*nres
12171           Etube=Etube+enetube(i)
12172         enddo
12173 C        print *,"ETUBE", etube
12174         return
12175         end
12176 C TO DO 1) add to total energy
12177 C       2) add to gradient summation
12178 C       3) add reading parameters (AND of course oppening of PARAM file)
12179 C       4) add reading the center of tube
12180 C       5) add COMMONs
12181 C       6) add to zerograd
12182
12183 C-----------------------------------------------------------------------
12184 C-----------------------------------------------------------
12185 C This subroutine is to mimic the histone like structure but as well can be
12186 C utilizet to nanostructures (infinit) small modification has to be used to
12187 C make it finite (z gradient at the ends has to be changes as well as the x,y
12188 C gradient has to be modified at the ends
12189 C The energy function is Kihara potential
12190 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12191 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12192 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12193 C simple Kihara potential
12194       subroutine calctube2(Etube)
12195        implicit real*8 (a-h,o-z)
12196       include 'DIMENSIONS'
12197       include 'COMMON.GEO'
12198       include 'COMMON.VAR'
12199       include 'COMMON.LOCAL'
12200       include 'COMMON.CHAIN'
12201       include 'COMMON.DERIV'
12202       include 'COMMON.NAMES'
12203       include 'COMMON.INTERACT'
12204       include 'COMMON.IOUNITS'
12205       include 'COMMON.CALC'
12206       include 'COMMON.CONTROL'
12207       include 'COMMON.SPLITELE'
12208       include 'COMMON.SBRIDGE'
12209       double precision tub_r,vectube(3),enetube(maxres*2)
12210       Etube=0.0d0
12211       do i=1,2*nres
12212         enetube(i)=0.0d0
12213       enddo
12214 C first we calculate the distance from tube center
12215 C first sugare-phosphate group for NARES this would be peptide group
12216 C for UNRES
12217       do i=1,nres
12218 C lets ommit dummy atoms for now
12219
12220        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12221 C now calculate distance from center of tube and direction vectors
12222       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12223           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12224       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12225           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12226       vectube(1)=vectube(1)-tubecenter(1)
12227       vectube(2)=vectube(2)-tubecenter(2)
12228
12229 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12230 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12231
12232 C as the tube is infinity we do not calculate the Z-vector use of Z
12233 C as chosen axis
12234       vectube(3)=0.0d0
12235 C now calculte the distance
12236        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12237 C now normalize vector
12238       vectube(1)=vectube(1)/tub_r
12239       vectube(2)=vectube(2)/tub_r
12240 C calculte rdiffrence between r and r0
12241       rdiff=tub_r-tubeR0
12242 C and its 6 power
12243       rdiff6=rdiff**6.0d0
12244 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12245        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12246 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12247 C       print *,rdiff,rdiff6,pep_aa_tube
12248 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12249 C now we calculate gradient
12250        fac=(-12.0d0*pep_aa_tube/rdiff6+
12251      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12252 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12253 C     &rdiff,fac
12254
12255 C now direction of gg_tube vector
12256         do j=1,3
12257         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12258         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12259         enddo
12260         enddo
12261 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12262         do i=1,nres
12263 C Lets not jump over memory as we use many times iti
12264          iti=itype(i)
12265 C lets ommit dummy atoms for now
12266          if ((iti.eq.ntyp1)
12267 C in UNRES uncomment the line below as GLY has no side-chain...
12268      &      .or.(iti.eq.10)
12269      &   ) cycle
12270           vectube(1)=c(1,i+nres)
12271           vectube(1)=mod(vectube(1),boxxsize)
12272           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12273           vectube(2)=c(2,i+nres)
12274           vectube(2)=mod(vectube(2),boxysize)
12275           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12276
12277       vectube(1)=vectube(1)-tubecenter(1)
12278       vectube(2)=vectube(2)-tubecenter(2)
12279 C THIS FRAGMENT MAKES TUBE FINITE
12280         positi=(mod(c(3,i+nres),boxzsize))
12281         if (positi.le.0) positi=positi+boxzsize
12282 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12283 c for each residue check if it is in lipid or lipid water border area
12284 C       respos=mod(c(3,i+nres),boxzsize)
12285        print *,positi,bordtubebot,buftubebot,bordtubetop
12286        if ((positi.gt.bordtubebot)
12287      & .and.(positi.lt.bordtubetop)) then
12288 C the energy transfer exist
12289         if (positi.lt.buftubebot) then
12290          fracinbuf=1.0d0-
12291      &     ((positi-bordtubebot)/tubebufthick)
12292 C lipbufthick is thickenes of lipid buffore
12293          sstube=sscalelip(fracinbuf)
12294          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12295          print *,ssgradtube, sstube,tubetranene(itype(i))
12296          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12297 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12298 C     &+ssgradtube*tubetranene(itype(i))
12299 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12300 C     &+ssgradtube*tubetranene(itype(i))
12301 C         print *,"doing sccale for lower part"
12302         elseif (positi.gt.buftubetop) then
12303          fracinbuf=1.0d0-
12304      &((bordtubetop-positi)/tubebufthick)
12305          sstube=sscalelip(fracinbuf)
12306          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12307          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12308 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12309 C     &+ssgradtube*tubetranene(itype(i))
12310 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12311 C     &+ssgradtube*tubetranene(itype(i))
12312 C          print *, "doing sscalefor top part",sslip,fracinbuf
12313         else
12314          sstube=1.0d0
12315          ssgradtube=0.0d0
12316          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12317 C         print *,"I am in true lipid"
12318         endif
12319         else
12320 C          sstube=0.0d0
12321 C          ssgradtube=0.0d0
12322         cycle
12323         endif ! if in lipid or buffor
12324 CEND OF FINITE FRAGMENT
12325 C as the tube is infinity we do not calculate the Z-vector use of Z
12326 C as chosen axis
12327       vectube(3)=0.0d0
12328 C now calculte the distance
12329        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12330 C now normalize vector
12331       vectube(1)=vectube(1)/tub_r
12332       vectube(2)=vectube(2)/tub_r
12333 C calculte rdiffrence between r and r0
12334       rdiff=tub_r-tubeR0
12335 C and its 6 power
12336       rdiff6=rdiff**6.0d0
12337 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12338        sc_aa_tube=sc_aa_tube_par(iti)
12339        sc_bb_tube=sc_bb_tube_par(iti)
12340        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12341      &                 *sstube+enetube(i+nres)
12342 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12343 C now we calculate gradient
12344        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12345      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12346 C now direction of gg_tube vector
12347          do j=1,3
12348           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12349           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12350          enddo
12351          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12352      &+ssgradtube*enetube(i+nres)/sstube
12353          gg_tube(3,i-1)= gg_tube(3,i-1)
12354      &+ssgradtube*enetube(i+nres)/sstube
12355
12356         enddo
12357         do i=1,2*nres
12358           Etube=Etube+enetube(i)
12359         enddo
12360 C        print *,"ETUBE", etube
12361         return
12362         end
12363 C TO DO 1) add to total energy
12364 C       2) add to gradient summation
12365 C       3) add reading parameters (AND of course oppening of PARAM file)
12366 C       4) add reading the center of tube
12367 C       5) add COMMONs
12368 C       6) add to zerograd
12369