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       double precision fac_shieldbuf(maxres),
  32      & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
  33      & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
  34      & grad_shieldbuf(3,-1:maxres)
  35        integer ishield_listbuf(maxres),
  36      &shield_listbuf(maxcontsshi,maxres)
  37 #ifdef MPI
  38 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  39 c     & " nfgtasks",nfgtasks
  40       if (nfgtasks.gt.1) then
  41         time00=MPI_Wtime()
  42 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  43         if (fg_rank.eq.0) then
  44           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  45 c          print *,"Processor",myrank," BROADCAST iorder"
  46 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  47 C FG slaves as WEIGHTS array.
  48           weights_(1)=wsc
  49           weights_(2)=wscp
  50           weights_(3)=welec
  51           weights_(4)=wcorr
  52           weights_(5)=wcorr5
  53           weights_(6)=wcorr6
  54           weights_(7)=wel_loc
  55           weights_(8)=wturn3
  56           weights_(9)=wturn4
  57           weights_(10)=wturn6
  58           weights_(11)=wang
  59           weights_(12)=wscloc
  60           weights_(13)=wtor
  61           weights_(14)=wtor_d
  62           weights_(15)=wstrain
  63           weights_(16)=wvdwpp
  64           weights_(17)=wbond
  65           weights_(18)=scal14
  66           weights_(21)=wsccor
  67           weights_(22)=wtube
  68
  69 C FG Master broadcasts the WEIGHTS_ array
  70           call MPI_Bcast(weights_(1),n_ene,
  71      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  72         else
  73 C FG slaves receive the WEIGHTS array
  74           call MPI_Bcast(weights(1),n_ene,
  75      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  76           wsc=weights(1)
  77           wscp=weights(2)
  78           welec=weights(3)
  79           wcorr=weights(4)
  80           wcorr5=weights(5)
  81           wcorr6=weights(6)
  82           wel_loc=weights(7)
  83           wturn3=weights(8)
  84           wturn4=weights(9)
  85           wturn6=weights(10)
  86           wang=weights(11)
  87           wscloc=weights(12)
  88           wtor=weights(13)
  89           wtor_d=weights(14)
  90           wstrain=weights(15)
  91           wvdwpp=weights(16)
  92           wbond=weights(17)
  93           scal14=weights(18)
  94           wsccor=weights(21)
  95           wtube=weights(22)
  96         endif
  97         time_Bcast=time_Bcast+MPI_Wtime()-time00
  98         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  99 c        call chainbuild_cart
 100       endif
 101 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 102 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 103 #else
 104 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 105 c        call int_from_cart1(.false.)
 106 c      endif
 107 #endif
 108 #ifdef TIMING
 109       time00=MPI_Wtime()
 110 #endif
 111 C
 112 C Compute the side-chain and electrostatic interaction energy
 113 C
 114 C      print *,ipot
 115       goto (101,102,103,104,105,106) ipot
 116 C Lennard-Jones potential.
 117   101 call elj(evdw)
 118 cd    print '(a)','Exit ELJ'
 119       goto 107
 120 C Lennard-Jones-Kihara potential (shifted).
 121   102 call eljk(evdw)
 122       goto 107
 123 C Berne-Pechukas potential (dilated LJ, angular dependence).
 124   103 call ebp(evdw)
 125       goto 107
 126 C Gay-Berne potential (shifted LJ, angular dependence).
 127   104 call egb(evdw)
 128 C      print *,"bylem w egb"
 129       goto 107
 130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 131   105 call egbv(evdw)
 132       goto 107
 133 C Soft-sphere potential
 134   106 call e_softsphere(evdw)
 135 C
 136 C Calculate electrostatic (H-bonding) energy of the main chain.
 137 C
 138   107 continue
 139 cmc
 140 cmc Sep-06: egb takes care of dynamic ss bonds too
 141 cmc
 142 c      if (dyn_ss) call dyn_set_nss
 143
 144 c      print *,"Processor",myrank," computed USCSC"
 145 #ifdef TIMING
 146       time01=MPI_Wtime()
 147 #endif
 148       call vec_and_deriv
 149 #ifdef TIMING
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #endif
 152 C Introduction of shielding effect first for each peptide group
 153 C the shielding factor is set this factor is describing how each
 154 C peptide group is shielded by side-chains
 155 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 156 C      write (iout,*) "shield_mode",shield_mode
 157       if (shield_mode.eq.1) then
 158        call set_shield_fac
 159       else if  (shield_mode.eq.2) then
 160        call set_shield_fac2
 161       if (nfgtasks.gt.1) then
 162 C#define DEBUG
 163 #ifdef DEBUG
 164        write(iout,*) "befor reduce fac_shield reduce"
 165        do i=1,nres
 166         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 167         write(2,*) "list", shield_list(1,i),ishield_list(i),
 168      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 169        enddo
 170 #endif
 171        call MPI_Allgatherv(fac_shield(ivec_start),
 172      &  ivec_count(fg_rank1),
 173      &  MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0),
 174      &  ivec_displ(0),
 175      &  MPI_DOUBLE_PRECISION,FG_COMM,IERR)
 176        call MPI_Allgatherv(shield_list(1,ivec_start),
 177      &  ivec_count(fg_rank1),
 178      &  MPI_I50,shield_listbuf(1,1),ivec_count(0),
 179      &  ivec_displ(0),
 180      &  MPI_I50,FG_COMM,IERR)
 181        call MPI_Allgatherv(ishield_list(ivec_start),
 182      &  ivec_count(fg_rank1),
 183      &  MPI_INTEGER,ishield_listbuf(1),ivec_count(0),
 184      &  ivec_displ(0),
 185      &  MPI_INTEGER,FG_COMM,IERR)
 186        call MPI_Allgatherv(grad_shield(1,ivec_start),
 187      &  ivec_count(fg_rank1),
 188      &  MPI_UYZ,grad_shieldbuf(1,1),ivec_count(0),
 189      &  ivec_displ(0),
 190      &  MPI_UYZ,FG_COMM,IERR)
 191        call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
 192      &  ivec_count(fg_rank1),
 193      &  MPI_SHI,grad_shield_sidebuf(1,1,1),ivec_count(0),
 194      &  ivec_displ(0),
 195      &  MPI_SHI,FG_COMM,IERR)
 196        call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
 197      &  ivec_count(fg_rank1),
 198      &  MPI_SHI,grad_shield_locbuf(1,1,1),ivec_count(0),
 199      &  ivec_displ(0),
 200      &  MPI_SHI,FG_COMM,IERR)
 201        do i=1,nres
 202         fac_shield(i)=fac_shieldbuf(i)
 203         ishield_list(i)=ishield_listbuf(i)
 204         do j=1,3
 205         grad_shield(j,i)=grad_shieldbuf(j,i)
 206         enddo !j
 207         do j=1,ishield_list(i)
 208           shield_list(j,i)=shield_listbuf(j,i)
 209          do k=1,3
 210          grad_shield_loc(k,j,i)=grad_shield_locbuf(k,j,i)
 211          grad_shield_side(k,j,i)=grad_shield_sidebuf(k,j,i)
 212          enddo !k
 213        enddo !j
 214       enddo !i
 215 #ifdef DEBUG
 216        write(iout,*) "after reduce fac_shield reduce"
 217        do i=1,nres
 218         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 219         write(2,*) "list", shield_list(1,i),ishield_list(i),
 220      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 221        enddo
 222 #endif
 223 C#undef DEBUG
 224       endif
 225 #ifdef DEBUG
 226       do i=1,nres
 227       write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
 228         do j=1,ishield_list(i)
 229          write(iout,*) "grad", grad_shield_side(1,j,i),
 230      &   grad_shield_loc(1,j,i)
 231         enddo
 232       enddo
 233 #endif
 234       endif
 235 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 236       if (ipot.lt.6) then
 237 #ifdef SPLITELE
 238          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 239      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 240      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 241      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 242 #else
 243          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 244      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 245      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 246      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 247 #endif
 248             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 249          else
 250             ees=0.0d0
 251             evdw1=0.0d0
 252             eel_loc=0.0d0
 253             eello_turn3=0.0d0
 254             eello_turn4=0.0d0
 255          endif
 256       else
 257         write (iout,*) "Soft-spheer ELEC potential"
 258 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 259 c     &   eello_turn4)
 260       endif
 261 c      print *,"Processor",myrank," computed UELEC"
 262 C
 263 C Calculate excluded-volume interaction energy between peptide groups
 264 C and side chains.
 265 C
 266       if (ipot.lt.6) then
 267        if(wscp.gt.0d0) then
 268         call escp(evdw2,evdw2_14)
 269        else
 270         evdw2=0
 271         evdw2_14=0
 272        endif
 273       else
 274 c        write (iout,*) "Soft-sphere SCP potential"
 275         call escp_soft_sphere(evdw2,evdw2_14)
 276       endif
 277 c
 278 c Calculate the bond-stretching energy
 279 c
 280       call ebond(estr)
 281 C
 282 C Calculate the disulfide-bridge and other energy and the contributions
 283 C from other distance constraints.
 284 cd    print *,'Calling EHPB'
 285       call edis(ehpb)
 286 cd    print *,'EHPB exitted succesfully.'
 287 C
 288 C Calculate the virtual-bond-angle energy.
 289 C
 290       if (wang.gt.0d0) then
 291        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 292         call ebend(ebe,ethetacnstr)
 293         endif
 294 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 295 C energy function
 296        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 297          call ebend_kcc(ebe,ethetacnstr)
 298         endif
 299       else
 300         ebe=0
 301         ethetacnstr=0
 302       endif
 303 c      print *,"Processor",myrank," computed UB"
 304 C
 305 C Calculate the SC local energy.
 306 C
 307 C      print *,"TU DOCHODZE?"
 308       call esc(escloc)
 309 c      print *,"Processor",myrank," computed USC"
 310 C
 311 C Calculate the virtual-bond torsional energy.
 312 C
 313 cd    print *,'nterm=',nterm
 314 C      print *,"tor",tor_mode
 315       if (wtor.gt.0) then
 316        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 317        call etor(etors,edihcnstr)
 318        endif
 319 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 320 C energy function
 321        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 322        call etor_kcc(etors,edihcnstr)
 323        endif
 324       else
 325        etors=0
 326        edihcnstr=0
 327       endif
 328 c      print *,"Processor",myrank," computed Utor"
 329 C
 330 C 6/23/01 Calculate double-torsional energy
 331 C
 332       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 333        call etor_d(etors_d)
 334       else
 335        etors_d=0
 336       endif
 337 c      print *,"Processor",myrank," computed Utord"
 338 C
 339 C 21/5/07 Calculate local sicdechain correlation energy
 340 C
 341       if (wsccor.gt.0.0d0) then
 342         call eback_sc_corr(esccor)
 343       else
 344         esccor=0.0d0
 345       endif
 346 C      print *,"PRZED MULIt"
 347 c      print *,"Processor",myrank," computed Usccorr"
 348 C
 349 C 12/1/95 Multi-body terms
 350 C
 351       n_corr=0
 352       n_corr1=0
 353       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 354      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 355          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 356 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 357 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 358       else
 359          ecorr=0.0d0
 360          ecorr5=0.0d0
 361          ecorr6=0.0d0
 362          eturn6=0.0d0
 363       endif
 364       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 365          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 366 cd         write (iout,*) "multibody_hb ecorr",ecorr
 367       endif
 368 c      print *,"Processor",myrank," computed Ucorr"
 369 C
 370 C If performing constraint dynamics, call the constraint energy
 371 C  after the equilibration time
 372       if(usampl.and.totT.gt.eq_time) then
 373          call EconstrQ
 374          call Econstr_back
 375       else
 376          Uconst=0.0d0
 377          Uconst_back=0.0d0
 378       endif
 379 C 01/27/2015 added by adasko
 380 C the energy component below is energy transfer into lipid environment
 381 C based on partition function
 382 C      print *,"przed lipidami"
 383       if (wliptran.gt.0) then
 384         call Eliptransfer(eliptran)
 385       else
 386        eliptran=0.0d0
 387       endif
 388 C      print *,"za lipidami"
 389       if (AFMlog.gt.0) then
 390         call AFMforce(Eafmforce)
 391       else if (selfguide.gt.0) then
 392         call AFMvel(Eafmforce)
 393       endif
 394       if (TUBElog.eq.1) then
 395 C      print *,"just before call"
 396         call calctube(Etube)
 397        elseif (TUBElog.eq.2) then
 398         call calctube2(Etube)
 399        elseif (TUBElog.eq.3) then
 400         call calcnano(Etube)
 401        else
 402        Etube=0.0d0
 403        endif
 404
 405 #ifdef TIMING
 406       time_enecalc=time_enecalc+MPI_Wtime()-time00
 407 #endif
 408 c      print *,"Processor",myrank," computed Uconstr"
 409 #ifdef TIMING
 410       time00=MPI_Wtime()
 411 #endif
 412 c
 413 C Sum the energies
 414 C
 415       energia(1)=evdw
 416 #ifdef SCP14
 417       energia(2)=evdw2-evdw2_14
 418       energia(18)=evdw2_14
 419 #else
 420       energia(2)=evdw2
 421       energia(18)=0.0d0
 422 #endif
 423 #ifdef SPLITELE
 424       energia(3)=ees
 425       energia(16)=evdw1
 426 #else
 427       energia(3)=ees+evdw1
 428       energia(16)=0.0d0
 429 #endif
 430       energia(4)=ecorr
 431       energia(5)=ecorr5
 432       energia(6)=ecorr6
 433       energia(7)=eel_loc
 434       energia(8)=eello_turn3
 435       energia(9)=eello_turn4
 436       energia(10)=eturn6
 437       energia(11)=ebe
 438       energia(12)=escloc
 439       energia(13)=etors
 440       energia(14)=etors_d
 441       energia(15)=ehpb
 442       energia(19)=edihcnstr
 443       energia(17)=estr
 444       energia(20)=Uconst+Uconst_back
 445       energia(21)=esccor
 446       energia(22)=eliptran
 447       energia(23)=Eafmforce
 448       energia(24)=ethetacnstr
 449       energia(25)=Etube
 450 c    Here are the energies showed per procesor if the are more processors
 451 c    per molecule then we sum it up in sum_energy subroutine
 452 c      print *," Processor",myrank," calls SUM_ENERGY"
 453       call sum_energy(energia,.true.)
 454       if (dyn_ss) call dyn_set_nss
 455 c      print *," Processor",myrank," left SUM_ENERGY"
 456 #ifdef TIMING
 457       time_sumene=time_sumene+MPI_Wtime()-time00
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_energy(energia,reduce)
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include "mpif.h"
 473 #endif
 474       include 'COMMON.SETUP'
 475       include 'COMMON.IOUNITS'
 476       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       logical reduce
 486 #ifdef MPI
 487       if (nfgtasks.gt.1 .and. reduce) then
 488 #ifdef DEBUG
 489         write (iout,*) "energies before REDUCE"
 490         call enerprint(energia)
 491         call flush(iout)
 492 #endif
 493         do i=0,n_ene
 494           enebuff(i)=energia(i)
 495         enddo
 496         time00=MPI_Wtime()
 497         call MPI_Barrier(FG_COMM,IERR)
 498         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 499         time00=MPI_Wtime()
 500         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 501      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 502 #ifdef DEBUG
 503         write (iout,*) "energies after REDUCE"
 504         call enerprint(energia)
 505         call flush(iout)
 506 #endif
 507         time_Reduce=time_Reduce+MPI_Wtime()-time00
 508       endif
 509       if (fg_rank.eq.0) then
 510 #endif
 511       evdw=energia(1)
 512 #ifdef SCP14
 513       evdw2=energia(2)+energia(18)
 514       evdw2_14=energia(18)
 515 #else
 516       evdw2=energia(2)
 517 #endif
 518 #ifdef SPLITELE
 519       ees=energia(3)
 520       evdw1=energia(16)
 521 #else
 522       ees=energia(3)
 523       evdw1=0.0d0
 524 #endif
 525       ecorr=energia(4)
 526       ecorr5=energia(5)
 527       ecorr6=energia(6)
 528       eel_loc=energia(7)
 529       eello_turn3=energia(8)
 530       eello_turn4=energia(9)
 531       eturn6=energia(10)
 532       ebe=energia(11)
 533       escloc=energia(12)
 534       etors=energia(13)
 535       etors_d=energia(14)
 536       ehpb=energia(15)
 537       edihcnstr=energia(19)
 538       estr=energia(17)
 539       Uconst=energia(20)
 540       esccor=energia(21)
 541       eliptran=energia(22)
 542       Eafmforce=energia(23)
 543       ethetacnstr=energia(24)
 544       Etube=energia(25)
 545 #ifdef SPLITELE
 546       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 547      & +wang*ebe+wtor*etors+wscloc*escloc
 548      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 549      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 550      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 551      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 552      & +ethetacnstr+wtube*Etube
 553 #else
 554       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 555      & +wang*ebe+wtor*etors+wscloc*escloc
 556      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 557      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 558      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 559      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 560      & +Eafmforce
 561      & +ethetacnstr+wtube*Etube
 562 #endif
 563       energia(0)=etot
 564 c detecting NaNQ
 565 #ifdef ISNAN
 566 #ifdef AIX
 567       if (isnan(etot).ne.0) energia(0)=1.0d+99
 568 #else
 569       if (isnan(etot)) energia(0)=1.0d+99
 570 #endif
 571 #else
 572       i=0
 573 #ifdef WINPGI
 574       idumm=proc_proc(etot,i)
 575 #else
 576       call proc_proc(etot,i)
 577 #endif
 578       if(i.eq.1)energia(0)=1.0d+99
 579 #endif
 580 #ifdef MPI
 581       endif
 582 #endif
 583       return
 584       end
 585 c-------------------------------------------------------------------------------
 586       subroutine sum_gradient
 587       implicit real*8 (a-h,o-z)
 588       include 'DIMENSIONS'
 589 #ifndef ISNAN
 590       external proc_proc
 591 #ifdef WINPGI
 592 cMS$ATTRIBUTES C ::  proc_proc
 593 #endif
 594 #endif
 595 #ifdef MPI
 596       include 'mpif.h'
 597 #endif
 598       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 599      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 600      & ,gloc_scbuf(3,-1:maxres)
 601       include 'COMMON.SETUP'
 602       include 'COMMON.IOUNITS'
 603       include 'COMMON.FFIELD'
 604       include 'COMMON.DERIV'
 605       include 'COMMON.INTERACT'
 606       include 'COMMON.SBRIDGE'
 607       include 'COMMON.CHAIN'
 608       include 'COMMON.VAR'
 609       include 'COMMON.CONTROL'
 610       include 'COMMON.TIME1'
 611       include 'COMMON.MAXGRAD'
 612       include 'COMMON.SCCOR'
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616 #ifdef DEBUG
 617       write (iout,*) "sum_gradient gvdwc, gvdwx"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 620      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef MPI
 625 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 626         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 627      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 628 #endif
 629 C
 630 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 631 C            in virtual-bond-vector coordinates
 632 C
 633 #ifdef DEBUG
 634 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 635 c      do i=1,nres-1
 636 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 637 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 638 c      enddo
 639 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 640 c      do i=1,nres-1
 641 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 642 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 643 c      enddo
 644       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 645       do i=1,nres
 646         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 647      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 648      &   g_corr5_loc(i)
 649       enddo
 650       call flush(iout)
 651 #endif
 652 #ifdef SPLITELE
 653       do i=0,nct
 654         do j=1,3
 655           gradbufc(j,i)=wsc*gvdwc(j,i)+
 656      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 657      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 658      &                wel_loc*gel_loc_long(j,i)+
 659      &                wcorr*gradcorr_long(j,i)+
 660      &                wcorr5*gradcorr5_long(j,i)+
 661      &                wcorr6*gradcorr6_long(j,i)+
 662      &                wturn6*gcorr6_turn_long(j,i)+
 663      &                wstrain*ghpbc(j,i)
 664      &                +wliptran*gliptranc(j,i)
 665      &                +gradafm(j,i)
 666      &                 +welec*gshieldc(j,i)
 667      &                 +wcorr*gshieldc_ec(j,i)
 668      &                 +wturn3*gshieldc_t3(j,i)
 669      &                 +wturn4*gshieldc_t4(j,i)
 670      &                 +wel_loc*gshieldc_ll(j,i)
 671      &                +wtube*gg_tube(j,i)
 672
 673
 674
 675         enddo
 676       enddo
 677 C      j=1
 678 C      i=0
 679 C      print *,"KUPA2",gradbufc(j,i),wsc*gvdwc(j,i),
 680 C     &                wscp*gvdwc_scp(j,i),gvdwc_scpp(j,i),
 681 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 682 C     &                wel_loc*gel_loc_long(j,i),
 683 C     &                wcorr*gradcorr_long(j,i),
 684 C     &                wcorr5*gradcorr5_long(j,i),
 685 C     &                wcorr6*gradcorr6_long(j,i),
 686 C     &                wturn6*gcorr6_turn_long(j,i),
 687 C     &                wstrain*ghpbc(j,i)
 688 C     &                ,wliptran*gliptranc(j,i)
 689 C     &                ,gradafm(j,i)
 690 C     &                 ,welec*gshieldc(j,i)
 691 C     &                 ,wcorr*gshieldc_ec(j,i)
 692 C     &                 ,wturn3*gshieldc_t3(j,i)
 693 C     &                 ,wturn4*gshieldc_t4(j,i)
 694 C     &                 ,wel_loc*gshieldc_ll(j,i)
 695 C     &                ,wtube*gg_tube(j,i)
 696 #else
 697       do i=0,nct
 698         do j=1,3
 699           gradbufc(j,i)=wsc*gvdwc(j,i)+
 700      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 701      &                welec*gelc_long(j,i)+
 702      &                wbond*gradb(j,i)+
 703      &                wel_loc*gel_loc_long(j,i)+
 704      &                wcorr*gradcorr_long(j,i)+
 705      &                wcorr5*gradcorr5_long(j,i)+
 706      &                wcorr6*gradcorr6_long(j,i)+
 707      &                wturn6*gcorr6_turn_long(j,i)+
 708      &                wstrain*ghpbc(j,i)
 709      &                +wliptran*gliptranc(j,i)
 710      &                +gradafm(j,i)
 711      &                 +welec*gshieldc(j,i)
 712      &                 +wcorr*gshieldc_ec(j,i)
 713      &                 +wturn4*gshieldc_t4(j,i)
 714      &                 +wel_loc*gshieldc_ll(j,i)
 715      &                +wtube*gg_tube(j,i)
 716
 717
 718
 719         enddo
 720       enddo
 721 #endif
 722 #ifdef MPI
 723       if (nfgtasks.gt.1) then
 724       time00=MPI_Wtime()
 725 #ifdef DEBUG
 726       write (iout,*) "gradbufc before allreduce"
 727       do i=1,nres
 728         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 729       enddo
 730       call flush(iout)
 731 #endif
 732       do i=0,nres
 733         do j=1,3
 734           gradbufc_sum(j,i)=gradbufc(j,i)
 735         enddo
 736       enddo
 737 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 738 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 739 c      time_reduce=time_reduce+MPI_Wtime()-time00
 740 #ifdef DEBUG
 741 c      write (iout,*) "gradbufc_sum after allreduce"
 742 c      do i=1,nres
 743 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 744 c      enddo
 745 c      call flush(iout)
 746 #endif
 747 #ifdef TIMING
 748 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 749 #endif
 750       do i=0,nres
 751         do k=1,3
 752           gradbufc(k,i)=0.0d0
 753         enddo
 754       enddo
 755 #ifdef DEBUG
 756       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 757       write (iout,*) (i," jgrad_start",jgrad_start(i),
 758      &                  " jgrad_end  ",jgrad_end(i),
 759      &                  i=igrad_start,igrad_end)
 760 #endif
 761 c
 762 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 763 c do not parallelize this part.
 764 c
 765 c      do i=igrad_start,igrad_end
 766 c        do j=jgrad_start(i),jgrad_end(i)
 767 c          do k=1,3
 768 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 769 c          enddo
 770 c        enddo
 771 c      enddo
 772       do j=1,3
 773         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 774       enddo
 775       do i=nres-2,-1,-1
 776         do j=1,3
 777           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 778         enddo
 779       enddo
 780 #ifdef DEBUG
 781       write (iout,*) "gradbufc after summing"
 782       do i=1,nres
 783         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 784       enddo
 785       call flush(iout)
 786 #endif
 787       else
 788 #endif
 789 #ifdef DEBUG
 790       write (iout,*) "gradbufc"
 791       do i=1,nres
 792         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 793       enddo
 794       call flush(iout)
 795 #endif
 796       do i=-1,nres
 797         do j=1,3
 798           gradbufc_sum(j,i)=gradbufc(j,i)
 799           gradbufc(j,i)=0.0d0
 800         enddo
 801       enddo
 802       do j=1,3
 803         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 804       enddo
 805       do i=nres-2,-1,-1
 806         do j=1,3
 807           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 808         enddo
 809       enddo
 810 c      do i=nnt,nres-1
 811 c        do k=1,3
 812 c          gradbufc(k,i)=0.0d0
 813 c        enddo
 814 c        do j=i+1,nres
 815 c          do k=1,3
 816 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 817 c          enddo
 818 c        enddo
 819 c      enddo
 820 #ifdef DEBUG
 821       write (iout,*) "gradbufc after summing"
 822       do i=1,nres
 823         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 824       enddo
 825       call flush(iout)
 826 #endif
 827 #ifdef MPI
 828       endif
 829 #endif
 830       do k=1,3
 831         gradbufc(k,nres)=0.0d0
 832       enddo
 833       do i=-1,nct
 834         do j=1,3
 835 #ifdef SPLITELE
 836 C          print *,gradbufc(1,13)
 837 C          print *,welec*gelc(1,13)
 838 C          print *,wel_loc*gel_loc(1,13)
 839 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 840 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 841 C          print *,wel_loc*gel_loc_long(1,13)
 842 C          print *,gradafm(1,13),"AFM"
 843           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 844      &                wel_loc*gel_loc(j,i)+
 845      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 846      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 847      &                wel_loc*gel_loc_long(j,i)+
 848      &                wcorr*gradcorr_long(j,i)+
 849      &                wcorr5*gradcorr5_long(j,i)+
 850      &                wcorr6*gradcorr6_long(j,i)+
 851      &                wturn6*gcorr6_turn_long(j,i))+
 852      &                wbond*gradb(j,i)+
 853      &                wcorr*gradcorr(j,i)+
 854      &                wturn3*gcorr3_turn(j,i)+
 855      &                wturn4*gcorr4_turn(j,i)+
 856      &                wcorr5*gradcorr5(j,i)+
 857      &                wcorr6*gradcorr6(j,i)+
 858      &                wturn6*gcorr6_turn(j,i)+
 859      &                wsccor*gsccorc(j,i)
 860      &               +wscloc*gscloc(j,i)
 861      &               +wliptran*gliptranc(j,i)
 862      &                +gradafm(j,i)
 863      &                 +welec*gshieldc(j,i)
 864      &                 +welec*gshieldc_loc(j,i)
 865      &                 +wcorr*gshieldc_ec(j,i)
 866      &                 +wcorr*gshieldc_loc_ec(j,i)
 867      &                 +wturn3*gshieldc_t3(j,i)
 868      &                 +wturn3*gshieldc_loc_t3(j,i)
 869      &                 +wturn4*gshieldc_t4(j,i)
 870      &                 +wturn4*gshieldc_loc_t4(j,i)
 871      &                 +wel_loc*gshieldc_ll(j,i)
 872      &                 +wel_loc*gshieldc_loc_ll(j,i)
 873      &                +wtube*gg_tube(j,i)
 874
 875 #else
 876           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 877      &                wel_loc*gel_loc(j,i)+
 878      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 879      &                welec*gelc_long(j,i)+
 880      &                wel_loc*gel_loc_long(j,i)+
 881      &                wcorr*gcorr_long(j,i)+
 882      &                wcorr5*gradcorr5_long(j,i)+
 883      &                wcorr6*gradcorr6_long(j,i)+
 884      &                wturn6*gcorr6_turn_long(j,i))+
 885      &                wbond*gradb(j,i)+
 886      &                wcorr*gradcorr(j,i)+
 887      &                wturn3*gcorr3_turn(j,i)+
 888      &                wturn4*gcorr4_turn(j,i)+
 889      &                wcorr5*gradcorr5(j,i)+
 890      &                wcorr6*gradcorr6(j,i)+
 891      &                wturn6*gcorr6_turn(j,i)+
 892      &                wsccor*gsccorc(j,i)
 893      &               +wscloc*gscloc(j,i)
 894      &               +wliptran*gliptranc(j,i)
 895      &                +gradafm(j,i)
 896      &                 +welec*gshieldc(j,i)
 897      &                 +welec*gshieldc_loc(j,i)
 898      &                 +wcorr*gshieldc_ec(j,i)
 899      &                 +wcorr*gshieldc_loc_ec(j,i)
 900      &                 +wturn3*gshieldc_t3(j,i)
 901      &                 +wturn3*gshieldc_loc_t3(j,i)
 902      &                 +wturn4*gshieldc_t4(j,i)
 903      &                 +wturn4*gshieldc_loc_t4(j,i)
 904      &                 +wel_loc*gshieldc_ll(j,i)
 905      &                 +wel_loc*gshieldc_loc_ll(j,i)
 906      &                +wtube*gg_tube(j,i)
 907
 908
 909 #endif
 910           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 911      &                  wbond*gradbx(j,i)+
 912      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 913      &                  wsccor*gsccorx(j,i)
 914      &                 +wscloc*gsclocx(j,i)
 915      &                 +wliptran*gliptranx(j,i)
 916      &                 +welec*gshieldx(j,i)
 917      &                 +wcorr*gshieldx_ec(j,i)
 918      &                 +wturn3*gshieldx_t3(j,i)
 919      &                 +wturn4*gshieldx_t4(j,i)
 920      &                 +wel_loc*gshieldx_ll(j,i)
 921      &                 +wtube*gg_tube_sc(j,i)
 922
 923
 924
 925         enddo
 926       enddo
 927 C       i=0
 928 C       j=1
 929 C       print *,"KUPA",    gradbufc(j,i),welec*gelc(j,i),
 930 C     &                wel_loc*gel_loc(j,i),
 931 C     &                0.5d0*wscp*gvdwc_scpp(j,i),
 932 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 933 C     &                wel_loc*gel_loc_long(j,i),
 934 C     &                wcorr*gradcorr_long(j,i),
 935 C     &                wcorr5*gradcorr5_long(j,i),
 936 C     &                wcorr6*gradcorr6_long(j,i),
 937 C     &                wturn6*gcorr6_turn_long(j,i),
 938 C     &                wbond*gradb(j,i),
 939 C     &                wcorr*gradcorr(j,i),
 940 C     &                wturn3*gcorr3_turn(j,i),
 941 C     &                wturn4*gcorr4_turn(j,i),
 942 C     &                wcorr5*gradcorr5(j,i),
 943 C     &                wcorr6*gradcorr6(j,i),
 944 C     &                wturn6*gcorr6_turn(j,i),
 945 C     &                wsccor*gsccorc(j,i)
 946 C     &               ,wscloc*gscloc(j,i)
 947 C     &               ,wliptran*gliptranc(j,i)
 948 C     &                ,gradafm(j,i)
 949 C     &                 +welec*gshieldc(j,i)
 950 C     &                 +welec*gshieldc_loc(j,i)
 951 C     &                 +wcorr*gshieldc_ec(j,i)
 952 C     &                 +wcorr*gshieldc_loc_ec(j,i)
 953 C     &                 +wturn3*gshieldc_t3(j,i)
 954 C     &                 +wturn3*gshieldc_loc_t3(j,i)
 955 C     &                 +wturn4*gshieldc_t4(j,i)
 956 C     &                 ,wturn4*gshieldc_loc_t4(j,i)
 957 C     &                 ,wel_loc*gshieldc_ll(j,i)
 958 C     &                 ,wel_loc*gshieldc_loc_ll(j,i)
 959 C     &                ,wtube*gg_tube(j,i)
 960
 961 C      print *,gg_tube(1,0),"TU3"
 962 #ifdef DEBUG
 963       write (iout,*) "gloc before adding corr"
 964       do i=1,4*nres
 965         write (iout,*) i,gloc(i,icg)
 966       enddo
 967 #endif
 968       do i=1,nres-3
 969         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 970      &   +wcorr5*g_corr5_loc(i)
 971      &   +wcorr6*g_corr6_loc(i)
 972      &   +wturn4*gel_loc_turn4(i)
 973      &   +wturn3*gel_loc_turn3(i)
 974      &   +wturn6*gel_loc_turn6(i)
 975      &   +wel_loc*gel_loc_loc(i)
 976       enddo
 977 #ifdef DEBUG
 978       write (iout,*) "gloc after adding corr"
 979       do i=1,4*nres
 980         write (iout,*) i,gloc(i,icg)
 981       enddo
 982 #endif
 983 #ifdef MPI
 984       if (nfgtasks.gt.1) then
 985         do j=1,3
 986           do i=1,nres
 987             gradbufc(j,i)=gradc(j,i,icg)
 988             gradbufx(j,i)=gradx(j,i,icg)
 989           enddo
 990         enddo
 991         do i=1,4*nres
 992           glocbuf(i)=gloc(i,icg)
 993         enddo
 994 c#define DEBUG
 995 #ifdef DEBUG
 996       write (iout,*) "gloc_sc before reduce"
 997       do i=1,nres
 998        do j=1,1
 999         write (iout,*) i,j,gloc_sc(j,i,icg)
1000        enddo
1001       enddo
1002 #endif
1003 c#undef DEBUG
1004         do i=1,nres
1005          do j=1,3
1006           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1007          enddo
1008         enddo
1009         time00=MPI_Wtime()
1010         call MPI_Barrier(FG_COMM,IERR)
1011         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1012         time00=MPI_Wtime()
1013         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,
1014      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1015         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1016      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1017         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1018      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019         time_reduce=time_reduce+MPI_Wtime()-time00
1020         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1021      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1022         time_reduce=time_reduce+MPI_Wtime()-time00
1023 c#define DEBUG
1024 #ifdef DEBUG
1025       write (iout,*) "gloc_sc after reduce"
1026       do i=1,nres
1027        do j=1,1
1028         write (iout,*) i,j,gloc_sc(j,i,icg)
1029        enddo
1030       enddo
1031 #endif
1032 c#undef DEBUG
1033 #ifdef DEBUG
1034       write (iout,*) "gloc after reduce"
1035       do i=1,4*nres
1036         write (iout,*) i,gloc(i,icg)
1037       enddo
1038 #endif
1039       endif
1040 #endif
1041       if (gnorm_check) then
1042 c
1043 c Compute the maximum elements of the gradient
1044 c
1045       gvdwc_max=0.0d0
1046       gvdwc_scp_max=0.0d0
1047       gelc_max=0.0d0
1048       gvdwpp_max=0.0d0
1049       gradb_max=0.0d0
1050       ghpbc_max=0.0d0
1051       gradcorr_max=0.0d0
1052       gel_loc_max=0.0d0
1053       gcorr3_turn_max=0.0d0
1054       gcorr4_turn_max=0.0d0
1055       gradcorr5_max=0.0d0
1056       gradcorr6_max=0.0d0
1057       gcorr6_turn_max=0.0d0
1058       gsccorc_max=0.0d0
1059       gscloc_max=0.0d0
1060       gvdwx_max=0.0d0
1061       gradx_scp_max=0.0d0
1062       ghpbx_max=0.0d0
1063       gradxorr_max=0.0d0
1064       gsccorx_max=0.0d0
1065       gsclocx_max=0.0d0
1066       do i=1,nct
1067         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1068         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1069         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1070         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1071      &   gvdwc_scp_max=gvdwc_scp_norm
1072         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1073         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1074         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1075         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1076         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1077         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1078         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1079         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1080         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1081         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1082         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1083         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1084         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1085      &    gcorr3_turn(1,i)))
1086         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1087      &    gcorr3_turn_max=gcorr3_turn_norm
1088         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1089      &    gcorr4_turn(1,i)))
1090         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1091      &    gcorr4_turn_max=gcorr4_turn_norm
1092         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1093         if (gradcorr5_norm.gt.gradcorr5_max)
1094      &    gradcorr5_max=gradcorr5_norm
1095         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1096         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1097         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1098      &    gcorr6_turn(1,i)))
1099         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1100      &    gcorr6_turn_max=gcorr6_turn_norm
1101         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1102         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1103         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1104         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1105         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1106         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1107         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1108         if (gradx_scp_norm.gt.gradx_scp_max)
1109      &    gradx_scp_max=gradx_scp_norm
1110         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1111         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1112         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1113         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1114         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1115         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1116         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1117         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1118       enddo
1119       if (gradout) then
1120 #ifdef AIX
1121         open(istat,file=statname,position="append")
1122 #else
1123         open(istat,file=statname,access="append")
1124 #endif
1125         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1126      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1127      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1128      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1129      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1130      &     gsccorx_max,gsclocx_max
1131         close(istat)
1132         if (gvdwc_max.gt.1.0d4) then
1133           write (iout,*) "gvdwc gvdwx gradb gradbx"
1134           do i=nnt,nct
1135             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1136      &        gradb(j,i),gradbx(j,i),j=1,3)
1137           enddo
1138           call pdbout(0.0d0,'cipiszcze',iout)
1139           call flush(iout)
1140         endif
1141       endif
1142       endif
1143 #ifdef DEBUG
1144       write (iout,*) "gradc gradx gloc"
1145       do i=1,nres
1146         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1147      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1148       enddo
1149 #endif
1150 #ifdef TIMING
1151       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1152 #endif
1153       return
1154       end
1155 c-------------------------------------------------------------------------------
1156       subroutine rescale_weights(t_bath)
1157       implicit real*8 (a-h,o-z)
1158       include 'DIMENSIONS'
1159       include 'COMMON.IOUNITS'
1160       include 'COMMON.FFIELD'
1161       include 'COMMON.SBRIDGE'
1162       include 'COMMON.CONTROL'
1163       double precision kfac /2.4d0/
1164       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1165 c      facT=temp0/t_bath
1166 c      facT=2*temp0/(t_bath+temp0)
1167       if (rescale_mode.eq.0) then
1168         facT=1.0d0
1169         facT2=1.0d0
1170         facT3=1.0d0
1171         facT4=1.0d0
1172         facT5=1.0d0
1173       else if (rescale_mode.eq.1) then
1174         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1175         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1176         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1177         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1178         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1179       else if (rescale_mode.eq.2) then
1180         x=t_bath/temp0
1181         x2=x*x
1182         x3=x2*x
1183         x4=x3*x
1184         x5=x4*x
1185         facT=licznik/dlog(dexp(x)+dexp(-x))
1186         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1187         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1188         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1189         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1190       else
1191         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1192         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1193 #ifdef MPI
1194        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1195 #endif
1196        stop 555
1197       endif
1198       if (shield_mode.gt.0) then
1199        wscp=weights(2)*fact
1200        wsc=weights(1)*fact
1201        wvdwpp=weights(16)*fact
1202       endif
1203       welec=weights(3)*fact
1204       wcorr=weights(4)*fact3
1205       wcorr5=weights(5)*fact4
1206       wcorr6=weights(6)*fact5
1207       wel_loc=weights(7)*fact2
1208       wturn3=weights(8)*fact2
1209       wturn4=weights(9)*fact3
1210       wturn6=weights(10)*fact5
1211       wtor=weights(13)*fact
1212       wtor_d=weights(14)*fact2
1213       wsccor=weights(21)*fact
1214
1215       return
1216       end
1217 C------------------------------------------------------------------------
1218       subroutine enerprint(energia)
1219       implicit real*8 (a-h,o-z)
1220       include 'DIMENSIONS'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.FFIELD'
1223       include 'COMMON.SBRIDGE'
1224       include 'COMMON.MD'
1225       double precision energia(0:n_ene)
1226       etot=energia(0)
1227       evdw=energia(1)
1228       evdw2=energia(2)
1229 #ifdef SCP14
1230       evdw2=energia(2)+energia(18)
1231 #else
1232       evdw2=energia(2)
1233 #endif
1234       ees=energia(3)
1235 #ifdef SPLITELE
1236       evdw1=energia(16)
1237 #endif
1238       ecorr=energia(4)
1239       ecorr5=energia(5)
1240       ecorr6=energia(6)
1241       eel_loc=energia(7)
1242       eello_turn3=energia(8)
1243       eello_turn4=energia(9)
1244       eello_turn6=energia(10)
1245       ebe=energia(11)
1246       escloc=energia(12)
1247       etors=energia(13)
1248       etors_d=energia(14)
1249       ehpb=energia(15)
1250       edihcnstr=energia(19)
1251       estr=energia(17)
1252       Uconst=energia(20)
1253       esccor=energia(21)
1254       eliptran=energia(22)
1255       Eafmforce=energia(23)
1256       ethetacnstr=energia(24)
1257       etube=energia(25)
1258 #ifdef SPLITELE
1259       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1260      &  estr,wbond,ebe,wang,
1261      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1262      &  ecorr,wcorr,
1263      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1264      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1265      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1266      &  etube,wtube,
1267      &  etot
1268    10 format (/'Virtual-chain energies:'//
1269      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1270      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1271      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1272      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1273      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1274      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1275      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1276      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1277      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1278      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1279      & ' (SS bridges & dist. cnstr.)'/
1280      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1281      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1282      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1283      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1284      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1285      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1286      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1287      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1288      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1289      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1290      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1291      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1292      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1293      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1294      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1295      & 'ETOT=  ',1pE16.6,' (total)')
1296
1297 #else
1298       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1299      &  estr,wbond,ebe,wang,
1300      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1301      &  ecorr,wcorr,
1302      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1303      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1304      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1305      &  etube,wtube,
1306      &  etot
1307    10 format (/'Virtual-chain energies:'//
1308      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1309      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1310      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1311      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1312      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1313      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1314      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1315      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1316      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1317      & ' (SS bridges & dist. cnstr.)'/
1318      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1319      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1320      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1321      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1322      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1323      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1324      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1325      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1326      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1327      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1328      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1329      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1330      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1331      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1332      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1333      & 'ETOT=  ',1pE16.6,' (total)')
1334 #endif
1335       return
1336       end
1337 C-----------------------------------------------------------------------
1338       subroutine elj(evdw)
1339 C
1340 C This subroutine calculates the interaction energy of nonbonded side chains
1341 C assuming the LJ potential of interaction.
1342 C
1343       implicit real*8 (a-h,o-z)
1344       include 'DIMENSIONS'
1345       parameter (accur=1.0d-10)
1346       include 'COMMON.GEO'
1347       include 'COMMON.VAR'
1348       include 'COMMON.LOCAL'
1349       include 'COMMON.CHAIN'
1350       include 'COMMON.DERIV'
1351       include 'COMMON.INTERACT'
1352       include 'COMMON.TORSION'
1353       include 'COMMON.SBRIDGE'
1354       include 'COMMON.NAMES'
1355       include 'COMMON.IOUNITS'
1356       include 'COMMON.CONTACTS'
1357       dimension gg(3)
1358 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1359       evdw=0.0D0
1360       do i=iatsc_s,iatsc_e
1361         itypi=iabs(itype(i))
1362         if (itypi.eq.ntyp1) cycle
1363         itypi1=iabs(itype(i+1))
1364         xi=c(1,nres+i)
1365         yi=c(2,nres+i)
1366         zi=c(3,nres+i)
1367 C Change 12/1/95
1368         num_conti=0
1369 C
1370 C Calculate SC interaction energy.
1371 C
1372         do iint=1,nint_gr(i)
1373 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1374 cd   &                  'iend=',iend(i,iint)
1375           do j=istart(i,iint),iend(i,iint)
1376             itypj=iabs(itype(j))
1377             if (itypj.eq.ntyp1) cycle
1378             xj=c(1,nres+j)-xi
1379             yj=c(2,nres+j)-yi
1380             zj=c(3,nres+j)-zi
1381 C Change 12/1/95 to calculate four-body interactions
1382             rij=xj*xj+yj*yj+zj*zj
1383             rrij=1.0D0/rij
1384 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1385             eps0ij=eps(itypi,itypj)
1386             fac=rrij**expon2
1387 C have you changed here?
1388             e1=fac*fac*aa
1389             e2=fac*bb
1390             evdwij=e1+e2
1391 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1392 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1393 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1394 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1395 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1396 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1397             evdw=evdw+evdwij
1398 C
1399 C Calculate the components of the gradient in DC and X
1400 C
1401             fac=-rrij*(e1+evdwij)
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405             do k=1,3
1406               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1410             enddo
1411 cgrad            do k=i,j-1
1412 cgrad              do l=1,3
1413 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1414 cgrad              enddo
1415 cgrad            enddo
1416 C
1417 C 12/1/95, revised on 5/20/97
1418 C
1419 C Calculate the contact function. The ith column of the array JCONT will
1420 C contain the numbers of atoms that make contacts with the atom I (of numbers
1421 C greater than I). The arrays FACONT and GACONT will contain the values of
1422 C the contact function and its derivative.
1423 C
1424 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1425 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1426 C Uncomment next line, if the correlation interactions are contact function only
1427             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1428               rij=dsqrt(rij)
1429               sigij=sigma(itypi,itypj)
1430               r0ij=rs0(itypi,itypj)
1431 C
1432 C Check whether the SC's are not too far to make a contact.
1433 C
1434               rcut=1.5d0*r0ij
1435               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1436 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1437 C
1438               if (fcont.gt.0.0D0) then
1439 C If the SC-SC distance if close to sigma, apply spline.
1440 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1441 cAdam &             fcont1,fprimcont1)
1442 cAdam           fcont1=1.0d0-fcont1
1443 cAdam           if (fcont1.gt.0.0d0) then
1444 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1445 cAdam             fcont=fcont*fcont1
1446 cAdam           endif
1447 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1448 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1449 cga             do k=1,3
1450 cga               gg(k)=gg(k)*eps0ij
1451 cga             enddo
1452 cga             eps0ij=-evdwij*eps0ij
1453 C Uncomment for AL's type of SC correlation interactions.
1454 cadam           eps0ij=-evdwij
1455                 num_conti=num_conti+1
1456                 jcont(num_conti,i)=j
1457                 facont(num_conti,i)=fcont*eps0ij
1458                 fprimcont=eps0ij*fprimcont/rij
1459                 fcont=expon*fcont
1460 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1461 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1462 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1463 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1464                 gacont(1,num_conti,i)=-fprimcont*xj
1465                 gacont(2,num_conti,i)=-fprimcont*yj
1466                 gacont(3,num_conti,i)=-fprimcont*zj
1467 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1468 cd              write (iout,'(2i3,3f10.5)')
1469 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1470               endif
1471             endif
1472           enddo      ! j
1473         enddo        ! iint
1474 C Change 12/1/95
1475         num_cont(i)=num_conti
1476       enddo          ! i
1477       do i=1,nct
1478         do j=1,3
1479           gvdwc(j,i)=expon*gvdwc(j,i)
1480           gvdwx(j,i)=expon*gvdwx(j,i)
1481         enddo
1482       enddo
1483 C******************************************************************************
1484 C
1485 C                              N O T E !!!
1486 C
1487 C To save time, the factor of EXPON has been extracted from ALL components
1488 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1489 C use!
1490 C
1491 C******************************************************************************
1492       return
1493       end
1494 C-----------------------------------------------------------------------------
1495       subroutine eljk(evdw)
1496 C
1497 C This subroutine calculates the interaction energy of nonbonded side chains
1498 C assuming the LJK potential of interaction.
1499 C
1500       implicit real*8 (a-h,o-z)
1501       include 'DIMENSIONS'
1502       include 'COMMON.GEO'
1503       include 'COMMON.VAR'
1504       include 'COMMON.LOCAL'
1505       include 'COMMON.CHAIN'
1506       include 'COMMON.DERIV'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.NAMES'
1510       dimension gg(3)
1511       logical scheck
1512 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1513       evdw=0.0D0
1514       do i=iatsc_s,iatsc_e
1515         itypi=iabs(itype(i))
1516         if (itypi.eq.ntyp1) cycle
1517         itypi1=iabs(itype(i+1))
1518         xi=c(1,nres+i)
1519         yi=c(2,nres+i)
1520         zi=c(3,nres+i)
1521 C
1522 C Calculate SC interaction energy.
1523 C
1524         do iint=1,nint_gr(i)
1525           do j=istart(i,iint),iend(i,iint)
1526             itypj=iabs(itype(j))
1527             if (itypj.eq.ntyp1) cycle
1528             xj=c(1,nres+j)-xi
1529             yj=c(2,nres+j)-yi
1530             zj=c(3,nres+j)-zi
1531             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532             fac_augm=rrij**expon
1533             e_augm=augm(itypi,itypj)*fac_augm
1534             r_inv_ij=dsqrt(rrij)
1535             rij=1.0D0/r_inv_ij
1536             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1537             fac=r_shift_inv**expon
1538 C have you changed here?
1539             e1=fac*fac*aa
1540             e2=fac*bb
1541             evdwij=e_augm+e1+e2
1542 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1543 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1544 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1545 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1546 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1547 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1548 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1549             evdw=evdw+evdwij
1550 C
1551 C Calculate the components of the gradient in DC and X
1552 C
1553             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557             do k=1,3
1558               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1559               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1561               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1562             enddo
1563 cgrad            do k=i,j-1
1564 cgrad              do l=1,3
1565 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1566 cgrad              enddo
1567 cgrad            enddo
1568           enddo      ! j
1569         enddo        ! iint
1570       enddo          ! i
1571       do i=1,nct
1572         do j=1,3
1573           gvdwc(j,i)=expon*gvdwc(j,i)
1574           gvdwx(j,i)=expon*gvdwx(j,i)
1575         enddo
1576       enddo
1577       return
1578       end
1579 C-----------------------------------------------------------------------------
1580       subroutine ebp(evdw)
1581 C
1582 C This subroutine calculates the interaction energy of nonbonded side chains
1583 C assuming the Berne-Pechukas potential of interaction.
1584 C
1585       implicit real*8 (a-h,o-z)
1586       include 'DIMENSIONS'
1587       include 'COMMON.GEO'
1588       include 'COMMON.VAR'
1589       include 'COMMON.LOCAL'
1590       include 'COMMON.CHAIN'
1591       include 'COMMON.DERIV'
1592       include 'COMMON.NAMES'
1593       include 'COMMON.INTERACT'
1594       include 'COMMON.IOUNITS'
1595       include 'COMMON.CALC'
1596       common /srutu/ icall
1597 c     double precision rrsave(maxdim)
1598       logical lprn
1599       evdw=0.0D0
1600 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1601       evdw=0.0D0
1602 c     if (icall.eq.0) then
1603 c       lprn=.true.
1604 c     else
1605         lprn=.false.
1606 c     endif
1607       ind=0
1608       do i=iatsc_s,iatsc_e
1609         itypi=iabs(itype(i))
1610         if (itypi.eq.ntyp1) cycle
1611         itypi1=iabs(itype(i+1))
1612         xi=c(1,nres+i)
1613         yi=c(2,nres+i)
1614         zi=c(3,nres+i)
1615         dxi=dc_norm(1,nres+i)
1616         dyi=dc_norm(2,nres+i)
1617         dzi=dc_norm(3,nres+i)
1618 c        dsci_inv=dsc_inv(itypi)
1619         dsci_inv=vbld_inv(i+nres)
1620 C
1621 C Calculate SC interaction energy.
1622 C
1623         do iint=1,nint_gr(i)
1624           do j=istart(i,iint),iend(i,iint)
1625             ind=ind+1
1626             itypj=iabs(itype(j))
1627             if (itypj.eq.ntyp1) cycle
1628 c            dscj_inv=dsc_inv(itypj)
1629             dscj_inv=vbld_inv(j+nres)
1630             chi1=chi(itypi,itypj)
1631             chi2=chi(itypj,itypi)
1632             chi12=chi1*chi2
1633             chip1=chip(itypi)
1634             chip2=chip(itypj)
1635             chip12=chip1*chip2
1636             alf1=alp(itypi)
1637             alf2=alp(itypj)
1638             alf12=0.5D0*(alf1+alf2)
1639 C For diagnostics only!!!
1640 c           chi1=0.0D0
1641 c           chi2=0.0D0
1642 c           chi12=0.0D0
1643 c           chip1=0.0D0
1644 c           chip2=0.0D0
1645 c           chip12=0.0D0
1646 c           alf1=0.0D0
1647 c           alf2=0.0D0
1648 c           alf12=0.0D0
1649             xj=c(1,nres+j)-xi
1650             yj=c(2,nres+j)-yi
1651             zj=c(3,nres+j)-zi
1652             dxj=dc_norm(1,nres+j)
1653             dyj=dc_norm(2,nres+j)
1654             dzj=dc_norm(3,nres+j)
1655             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1656 cd          if (icall.eq.0) then
1657 cd            rrsave(ind)=rrij
1658 cd          else
1659 cd            rrij=rrsave(ind)
1660 cd          endif
1661             rij=dsqrt(rrij)
1662 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1663             call sc_angular
1664 C Calculate whole angle-dependent part of epsilon and contributions
1665 C to its derivatives
1666 C have you changed here?
1667             fac=(rrij*sigsq)**expon2
1668             e1=fac*fac*aa
1669             e2=fac*bb
1670             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1671             eps2der=evdwij*eps3rt
1672             eps3der=evdwij*eps2rt
1673             evdwij=evdwij*eps2rt*eps3rt
1674             evdw=evdw+evdwij
1675             if (lprn) then
1676             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1677             epsi=bb**2/aa
1678 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1679 cd     &        restyp(itypi),i,restyp(itypj),j,
1680 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1681 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1682 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1683 cd     &        evdwij
1684             endif
1685 C Calculate gradient components.
1686             e1=e1*eps1*eps2rt**2*eps3rt**2
1687             fac=-expon*(e1+evdwij)
1688             sigder=fac/sigsq
1689             fac=rrij*fac
1690 C Calculate radial part of the gradient
1691             gg(1)=xj*fac
1692             gg(2)=yj*fac
1693             gg(3)=zj*fac
1694 C Calculate the angular part of the gradient and sum add the contributions
1695 C to the appropriate components of the Cartesian gradient.
1696             call sc_grad
1697           enddo      ! j
1698         enddo        ! iint
1699       enddo          ! i
1700 c     stop
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egb(evdw)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       include 'COMMON.CONTROL'
1721       include 'COMMON.SPLITELE'
1722       include 'COMMON.SBRIDGE'
1723       logical lprn
1724       integer xshift,yshift,zshift
1725
1726       evdw=0.0D0
1727 ccccc      energy_dec=.false.
1728 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1729       evdw=0.0D0
1730       lprn=.false.
1731 c     if (icall.eq.0) lprn=.false.
1732       ind=0
1733 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1734 C we have the original box)
1735 C      do xshift=-1,1
1736 C      do yshift=-1,1
1737 C      do zshift=-1,1
1738       do i=iatsc_s,iatsc_e
1739         itypi=iabs(itype(i))
1740         if (itypi.eq.ntyp1) cycle
1741         itypi1=iabs(itype(i+1))
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745 C Return atom into box, boxxsize is size of box in x dimension
1746 c  134   continue
1747 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1748 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1749 C Condition for being inside the proper box
1750 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1751 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1752 c        go to 134
1753 c        endif
1754 c  135   continue
1755 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1756 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1757 C Condition for being inside the proper box
1758 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1759 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1760 c        go to 135
1761 c        endif
1762 c  136   continue
1763 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1764 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1765 C Condition for being inside the proper box
1766 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1767 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1768 c        go to 136
1769 c        endif
1770           xi=mod(xi,boxxsize)
1771           if (xi.lt.0) xi=xi+boxxsize
1772           yi=mod(yi,boxysize)
1773           if (yi.lt.0) yi=yi+boxysize
1774           zi=mod(zi,boxzsize)
1775           if (zi.lt.0) zi=zi+boxzsize
1776 C define scaling factor for lipids
1777
1778 C        if (positi.le.0) positi=positi+boxzsize
1779 C        print *,i
1780 C first for peptide groups
1781 c for each residue check if it is in lipid or lipid water border area
1782        if ((zi.gt.bordlipbot)
1783      &.and.(zi.lt.bordliptop)) then
1784 C the energy transfer exist
1785         if (zi.lt.buflipbot) then
1786 C what fraction I am in
1787          fracinbuf=1.0d0-
1788      &        ((zi-bordlipbot)/lipbufthick)
1789 C lipbufthick is thickenes of lipid buffore
1790          sslipi=sscalelip(fracinbuf)
1791          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1792         elseif (zi.gt.bufliptop) then
1793          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1794          sslipi=sscalelip(fracinbuf)
1795          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1796         else
1797          sslipi=1.0d0
1798          ssgradlipi=0.0
1799         endif
1800        else
1801          sslipi=0.0d0
1802          ssgradlipi=0.0
1803        endif
1804
1805 C          xi=xi+xshift*boxxsize
1806 C          yi=yi+yshift*boxysize
1807 C          zi=zi+zshift*boxzsize
1808
1809         dxi=dc_norm(1,nres+i)
1810         dyi=dc_norm(2,nres+i)
1811         dzi=dc_norm(3,nres+i)
1812 c        dsci_inv=dsc_inv(itypi)
1813         dsci_inv=vbld_inv(i+nres)
1814 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1815 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1816 C
1817 C Calculate SC interaction energy.
1818 C
1819         do iint=1,nint_gr(i)
1820           do j=istart(i,iint),iend(i,iint)
1821             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1822
1823 c              write(iout,*) "PRZED ZWYKLE", evdwij
1824               call dyn_ssbond_ene(i,j,evdwij)
1825 c              write(iout,*) "PO ZWYKLE", evdwij
1826
1827               evdw=evdw+evdwij
1828               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1829      &                        'evdw',i,j,evdwij,' ss'
1830 C triple bond artifac removal
1831              do k=j+1,iend(i,iint)
1832 C search over all next residues
1833               if (dyn_ss_mask(k)) then
1834 C check if they are cysteins
1835 C              write(iout,*) 'k=',k
1836
1837 c              write(iout,*) "PRZED TRI", evdwij
1838                evdwij_przed_tri=evdwij
1839               call triple_ssbond_ene(i,j,k,evdwij)
1840 c               if(evdwij_przed_tri.ne.evdwij) then
1841 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1842 c               endif
1843
1844 c              write(iout,*) "PO TRI", evdwij
1845 C call the energy function that removes the artifical triple disulfide
1846 C bond the soubroutine is located in ssMD.F
1847               evdw=evdw+evdwij
1848               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1849      &                        'evdw',i,j,evdwij,'tss'
1850               endif!dyn_ss_mask(k)
1851              enddo! k
1852             ELSE
1853             ind=ind+1
1854             itypj=iabs(itype(j))
1855             if (itypj.eq.ntyp1) cycle
1856 c            dscj_inv=dsc_inv(itypj)
1857             dscj_inv=vbld_inv(j+nres)
1858 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1859 c     &       1.0d0/vbld(j+nres)
1860 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1861             sig0ij=sigma(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881             xj=c(1,nres+j)
1882             yj=c(2,nres+j)
1883             zj=c(3,nres+j)
1884 C Return atom J into box the original box
1885 c  137   continue
1886 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1887 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1888 C Condition for being inside the proper box
1889 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1890 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1891 c        go to 137
1892 c        endif
1893 c  138   continue
1894 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1895 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1896 C Condition for being inside the proper box
1897 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1898 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1899 c        go to 138
1900 c        endif
1901 c  139   continue
1902 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1903 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1904 C Condition for being inside the proper box
1905 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1906 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1907 c        go to 139
1908 c        endif
1909           xj=mod(xj,boxxsize)
1910           if (xj.lt.0) xj=xj+boxxsize
1911           yj=mod(yj,boxysize)
1912           if (yj.lt.0) yj=yj+boxysize
1913           zj=mod(zj,boxzsize)
1914           if (zj.lt.0) zj=zj+boxzsize
1915        if ((zj.gt.bordlipbot)
1916      &.and.(zj.lt.bordliptop)) then
1917 C the energy transfer exist
1918         if (zj.lt.buflipbot) then
1919 C what fraction I am in
1920          fracinbuf=1.0d0-
1921      &        ((zj-bordlipbot)/lipbufthick)
1922 C lipbufthick is thickenes of lipid buffore
1923          sslipj=sscalelip(fracinbuf)
1924          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925         elseif (zj.gt.bufliptop) then
1926          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927          sslipj=sscalelip(fracinbuf)
1928          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1929         else
1930          sslipj=1.0d0
1931          ssgradlipj=0.0
1932         endif
1933        else
1934          sslipj=0.0d0
1935          ssgradlipj=0.0
1936        endif
1937       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1940      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1942 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1943 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1944 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1945 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1946       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1947       xj_safe=xj
1948       yj_safe=yj
1949       zj_safe=zj
1950       subchap=0
1951       do xshift=-1,1
1952       do yshift=-1,1
1953       do zshift=-1,1
1954           xj=xj_safe+xshift*boxxsize
1955           yj=yj_safe+yshift*boxysize
1956           zj=zj_safe+zshift*boxzsize
1957           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1958           if(dist_temp.lt.dist_init) then
1959             dist_init=dist_temp
1960             xj_temp=xj
1961             yj_temp=yj
1962             zj_temp=zj
1963             subchap=1
1964           endif
1965        enddo
1966        enddo
1967        enddo
1968        if (subchap.eq.1) then
1969           xj=xj_temp-xi
1970           yj=yj_temp-yi
1971           zj=zj_temp-zi
1972        else
1973           xj=xj_safe-xi
1974           yj=yj_safe-yi
1975           zj=zj_safe-zi
1976        endif
1977             dxj=dc_norm(1,nres+j)
1978             dyj=dc_norm(2,nres+j)
1979             dzj=dc_norm(3,nres+j)
1980 C            xj=xj-xi
1981 C            yj=yj-yi
1982 C            zj=zj-zi
1983 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1984 c            write (iout,*) "j",j," dc_norm",
1985 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1986             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1987             rij=dsqrt(rrij)
1988             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1989             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1990
1991 c            write (iout,'(a7,4f8.3)')
1992 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1993             if (sss.gt.0.0d0) then
1994 C Calculate angle-dependent terms of energy and contributions to their
1995 C derivatives.
1996             call sc_angular
1997             sigsq=1.0D0/sigsq
1998             sig=sig0ij*dsqrt(sigsq)
1999             rij_shift=1.0D0/rij-sig+sig0ij
2000 c for diagnostics; uncomment
2001 c            rij_shift=1.2*sig0ij
2002 C I hate to put IF's in the loops, but here don't have another choice!!!!
2003             if (rij_shift.le.0.0D0) then
2004               evdw=1.0D20
2005 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2006 cd     &        restyp(itypi),i,restyp(itypj),j,
2007 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2008               return
2009             endif
2010             sigder=-sig*sigsq
2011 c---------------------------------------------------------------
2012             rij_shift=1.0D0/rij_shift
2013             fac=rij_shift**expon
2014 C here to start with
2015 C            if (c(i,3).gt.
2016             faclip=fac
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2023 C     &((sslipi+sslipj)/2.0d0+
2024 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2025 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2026 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2027             evdwij=evdwij*eps2rt*eps3rt
2028             evdw=evdw+evdwij*sss
2029             if (lprn) then
2030             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2031             epsi=bb**2/aa
2032             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2033      &        restyp(itypi),i,restyp(itypj),j,
2034      &        epsi,sigm,chi1,chi2,chip1,chip2,
2035      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2036      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2037      &        evdwij
2038             endif
2039
2040             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2041      &                        'evdw',i,j,evdwij
2042
2043 C Calculate gradient components.
2044             e1=e1*eps1*eps2rt**2*eps3rt**2
2045             fac=-expon*(e1+evdwij)*rij_shift
2046             sigder=fac*sigder
2047             fac=rij*fac
2048 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2049 c     &      evdwij,fac,sigma(itypi,itypj),expon
2050             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2051 c            fac=0.0d0
2052 C Calculate the radial part of the gradient
2053             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2054      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2055      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2056      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2057             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2058             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2059 C            gg_lipi(3)=0.0d0
2060 C            gg_lipj(3)=0.0d0
2061             gg(1)=xj*fac
2062             gg(2)=yj*fac
2063             gg(3)=zj*fac
2064 C Calculate angular part of the gradient.
2065             call sc_grad
2066             endif
2067             ENDIF    ! dyn_ss
2068           enddo      ! j
2069         enddo        ! iint
2070       enddo          ! i
2071 C      enddo          ! zshift
2072 C      enddo          ! yshift
2073 C      enddo          ! xshift
2074 c      write (iout,*) "Number of loop steps in EGB:",ind
2075 cccc      energy_dec=.false.
2076       return
2077       end
2078 C-----------------------------------------------------------------------------
2079       subroutine egbv(evdw)
2080 C
2081 C This subroutine calculates the interaction energy of nonbonded side chains
2082 C assuming the Gay-Berne-Vorobjev potential of interaction.
2083 C
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.GEO'
2087       include 'COMMON.VAR'
2088       include 'COMMON.LOCAL'
2089       include 'COMMON.CHAIN'
2090       include 'COMMON.DERIV'
2091       include 'COMMON.NAMES'
2092       include 'COMMON.INTERACT'
2093       include 'COMMON.IOUNITS'
2094       include 'COMMON.CALC'
2095       common /srutu/ icall
2096       logical lprn
2097       evdw=0.0D0
2098 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2099       evdw=0.0D0
2100       lprn=.false.
2101 c     if (icall.eq.0) lprn=.true.
2102       ind=0
2103       do i=iatsc_s,iatsc_e
2104         itypi=iabs(itype(i))
2105         if (itypi.eq.ntyp1) cycle
2106         itypi1=iabs(itype(i+1))
2107         xi=c(1,nres+i)
2108         yi=c(2,nres+i)
2109         zi=c(3,nres+i)
2110           xi=mod(xi,boxxsize)
2111           if (xi.lt.0) xi=xi+boxxsize
2112           yi=mod(yi,boxysize)
2113           if (yi.lt.0) yi=yi+boxysize
2114           zi=mod(zi,boxzsize)
2115           if (zi.lt.0) zi=zi+boxzsize
2116 C define scaling factor for lipids
2117
2118 C        if (positi.le.0) positi=positi+boxzsize
2119 C        print *,i
2120 C first for peptide groups
2121 c for each residue check if it is in lipid or lipid water border area
2122        if ((zi.gt.bordlipbot)
2123      &.and.(zi.lt.bordliptop)) then
2124 C the energy transfer exist
2125         if (zi.lt.buflipbot) then
2126 C what fraction I am in
2127          fracinbuf=1.0d0-
2128      &        ((zi-bordlipbot)/lipbufthick)
2129 C lipbufthick is thickenes of lipid buffore
2130          sslipi=sscalelip(fracinbuf)
2131          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2132         elseif (zi.gt.bufliptop) then
2133          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2134          sslipi=sscalelip(fracinbuf)
2135          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2136         else
2137          sslipi=1.0d0
2138          ssgradlipi=0.0
2139         endif
2140        else
2141          sslipi=0.0d0
2142          ssgradlipi=0.0
2143        endif
2144
2145         dxi=dc_norm(1,nres+i)
2146         dyi=dc_norm(2,nres+i)
2147         dzi=dc_norm(3,nres+i)
2148 c        dsci_inv=dsc_inv(itypi)
2149         dsci_inv=vbld_inv(i+nres)
2150 C
2151 C Calculate SC interaction energy.
2152 C
2153         do iint=1,nint_gr(i)
2154           do j=istart(i,iint),iend(i,iint)
2155             ind=ind+1
2156             itypj=iabs(itype(j))
2157             if (itypj.eq.ntyp1) cycle
2158 c            dscj_inv=dsc_inv(itypj)
2159             dscj_inv=vbld_inv(j+nres)
2160             sig0ij=sigma(itypi,itypj)
2161             r0ij=r0(itypi,itypj)
2162             chi1=chi(itypi,itypj)
2163             chi2=chi(itypj,itypi)
2164             chi12=chi1*chi2
2165             chip1=chip(itypi)
2166             chip2=chip(itypj)
2167             chip12=chip1*chip2
2168             alf1=alp(itypi)
2169             alf2=alp(itypj)
2170             alf12=0.5D0*(alf1+alf2)
2171 C For diagnostics only!!!
2172 c           chi1=0.0D0
2173 c           chi2=0.0D0
2174 c           chi12=0.0D0
2175 c           chip1=0.0D0
2176 c           chip2=0.0D0
2177 c           chip12=0.0D0
2178 c           alf1=0.0D0
2179 c           alf2=0.0D0
2180 c           alf12=0.0D0
2181 C            xj=c(1,nres+j)-xi
2182 C            yj=c(2,nres+j)-yi
2183 C            zj=c(3,nres+j)-zi
2184           xj=mod(xj,boxxsize)
2185           if (xj.lt.0) xj=xj+boxxsize
2186           yj=mod(yj,boxysize)
2187           if (yj.lt.0) yj=yj+boxysize
2188           zj=mod(zj,boxzsize)
2189           if (zj.lt.0) zj=zj+boxzsize
2190        if ((zj.gt.bordlipbot)
2191      &.and.(zj.lt.bordliptop)) then
2192 C the energy transfer exist
2193         if (zj.lt.buflipbot) then
2194 C what fraction I am in
2195          fracinbuf=1.0d0-
2196      &        ((zj-bordlipbot)/lipbufthick)
2197 C lipbufthick is thickenes of lipid buffore
2198          sslipj=sscalelip(fracinbuf)
2199          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2200         elseif (zj.gt.bufliptop) then
2201          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2202          sslipj=sscalelip(fracinbuf)
2203          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2204         else
2205          sslipj=1.0d0
2206          ssgradlipj=0.0
2207         endif
2208        else
2209          sslipj=0.0d0
2210          ssgradlipj=0.0
2211        endif
2212       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2213      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2214       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2215      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2216 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2217 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2218 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2219       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2220       xj_safe=xj
2221       yj_safe=yj
2222       zj_safe=zj
2223       subchap=0
2224       do xshift=-1,1
2225       do yshift=-1,1
2226       do zshift=-1,1
2227           xj=xj_safe+xshift*boxxsize
2228           yj=yj_safe+yshift*boxysize
2229           zj=zj_safe+zshift*boxzsize
2230           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2231           if(dist_temp.lt.dist_init) then
2232             dist_init=dist_temp
2233             xj_temp=xj
2234             yj_temp=yj
2235             zj_temp=zj
2236             subchap=1
2237           endif
2238        enddo
2239        enddo
2240        enddo
2241        if (subchap.eq.1) then
2242           xj=xj_temp-xi
2243           yj=yj_temp-yi
2244           zj=zj_temp-zi
2245        else
2246           xj=xj_safe-xi
2247           yj=yj_safe-yi
2248           zj=zj_safe-zi
2249        endif
2250             dxj=dc_norm(1,nres+j)
2251             dyj=dc_norm(2,nres+j)
2252             dzj=dc_norm(3,nres+j)
2253             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2254             rij=dsqrt(rrij)
2255 C Calculate angle-dependent terms of energy and contributions to their
2256 C derivatives.
2257             call sc_angular
2258             sigsq=1.0D0/sigsq
2259             sig=sig0ij*dsqrt(sigsq)
2260             rij_shift=1.0D0/rij-sig+r0ij
2261 C I hate to put IF's in the loops, but here don't have another choice!!!!
2262             if (rij_shift.le.0.0D0) then
2263               evdw=1.0D20
2264               return
2265             endif
2266             sigder=-sig*sigsq
2267 c---------------------------------------------------------------
2268             rij_shift=1.0D0/rij_shift
2269             fac=rij_shift**expon
2270             e1=fac*fac*aa
2271             e2=fac*bb
2272             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2273             eps2der=evdwij*eps3rt
2274             eps3der=evdwij*eps2rt
2275             fac_augm=rrij**expon
2276             e_augm=augm(itypi,itypj)*fac_augm
2277             evdwij=evdwij*eps2rt*eps3rt
2278             evdw=evdw+evdwij+e_augm
2279             if (lprn) then
2280             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2281             epsi=bb**2/aa
2282             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2283      &        restyp(itypi),i,restyp(itypj),j,
2284      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2285      &        chi1,chi2,chip1,chip2,
2286      &        eps1,eps2rt**2,eps3rt**2,
2287      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2288      &        evdwij+e_augm
2289             endif
2290 C Calculate gradient components.
2291             e1=e1*eps1*eps2rt**2*eps3rt**2
2292             fac=-expon*(e1+evdwij)*rij_shift
2293             sigder=fac*sigder
2294             fac=rij*fac-2*expon*rrij*e_augm
2295             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2296 C Calculate the radial part of the gradient
2297             gg(1)=xj*fac
2298             gg(2)=yj*fac
2299             gg(3)=zj*fac
2300 C Calculate angular part of the gradient.
2301             call sc_grad
2302           enddo      ! j
2303         enddo        ! iint
2304       enddo          ! i
2305       end
2306 C-----------------------------------------------------------------------------
2307       subroutine sc_angular
2308 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2309 C om12. Called by ebp, egb, and egbv.
2310       implicit none
2311       include 'COMMON.CALC'
2312       include 'COMMON.IOUNITS'
2313       erij(1)=xj*rij
2314       erij(2)=yj*rij
2315       erij(3)=zj*rij
2316       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2317       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2318       om12=dxi*dxj+dyi*dyj+dzi*dzj
2319       chiom12=chi12*om12
2320 C Calculate eps1(om12) and its derivative in om12
2321       faceps1=1.0D0-om12*chiom12
2322       faceps1_inv=1.0D0/faceps1
2323       eps1=dsqrt(faceps1_inv)
2324 C Following variable is eps1*deps1/dom12
2325       eps1_om12=faceps1_inv*chiom12
2326 c diagnostics only
2327 c      faceps1_inv=om12
2328 c      eps1=om12
2329 c      eps1_om12=1.0d0
2330 c      write (iout,*) "om12",om12," eps1",eps1
2331 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2332 C and om12.
2333       om1om2=om1*om2
2334       chiom1=chi1*om1
2335       chiom2=chi2*om2
2336       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2337       sigsq=1.0D0-facsig*faceps1_inv
2338       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2339       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2340       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2341 c diagnostics only
2342 c      sigsq=1.0d0
2343 c      sigsq_om1=0.0d0
2344 c      sigsq_om2=0.0d0
2345 c      sigsq_om12=0.0d0
2346 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2347 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2348 c     &    " eps1",eps1
2349 C Calculate eps2 and its derivatives in om1, om2, and om12.
2350       chipom1=chip1*om1
2351       chipom2=chip2*om2
2352       chipom12=chip12*om12
2353       facp=1.0D0-om12*chipom12
2354       facp_inv=1.0D0/facp
2355       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2356 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2357 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2358 C Following variable is the square root of eps2
2359       eps2rt=1.0D0-facp1*facp_inv
2360 C Following three variables are the derivatives of the square root of eps
2361 C in om1, om2, and om12.
2362       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2363       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2364       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2365 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2366       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2367 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2368 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2369 c     &  " eps2rt_om12",eps2rt_om12
2370 C Calculate whole angle-dependent part of epsilon and contributions
2371 C to its derivatives
2372       return
2373       end
2374 C----------------------------------------------------------------------------
2375       subroutine sc_grad
2376       implicit real*8 (a-h,o-z)
2377       include 'DIMENSIONS'
2378       include 'COMMON.CHAIN'
2379       include 'COMMON.DERIV'
2380       include 'COMMON.CALC'
2381       include 'COMMON.IOUNITS'
2382       double precision dcosom1(3),dcosom2(3)
2383 cc      print *,'sss=',sss
2384       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2385       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2386       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2387      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2388 c diagnostics only
2389 c      eom1=0.0d0
2390 c      eom2=0.0d0
2391 c      eom12=evdwij*eps1_om12
2392 c end diagnostics
2393 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2394 c     &  " sigder",sigder
2395 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2396 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2397       do k=1,3
2398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2400       enddo
2401       do k=1,3
2402         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2403       enddo
2404 c      write (iout,*) "gg",(gg(k),k=1,3)
2405       do k=1,3
2406         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2407      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2409         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2410      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2411      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2412 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2413 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2414 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2415 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2416       enddo
2417 C
2418 C Calculate the components of the gradient in DC and X
2419 C
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       do l=1,3
2426         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2427         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2428       enddo
2429       return
2430       end
2431 C-----------------------------------------------------------------------
2432       subroutine e_softsphere(evdw)
2433 C
2434 C This subroutine calculates the interaction energy of nonbonded side chains
2435 C assuming the LJ potential of interaction.
2436 C
2437       implicit real*8 (a-h,o-z)
2438       include 'DIMENSIONS'
2439       parameter (accur=1.0d-10)
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.TORSION'
2447       include 'COMMON.SBRIDGE'
2448       include 'COMMON.NAMES'
2449       include 'COMMON.IOUNITS'
2450       include 'COMMON.CONTACTS'
2451       dimension gg(3)
2452 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2453       evdw=0.0D0
2454       do i=iatsc_s,iatsc_e
2455         itypi=iabs(itype(i))
2456         if (itypi.eq.ntyp1) cycle
2457         itypi1=iabs(itype(i+1))
2458         xi=c(1,nres+i)
2459         yi=c(2,nres+i)
2460         zi=c(3,nres+i)
2461 C
2462 C Calculate SC interaction energy.
2463 C
2464         do iint=1,nint_gr(i)
2465 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd   &                  'iend=',iend(i,iint)
2467           do j=istart(i,iint),iend(i,iint)
2468             itypj=iabs(itype(j))
2469             if (itypj.eq.ntyp1) cycle
2470             xj=c(1,nres+j)-xi
2471             yj=c(2,nres+j)-yi
2472             zj=c(3,nres+j)-zi
2473             rij=xj*xj+yj*yj+zj*zj
2474 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475             r0ij=r0(itypi,itypj)
2476             r0ijsq=r0ij*r0ij
2477 c            print *,i,j,r0ij,dsqrt(rij)
2478             if (rij.lt.r0ijsq) then
2479               evdwij=0.25d0*(rij-r0ijsq)**2
2480               fac=rij-r0ijsq
2481             else
2482               evdwij=0.0d0
2483               fac=0.0d0
2484             endif
2485             evdw=evdw+evdwij
2486 C
2487 C Calculate the components of the gradient in DC and X
2488 C
2489             gg(1)=xj*fac
2490             gg(2)=yj*fac
2491             gg(3)=zj*fac
2492             do k=1,3
2493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2497             enddo
2498 cgrad            do k=i,j-1
2499 cgrad              do l=1,3
2500 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2501 cgrad              enddo
2502 cgrad            enddo
2503           enddo ! j
2504         enddo ! iint
2505       enddo ! i
2506       return
2507       end
2508 C--------------------------------------------------------------------------
2509       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2510      &              eello_turn4)
2511 C
2512 C Soft-sphere potential of p-p interaction
2513 C
2514       implicit real*8 (a-h,o-z)
2515       include 'DIMENSIONS'
2516       include 'COMMON.CONTROL'
2517       include 'COMMON.IOUNITS'
2518       include 'COMMON.GEO'
2519       include 'COMMON.VAR'
2520       include 'COMMON.LOCAL'
2521       include 'COMMON.CHAIN'
2522       include 'COMMON.DERIV'
2523       include 'COMMON.INTERACT'
2524       include 'COMMON.CONTACTS'
2525       include 'COMMON.TORSION'
2526       include 'COMMON.VECTORS'
2527       include 'COMMON.FFIELD'
2528       dimension ggg(3)
2529 C      write(iout,*) 'In EELEC_soft_sphere'
2530       ees=0.0D0
2531       evdw1=0.0D0
2532       eel_loc=0.0d0
2533       eello_turn3=0.0d0
2534       eello_turn4=0.0d0
2535       ind=0
2536       do i=iatel_s,iatel_e
2537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2538         dxi=dc(1,i)
2539         dyi=dc(2,i)
2540         dzi=dc(3,i)
2541         xmedi=c(1,i)+0.5d0*dxi
2542         ymedi=c(2,i)+0.5d0*dyi
2543         zmedi=c(3,i)+0.5d0*dzi
2544           xmedi=mod(xmedi,boxxsize)
2545           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2546           ymedi=mod(ymedi,boxysize)
2547           if (ymedi.lt.0) ymedi=ymedi+boxysize
2548           zmedi=mod(zmedi,boxzsize)
2549           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2550         num_conti=0
2551 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2552         do j=ielstart(i),ielend(i)
2553           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2554           ind=ind+1
2555           iteli=itel(i)
2556           itelj=itel(j)
2557           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2558           r0ij=rpp(iteli,itelj)
2559           r0ijsq=r0ij*r0ij
2560           dxj=dc(1,j)
2561           dyj=dc(2,j)
2562           dzj=dc(3,j)
2563           xj=c(1,j)+0.5D0*dxj
2564           yj=c(2,j)+0.5D0*dyj
2565           zj=c(3,j)+0.5D0*dzj
2566           xj=mod(xj,boxxsize)
2567           if (xj.lt.0) xj=xj+boxxsize
2568           yj=mod(yj,boxysize)
2569           if (yj.lt.0) yj=yj+boxysize
2570           zj=mod(zj,boxzsize)
2571           if (zj.lt.0) zj=zj+boxzsize
2572       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2573       xj_safe=xj
2574       yj_safe=yj
2575       zj_safe=zj
2576       isubchap=0
2577       do xshift=-1,1
2578       do yshift=-1,1
2579       do zshift=-1,1
2580           xj=xj_safe+xshift*boxxsize
2581           yj=yj_safe+yshift*boxysize
2582           zj=zj_safe+zshift*boxzsize
2583           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2584           if(dist_temp.lt.dist_init) then
2585             dist_init=dist_temp
2586             xj_temp=xj
2587             yj_temp=yj
2588             zj_temp=zj
2589             isubchap=1
2590           endif
2591        enddo
2592        enddo
2593        enddo
2594        if (isubchap.eq.1) then
2595           xj=xj_temp-xmedi
2596           yj=yj_temp-ymedi
2597           zj=zj_temp-zmedi
2598        else
2599           xj=xj_safe-xmedi
2600           yj=yj_safe-ymedi
2601           zj=zj_safe-zmedi
2602        endif
2603           rij=xj*xj+yj*yj+zj*zj
2604             sss=sscale(sqrt(rij))
2605             sssgrad=sscagrad(sqrt(rij))
2606           if (rij.lt.r0ijsq) then
2607             evdw1ij=0.25d0*(rij-r0ijsq)**2
2608             fac=rij-r0ijsq
2609           else
2610             evdw1ij=0.0d0
2611             fac=0.0d0
2612           endif
2613           evdw1=evdw1+evdw1ij*sss
2614 C
2615 C Calculate contributions to the Cartesian gradient.
2616 C
2617           ggg(1)=fac*xj*sssgrad
2618           ggg(2)=fac*yj*sssgrad
2619           ggg(3)=fac*zj*sssgrad
2620           do k=1,3
2621             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2622             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2623           enddo
2624 *
2625 * Loop over residues i+1 thru j-1.
2626 *
2627 cgrad          do k=i+1,j-1
2628 cgrad            do l=1,3
2629 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2630 cgrad            enddo
2631 cgrad          enddo
2632         enddo ! j
2633       enddo   ! i
2634 cgrad      do i=nnt,nct-1
2635 cgrad        do k=1,3
2636 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2637 cgrad        enddo
2638 cgrad        do j=i+1,nct-1
2639 cgrad          do k=1,3
2640 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2641 cgrad          enddo
2642 cgrad        enddo
2643 cgrad      enddo
2644       return
2645       end
2646 c------------------------------------------------------------------------------
2647       subroutine vec_and_deriv
2648       implicit real*8 (a-h,o-z)
2649       include 'DIMENSIONS'
2650 #ifdef MPI
2651       include 'mpif.h'
2652 #endif
2653       include 'COMMON.IOUNITS'
2654       include 'COMMON.GEO'
2655       include 'COMMON.VAR'
2656       include 'COMMON.LOCAL'
2657       include 'COMMON.CHAIN'
2658       include 'COMMON.VECTORS'
2659       include 'COMMON.SETUP'
2660       include 'COMMON.TIME1'
2661       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2662 C Compute the local reference systems. For reference system (i), the
2663 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2664 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2665 #ifdef PARVEC
2666       do i=ivec_start,ivec_end
2667 #else
2668       do i=1,nres-1
2669 #endif
2670           if (i.eq.nres-1) then
2671 C Case of the last full residue
2672 C Compute the Z-axis
2673             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2674             costh=dcos(pi-theta(nres))
2675             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2676             do k=1,3
2677               uz(k,i)=fac*uz(k,i)
2678             enddo
2679 C Compute the derivatives of uz
2680             uzder(1,1,1)= 0.0d0
2681             uzder(2,1,1)=-dc_norm(3,i-1)
2682             uzder(3,1,1)= dc_norm(2,i-1)
2683             uzder(1,2,1)= dc_norm(3,i-1)
2684             uzder(2,2,1)= 0.0d0
2685             uzder(3,2,1)=-dc_norm(1,i-1)
2686             uzder(1,3,1)=-dc_norm(2,i-1)
2687             uzder(2,3,1)= dc_norm(1,i-1)
2688             uzder(3,3,1)= 0.0d0
2689             uzder(1,1,2)= 0.0d0
2690             uzder(2,1,2)= dc_norm(3,i)
2691             uzder(3,1,2)=-dc_norm(2,i)
2692             uzder(1,2,2)=-dc_norm(3,i)
2693             uzder(2,2,2)= 0.0d0
2694             uzder(3,2,2)= dc_norm(1,i)
2695             uzder(1,3,2)= dc_norm(2,i)
2696             uzder(2,3,2)=-dc_norm(1,i)
2697             uzder(3,3,2)= 0.0d0
2698 C Compute the Y-axis
2699             facy=fac
2700             do k=1,3
2701               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2702             enddo
2703 C Compute the derivatives of uy
2704             do j=1,3
2705               do k=1,3
2706                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2707      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2708                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2709               enddo
2710               uyder(j,j,1)=uyder(j,j,1)-costh
2711               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2712             enddo
2713             do j=1,2
2714               do k=1,3
2715                 do l=1,3
2716                   uygrad(l,k,j,i)=uyder(l,k,j)
2717                   uzgrad(l,k,j,i)=uzder(l,k,j)
2718                 enddo
2719               enddo
2720             enddo
2721             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2722             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2723             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2724             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2725           else
2726 C Other residues
2727 C Compute the Z-axis
2728             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2729             costh=dcos(pi-theta(i+2))
2730             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2731             do k=1,3
2732               uz(k,i)=fac*uz(k,i)
2733             enddo
2734 C Compute the derivatives of uz
2735             uzder(1,1,1)= 0.0d0
2736             uzder(2,1,1)=-dc_norm(3,i+1)
2737             uzder(3,1,1)= dc_norm(2,i+1)
2738             uzder(1,2,1)= dc_norm(3,i+1)
2739             uzder(2,2,1)= 0.0d0
2740             uzder(3,2,1)=-dc_norm(1,i+1)
2741             uzder(1,3,1)=-dc_norm(2,i+1)
2742             uzder(2,3,1)= dc_norm(1,i+1)
2743             uzder(3,3,1)= 0.0d0
2744             uzder(1,1,2)= 0.0d0
2745             uzder(2,1,2)= dc_norm(3,i)
2746             uzder(3,1,2)=-dc_norm(2,i)
2747             uzder(1,2,2)=-dc_norm(3,i)
2748             uzder(2,2,2)= 0.0d0
2749             uzder(3,2,2)= dc_norm(1,i)
2750             uzder(1,3,2)= dc_norm(2,i)
2751             uzder(2,3,2)=-dc_norm(1,i)
2752             uzder(3,3,2)= 0.0d0
2753 C Compute the Y-axis
2754             facy=fac
2755             do k=1,3
2756               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2757             enddo
2758 C Compute the derivatives of uy
2759             do j=1,3
2760               do k=1,3
2761                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2762      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2763                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2764               enddo
2765               uyder(j,j,1)=uyder(j,j,1)-costh
2766               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2767             enddo
2768             do j=1,2
2769               do k=1,3
2770                 do l=1,3
2771                   uygrad(l,k,j,i)=uyder(l,k,j)
2772                   uzgrad(l,k,j,i)=uzder(l,k,j)
2773                 enddo
2774               enddo
2775             enddo
2776             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2777             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2778             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2779             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2780           endif
2781       enddo
2782       do i=1,nres-1
2783         vbld_inv_temp(1)=vbld_inv(i+1)
2784         if (i.lt.nres-1) then
2785           vbld_inv_temp(2)=vbld_inv(i+2)
2786           else
2787           vbld_inv_temp(2)=vbld_inv(i)
2788           endif
2789         do j=1,2
2790           do k=1,3
2791             do l=1,3
2792               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2793               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2794             enddo
2795           enddo
2796         enddo
2797       enddo
2798 #if defined(PARVEC) && defined(MPI)
2799       if (nfgtasks1.gt.1) then
2800         time00=MPI_Wtime()
2801 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2802 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2803 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2804         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2811      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2812      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2813         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2814      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2815      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2816         time_gather=time_gather+MPI_Wtime()-time00
2817       endif
2818 c      if (fg_rank.eq.0) then
2819 c        write (iout,*) "Arrays UY and UZ"
2820 c        do i=1,nres-1
2821 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2822 c     &     (uz(k,i),k=1,3)
2823 c        enddo
2824 c      endif
2825 #endif
2826       return
2827       end
2828 C-----------------------------------------------------------------------------
2829       subroutine check_vecgrad
2830       implicit real*8 (a-h,o-z)
2831       include 'DIMENSIONS'
2832       include 'COMMON.IOUNITS'
2833       include 'COMMON.GEO'
2834       include 'COMMON.VAR'
2835       include 'COMMON.LOCAL'
2836       include 'COMMON.CHAIN'
2837       include 'COMMON.VECTORS'
2838       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2839       dimension uyt(3,maxres),uzt(3,maxres)
2840       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2841       double precision delta /1.0d-7/
2842       call vec_and_deriv
2843 cd      do i=1,nres
2844 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2845 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2846 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2847 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2848 cd     &     (dc_norm(if90,i),if90=1,3)
2849 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2850 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2851 cd          write(iout,'(a)')
2852 cd      enddo
2853       do i=1,nres
2854         do j=1,2
2855           do k=1,3
2856             do l=1,3
2857               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2858               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2859             enddo
2860           enddo
2861         enddo
2862       enddo
2863       call vec_and_deriv
2864       do i=1,nres
2865         do j=1,3
2866           uyt(j,i)=uy(j,i)
2867           uzt(j,i)=uz(j,i)
2868         enddo
2869       enddo
2870       do i=1,nres
2871 cd        write (iout,*) 'i=',i
2872         do k=1,3
2873           erij(k)=dc_norm(k,i)
2874         enddo
2875         do j=1,3
2876           do k=1,3
2877             dc_norm(k,i)=erij(k)
2878           enddo
2879           dc_norm(j,i)=dc_norm(j,i)+delta
2880 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2881 c          do k=1,3
2882 c            dc_norm(k,i)=dc_norm(k,i)/fac
2883 c          enddo
2884 c          write (iout,*) (dc_norm(k,i),k=1,3)
2885 c          write (iout,*) (erij(k),k=1,3)
2886           call vec_and_deriv
2887           do k=1,3
2888             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2889             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2890             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2891             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2892           enddo
2893 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2894 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2895 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2896         enddo
2897         do k=1,3
2898           dc_norm(k,i)=erij(k)
2899         enddo
2900 cd        do k=1,3
2901 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2902 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2903 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2904 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2905 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2906 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2907 cd          write (iout,'(a)')
2908 cd        enddo
2909       enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine set_matrices
2914       implicit real*8 (a-h,o-z)
2915       include 'DIMENSIONS'
2916 #ifdef MPI
2917       include "mpif.h"
2918       include "COMMON.SETUP"
2919       integer IERR
2920       integer status(MPI_STATUS_SIZE)
2921 #endif
2922       include 'COMMON.IOUNITS'
2923       include 'COMMON.GEO'
2924       include 'COMMON.VAR'
2925       include 'COMMON.LOCAL'
2926       include 'COMMON.CHAIN'
2927       include 'COMMON.DERIV'
2928       include 'COMMON.INTERACT'
2929       include 'COMMON.CONTACTS'
2930       include 'COMMON.TORSION'
2931       include 'COMMON.VECTORS'
2932       include 'COMMON.FFIELD'
2933       double precision auxvec(2),auxmat(2,2)
2934 C
2935 C Compute the virtual-bond-torsional-angle dependent quantities needed
2936 C to calculate the el-loc multibody terms of various order.
2937 C
2938 c      write(iout,*) 'nphi=',nphi,nres
2939 #ifdef PARMAT
2940       do i=ivec_start+2,ivec_end+2
2941 #else
2942       do i=3,nres+1
2943 #endif
2944 #ifdef NEWCORR
2945         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2946           iti = itype2loc(itype(i-2))
2947         else
2948           iti=nloctyp
2949         endif
2950 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2951         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2952           iti1 = itype2loc(itype(i-1))
2953         else
2954           iti1=nloctyp
2955         endif
2956 c        write(iout,*),i
2957         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2958      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2959      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2960         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2961      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2962      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2963 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2964 c     &*(cos(theta(i)/2.0)
2965         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2966      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2967      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2968 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2969 c     &*(cos(theta(i)/2.0)
2970         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2971      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2972      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2973 c        if (ggb1(1,i).eq.0.0d0) then
2974 c        write(iout,*) 'i=',i,ggb1(1,i),
2975 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2976 c     &bnew1(2,1,iti)*cos(theta(i)),
2977 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2978 c        endif
2979         b1(2,i-2)=bnew1(1,2,iti)
2980         gtb1(2,i-2)=0.0
2981         b2(2,i-2)=bnew2(1,2,iti)
2982         gtb2(2,i-2)=0.0
2983         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2984         EE(1,2,i-2)=eeold(1,2,iti)
2985         EE(2,1,i-2)=eeold(2,1,iti)
2986         EE(2,2,i-2)=eeold(2,2,iti)
2987         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2988         gtEE(1,2,i-2)=0.0d0
2989         gtEE(2,2,i-2)=0.0d0
2990         gtEE(2,1,i-2)=0.0d0
2991 c        EE(2,2,iti)=0.0d0
2992 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2993 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2994 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2995 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2996        b1tilde(1,i-2)=b1(1,i-2)
2997        b1tilde(2,i-2)=-b1(2,i-2)
2998        b2tilde(1,i-2)=b2(1,i-2)
2999        b2tilde(2,i-2)=-b2(2,i-2)
3000 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001 c       write(iout,*)  'b1=',b1(1,i-2)
3002 c       write (iout,*) 'theta=', theta(i-1)
3003        enddo
3004 #else
3005         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3006           iti = itype2loc(itype(i-2))
3007         else
3008           iti=nloctyp
3009         endif
3010 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3011         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3012           iti1 = itype2loc(itype(i-1))
3013         else
3014           iti1=nloctyp
3015         endif
3016         b1(1,i-2)=b(3,iti)
3017         b1(2,i-2)=b(5,iti)
3018         b2(1,i-2)=b(2,iti)
3019         b2(2,i-2)=b(4,iti)
3020        b1tilde(1,i-2)=b1(1,i-2)
3021        b1tilde(2,i-2)=-b1(2,i-2)
3022        b2tilde(1,i-2)=b2(1,i-2)
3023        b2tilde(2,i-2)=-b2(2,i-2)
3024         EE(1,2,i-2)=eeold(1,2,iti)
3025         EE(2,1,i-2)=eeold(2,1,iti)
3026         EE(2,2,i-2)=eeold(2,2,iti)
3027         EE(1,1,i-2)=eeold(1,1,iti)
3028       enddo
3029 #endif
3030 #ifdef PARMAT
3031       do i=ivec_start+2,ivec_end+2
3032 #else
3033       do i=3,nres+1
3034 #endif
3035         if (i .lt. nres+1) then
3036           sin1=dsin(phi(i))
3037           cos1=dcos(phi(i))
3038           sintab(i-2)=sin1
3039           costab(i-2)=cos1
3040           obrot(1,i-2)=cos1
3041           obrot(2,i-2)=sin1
3042           sin2=dsin(2*phi(i))
3043           cos2=dcos(2*phi(i))
3044           sintab2(i-2)=sin2
3045           costab2(i-2)=cos2
3046           obrot2(1,i-2)=cos2
3047           obrot2(2,i-2)=sin2
3048           Ug(1,1,i-2)=-cos1
3049           Ug(1,2,i-2)=-sin1
3050           Ug(2,1,i-2)=-sin1
3051           Ug(2,2,i-2)= cos1
3052           Ug2(1,1,i-2)=-cos2
3053           Ug2(1,2,i-2)=-sin2
3054           Ug2(2,1,i-2)=-sin2
3055           Ug2(2,2,i-2)= cos2
3056         else
3057           costab(i-2)=1.0d0
3058           sintab(i-2)=0.0d0
3059           obrot(1,i-2)=1.0d0
3060           obrot(2,i-2)=0.0d0
3061           obrot2(1,i-2)=0.0d0
3062           obrot2(2,i-2)=0.0d0
3063           Ug(1,1,i-2)=1.0d0
3064           Ug(1,2,i-2)=0.0d0
3065           Ug(2,1,i-2)=0.0d0
3066           Ug(2,2,i-2)=1.0d0
3067           Ug2(1,1,i-2)=0.0d0
3068           Ug2(1,2,i-2)=0.0d0
3069           Ug2(2,1,i-2)=0.0d0
3070           Ug2(2,2,i-2)=0.0d0
3071         endif
3072         if (i .gt. 3 .and. i .lt. nres+1) then
3073           obrot_der(1,i-2)=-sin1
3074           obrot_der(2,i-2)= cos1
3075           Ugder(1,1,i-2)= sin1
3076           Ugder(1,2,i-2)=-cos1
3077           Ugder(2,1,i-2)=-cos1
3078           Ugder(2,2,i-2)=-sin1
3079           dwacos2=cos2+cos2
3080           dwasin2=sin2+sin2
3081           obrot2_der(1,i-2)=-dwasin2
3082           obrot2_der(2,i-2)= dwacos2
3083           Ug2der(1,1,i-2)= dwasin2
3084           Ug2der(1,2,i-2)=-dwacos2
3085           Ug2der(2,1,i-2)=-dwacos2
3086           Ug2der(2,2,i-2)=-dwasin2
3087         else
3088           obrot_der(1,i-2)=0.0d0
3089           obrot_der(2,i-2)=0.0d0
3090           Ugder(1,1,i-2)=0.0d0
3091           Ugder(1,2,i-2)=0.0d0
3092           Ugder(2,1,i-2)=0.0d0
3093           Ugder(2,2,i-2)=0.0d0
3094           obrot2_der(1,i-2)=0.0d0
3095           obrot2_der(2,i-2)=0.0d0
3096           Ug2der(1,1,i-2)=0.0d0
3097           Ug2der(1,2,i-2)=0.0d0
3098           Ug2der(2,1,i-2)=0.0d0
3099           Ug2der(2,2,i-2)=0.0d0
3100         endif
3101 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3102         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103           iti = itype2loc(itype(i-2))
3104         else
3105           iti=nloctyp
3106         endif
3107 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3108         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3109           iti1 = itype2loc(itype(i-1))
3110         else
3111           iti1=nloctyp
3112         endif
3113 cd        write (iout,*) '*******i',i,' iti1',iti
3114 cd        write (iout,*) 'b1',b1(:,iti)
3115 cd        write (iout,*) 'b2',b2(:,iti)
3116 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3117 c        if (i .gt. iatel_s+2) then
3118         if (i .gt. nnt+2) then
3119           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3120 #ifdef NEWCORR
3121           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3122 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3123 #endif
3124 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3125 c     &    EE(1,2,iti),EE(2,2,i)
3126           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3127           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3128 c          write(iout,*) "Macierz EUG",
3129 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3130 c     &    eug(2,2,i-2)
3131           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3132      &    then
3133           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3134           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3135           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3136           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3137           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3138           endif
3139         else
3140           do k=1,2
3141             Ub2(k,i-2)=0.0d0
3142             Ctobr(k,i-2)=0.0d0
3143             Dtobr2(k,i-2)=0.0d0
3144             do l=1,2
3145               EUg(l,k,i-2)=0.0d0
3146               CUg(l,k,i-2)=0.0d0
3147               DUg(l,k,i-2)=0.0d0
3148               DtUg2(l,k,i-2)=0.0d0
3149             enddo
3150           enddo
3151         endif
3152         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3153         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3154         do k=1,2
3155           muder(k,i-2)=Ub2der(k,i-2)
3156         enddo
3157 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3158         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3159           if (itype(i-1).le.ntyp) then
3160             iti1 = itype2loc(itype(i-1))
3161           else
3162             iti1=nloctyp
3163           endif
3164         else
3165           iti1=nloctyp
3166         endif
3167         do k=1,2
3168           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3169         enddo
3170 #ifdef MUOUT
3171         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3172      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3173      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3174      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3175      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3176      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3177 #endif
3178 cd        write (iout,*) 'mu1',mu1(:,i-2)
3179 cd        write (iout,*) 'mu2',mu2(:,i-2)
3180         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3181      &  then
3182         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3183         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3184         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3185         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3186         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3187 C Vectors and matrices dependent on a single virtual-bond dihedral.
3188         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3189         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3190         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3191         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3192         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3193         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3194         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3195         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3196         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3197         endif
3198       enddo
3199 C Matrices dependent on two consecutive virtual-bond dihedrals.
3200 C The order of matrices is from left to right.
3201       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3202      &then
3203 c      do i=max0(ivec_start,2),ivec_end
3204       do i=2,nres-1
3205         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3206         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3207         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3208         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3209         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3210         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3211         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3212         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3213       enddo
3214       endif
3215 #if defined(MPI) && defined(PARMAT)
3216 #ifdef DEBUG
3217 c      if (fg_rank.eq.0) then
3218         write (iout,*) "Arrays UG and UGDER before GATHER"
3219         do i=1,nres-1
3220           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3221      &     ((ug(l,k,i),l=1,2),k=1,2),
3222      &     ((ugder(l,k,i),l=1,2),k=1,2)
3223         enddo
3224         write (iout,*) "Arrays UG2 and UG2DER"
3225         do i=1,nres-1
3226           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3227      &     ((ug2(l,k,i),l=1,2),k=1,2),
3228      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3229         enddo
3230         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3231         do i=1,nres-1
3232           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3233      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3234      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3235         enddo
3236         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3237         do i=1,nres-1
3238           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3239      &     costab(i),sintab(i),costab2(i),sintab2(i)
3240         enddo
3241         write (iout,*) "Array MUDER"
3242         do i=1,nres-1
3243           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3244         enddo
3245 c      endif
3246 #endif
3247       if (nfgtasks.gt.1) then
3248         time00=MPI_Wtime()
3249 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3250 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3251 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3252 #ifdef MATGATHER
3253         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3254      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3255      &   FG_COMM1,IERR)
3256         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3257      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3258      &   FG_COMM1,IERR)
3259         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3260      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3261      &   FG_COMM1,IERR)
3262         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3263      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3264      &   FG_COMM1,IERR)
3265         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3266      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3267      &   FG_COMM1,IERR)
3268         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3269      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3270      &   FG_COMM1,IERR)
3271         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3272      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3273      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3274         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3275      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3276      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3277         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3278      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3279      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3280         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3281      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3282      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3283         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3284      &  then
3285         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3292      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3293      &   FG_COMM1,IERR)
3294        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3295      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3296      &   FG_COMM1,IERR)
3297         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3298      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3299      &   FG_COMM1,IERR)
3300         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3301      &   ivec_count(fg_rank1),
3302      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3303      &   FG_COMM1,IERR)
3304         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3305      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3308      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3309      &   FG_COMM1,IERR)
3310         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3311      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3312      &   FG_COMM1,IERR)
3313         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3314      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3315      &   FG_COMM1,IERR)
3316         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3317      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3318      &   FG_COMM1,IERR)
3319         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3320      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3321      &   FG_COMM1,IERR)
3322         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3323      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3324      &   FG_COMM1,IERR)
3325         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3326      &   ivec_count(fg_rank1),
3327      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3331      &   FG_COMM1,IERR)
3332        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3337      &   FG_COMM1,IERR)
3338        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3342      &   ivec_count(fg_rank1),
3343      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3344      &   FG_COMM1,IERR)
3345         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3346      &   ivec_count(fg_rank1),
3347      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3348      &   FG_COMM1,IERR)
3349         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3350      &   ivec_count(fg_rank1),
3351      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3352      &   MPI_MAT2,FG_COMM1,IERR)
3353         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3354      &   ivec_count(fg_rank1),
3355      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3356      &   MPI_MAT2,FG_COMM1,IERR)
3357         endif
3358 #else
3359 c Passes matrix info through the ring
3360       isend=fg_rank1
3361       irecv=fg_rank1-1
3362       if (irecv.lt.0) irecv=nfgtasks1-1
3363       iprev=irecv
3364       inext=fg_rank1+1
3365       if (inext.ge.nfgtasks1) inext=0
3366       do i=1,nfgtasks1-1
3367 c        write (iout,*) "isend",isend," irecv",irecv
3368 c        call flush(iout)
3369         lensend=lentyp(isend)
3370         lenrecv=lentyp(irecv)
3371 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3372 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3373 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3374 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3375 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3376 c        write (iout,*) "Gather ROTAT1"
3377 c        call flush(iout)
3378 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3379 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3380 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3381 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3382 c        write (iout,*) "Gather ROTAT2"
3383 c        call flush(iout)
3384         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3385      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3386      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3387      &   iprev,4400+irecv,FG_COMM,status,IERR)
3388 c        write (iout,*) "Gather ROTAT_OLD"
3389 c        call flush(iout)
3390         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3391      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3392      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3393      &   iprev,5500+irecv,FG_COMM,status,IERR)
3394 c        write (iout,*) "Gather PRECOMP11"
3395 c        call flush(iout)
3396         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3397      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3398      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3399      &   iprev,6600+irecv,FG_COMM,status,IERR)
3400 c        write (iout,*) "Gather PRECOMP12"
3401 c        call flush(iout)
3402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3403      &  then
3404         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3405      &   MPI_ROTAT2(lensend),inext,7700+isend,
3406      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3407      &   iprev,7700+irecv,FG_COMM,status,IERR)
3408 c        write (iout,*) "Gather PRECOMP21"
3409 c        call flush(iout)
3410         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3411      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3412      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3413      &   iprev,8800+irecv,FG_COMM,status,IERR)
3414 c        write (iout,*) "Gather PRECOMP22"
3415 c        call flush(iout)
3416         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3417      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3418      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3419      &   MPI_PRECOMP23(lenrecv),
3420      &   iprev,9900+irecv,FG_COMM,status,IERR)
3421 c        write (iout,*) "Gather PRECOMP23"
3422 c        call flush(iout)
3423         endif
3424         isend=irecv
3425         irecv=irecv-1
3426         if (irecv.lt.0) irecv=nfgtasks1-1
3427       enddo
3428 #endif
3429         time_gather=time_gather+MPI_Wtime()-time00
3430       endif
3431 #ifdef DEBUG
3432 c      if (fg_rank.eq.0) then
3433         write (iout,*) "Arrays UG and UGDER"
3434         do i=1,nres-1
3435           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3436      &     ((ug(l,k,i),l=1,2),k=1,2),
3437      &     ((ugder(l,k,i),l=1,2),k=1,2)
3438         enddo
3439         write (iout,*) "Arrays UG2 and UG2DER"
3440         do i=1,nres-1
3441           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3442      &     ((ug2(l,k,i),l=1,2),k=1,2),
3443      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3444         enddo
3445         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3446         do i=1,nres-1
3447           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3448      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3449      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3450         enddo
3451         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3452         do i=1,nres-1
3453           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3454      &     costab(i),sintab(i),costab2(i),sintab2(i)
3455         enddo
3456         write (iout,*) "Array MUDER"
3457         do i=1,nres-1
3458           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3459         enddo
3460 c      endif
3461 #endif
3462 #endif
3463 cd      do i=1,nres
3464 cd        iti = itype2loc(itype(i))
3465 cd        write (iout,*) i
3466 cd        do j=1,2
3467 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3468 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3469 cd        enddo
3470 cd      enddo
3471       return
3472       end
3473 C--------------------------------------------------------------------------
3474       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3475 C
3476 C This subroutine calculates the average interaction energy and its gradient
3477 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3478 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3479 C The potential depends both on the distance of peptide-group centers and on
3480 C the orientation of the CA-CA virtual bonds.
3481 C
3482       implicit real*8 (a-h,o-z)
3483 #ifdef MPI
3484       include 'mpif.h'
3485 #endif
3486       include 'DIMENSIONS'
3487       include 'COMMON.CONTROL'
3488       include 'COMMON.SETUP'
3489       include 'COMMON.IOUNITS'
3490       include 'COMMON.GEO'
3491       include 'COMMON.VAR'
3492       include 'COMMON.LOCAL'
3493       include 'COMMON.CHAIN'
3494       include 'COMMON.DERIV'
3495       include 'COMMON.INTERACT'
3496       include 'COMMON.CONTACTS'
3497       include 'COMMON.TORSION'
3498       include 'COMMON.VECTORS'
3499       include 'COMMON.FFIELD'
3500       include 'COMMON.TIME1'
3501       include 'COMMON.SPLITELE'
3502       include 'COMMON.SHIELD'
3503       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3504      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3505       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3506      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3507       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3508      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3509      &    num_conti,j1,j2
3510 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3511 #ifdef MOMENT
3512       double precision scal_el /1.0d0/
3513 #else
3514       double precision scal_el /0.5d0/
3515 #endif
3516 C 12/13/98
3517 C 13-go grudnia roku pamietnego...
3518       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3519      &                   0.0d0,1.0d0,0.0d0,
3520      &                   0.0d0,0.0d0,1.0d0/
3521 cd      write(iout,*) 'In EELEC'
3522 cd      do i=1,nloctyp
3523 cd        write(iout,*) 'Type',i
3524 cd        write(iout,*) 'B1',B1(:,i)
3525 cd        write(iout,*) 'B2',B2(:,i)
3526 cd        write(iout,*) 'CC',CC(:,:,i)
3527 cd        write(iout,*) 'DD',DD(:,:,i)
3528 cd        write(iout,*) 'EE',EE(:,:,i)
3529 cd      enddo
3530 cd      call check_vecgrad
3531 cd      stop
3532       if (icheckgrad.eq.1) then
3533         do i=1,nres-1
3534           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3535           do k=1,3
3536             dc_norm(k,i)=dc(k,i)*fac
3537           enddo
3538 c          write (iout,*) 'i',i,' fac',fac
3539         enddo
3540       endif
3541       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3542      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3543      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3544 c        call vec_and_deriv
3545 #ifdef TIMING
3546         time01=MPI_Wtime()
3547 #endif
3548         call set_matrices
3549 #ifdef TIMING
3550         time_mat=time_mat+MPI_Wtime()-time01
3551 #endif
3552       endif
3553 cd      do i=1,nres-1
3554 cd        write (iout,*) 'i=',i
3555 cd        do k=1,3
3556 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3557 cd        enddo
3558 cd        do k=1,3
3559 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3560 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3561 cd        enddo
3562 cd      enddo
3563       t_eelecij=0.0d0
3564       ees=0.0D0
3565       evdw1=0.0D0
3566       eel_loc=0.0d0
3567       eello_turn3=0.0d0
3568       eello_turn4=0.0d0
3569       ind=0
3570       do i=1,nres
3571         num_cont_hb(i)=0
3572       enddo
3573 cd      print '(a)','Enter EELEC'
3574 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3575       do i=1,nres
3576         gel_loc_loc(i)=0.0d0
3577         gcorr_loc(i)=0.0d0
3578       enddo
3579 c
3580 c
3581 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3582 C
3583 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3584 C
3585 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3586       do i=iturn3_start,iturn3_end
3587 c        if (i.le.1) cycle
3588 C        write(iout,*) "tu jest i",i
3589         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3590 C changes suggested by Ana to avoid out of bounds
3591 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3592 c     & .or.((i+4).gt.nres)
3593 c     & .or.((i-1).le.0)
3594 C end of changes by Ana
3595      &  .or. itype(i+2).eq.ntyp1
3596      &  .or. itype(i+3).eq.ntyp1) cycle
3597 C Adam: Instructions below will switch off existing interactions
3598 c        if(i.gt.1)then
3599 c          if(itype(i-1).eq.ntyp1)cycle
3600 c        end if
3601 c        if(i.LT.nres-3)then
3602 c          if (itype(i+4).eq.ntyp1) cycle
3603 c        end if
3604         dxi=dc(1,i)
3605         dyi=dc(2,i)
3606         dzi=dc(3,i)
3607         dx_normi=dc_norm(1,i)
3608         dy_normi=dc_norm(2,i)
3609         dz_normi=dc_norm(3,i)
3610         xmedi=c(1,i)+0.5d0*dxi
3611         ymedi=c(2,i)+0.5d0*dyi
3612         zmedi=c(3,i)+0.5d0*dzi
3613           xmedi=mod(xmedi,boxxsize)
3614           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3615           ymedi=mod(ymedi,boxysize)
3616           if (ymedi.lt.0) ymedi=ymedi+boxysize
3617           zmedi=mod(zmedi,boxzsize)
3618           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3619           zmedi2=mod(zmedi,boxzsize)
3620           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3621        if ((zmedi2.gt.bordlipbot)
3622      &.and.(zmedi2.lt.bordliptop)) then
3623 C the energy transfer exist
3624         if (zmedi2.lt.buflipbot) then
3625 C what fraction I am in
3626          fracinbuf=1.0d0-
3627      &        ((zmedi2-bordlipbot)/lipbufthick)
3628 C lipbufthick is thickenes of lipid buffore
3629          sslipi=sscalelip(fracinbuf)
3630          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3631         elseif (zmedi2.gt.bufliptop) then
3632          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3633          sslipi=sscalelip(fracinbuf)
3634          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3635         else
3636          sslipi=1.0d0
3637          ssgradlipi=0.0d0
3638         endif
3639        else
3640          sslipi=0.0d0
3641          ssgradlipi=0.0d0
3642        endif
3643         num_conti=0
3644         call eelecij(i,i+2,ees,evdw1,eel_loc)
3645         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3646         num_cont_hb(i)=num_conti
3647       enddo
3648       do i=iturn4_start,iturn4_end
3649         if (i.lt.1) cycle
3650         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 c     & .or.((i+5).gt.nres)
3653 c     & .or.((i-1).le.0)
3654 C end of changes suggested by Ana
3655      &    .or. itype(i+3).eq.ntyp1
3656      &    .or. itype(i+4).eq.ntyp1
3657 c     &    .or. itype(i+5).eq.ntyp1
3658 c     &    .or. itype(i).eq.ntyp1
3659 c     &    .or. itype(i-1).eq.ntyp1
3660      &                             ) cycle
3661         dxi=dc(1,i)
3662         dyi=dc(2,i)
3663         dzi=dc(3,i)
3664         dx_normi=dc_norm(1,i)
3665         dy_normi=dc_norm(2,i)
3666         dz_normi=dc_norm(3,i)
3667         xmedi=c(1,i)+0.5d0*dxi
3668         ymedi=c(2,i)+0.5d0*dyi
3669         zmedi=c(3,i)+0.5d0*dzi
3670 C Return atom into box, boxxsize is size of box in x dimension
3671 c  194   continue
3672 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3673 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3674 C Condition for being inside the proper box
3675 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3676 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3677 c        go to 194
3678 c        endif
3679 c  195   continue
3680 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3681 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3682 C Condition for being inside the proper box
3683 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3684 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3685 c        go to 195
3686 c        endif
3687 c  196   continue
3688 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3689 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3690 C Condition for being inside the proper box
3691 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3692 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3693 c        go to 196
3694 c        endif
3695           xmedi=mod(xmedi,boxxsize)
3696           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3697           ymedi=mod(ymedi,boxysize)
3698           if (ymedi.lt.0) ymedi=ymedi+boxysize
3699           zmedi=mod(zmedi,boxzsize)
3700           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3701           zmedi2=mod(zmedi,boxzsize)
3702           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3703        if ((zmedi2.gt.bordlipbot)
3704      &.and.(zmedi2.lt.bordliptop)) then
3705 C the energy transfer exist
3706         if (zmedi2.lt.buflipbot) then
3707 C what fraction I am in
3708          fracinbuf=1.0d0-
3709      &        ((zmedi2-bordlipbot)/lipbufthick)
3710 C lipbufthick is thickenes of lipid buffore
3711          sslipi=sscalelip(fracinbuf)
3712          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3713         elseif (zmedi2.gt.bufliptop) then
3714          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3715          sslipi=sscalelip(fracinbuf)
3716          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3717         else
3718          sslipi=1.0d0
3719          ssgradlipi=0.0
3720         endif
3721        else
3722          sslipi=0.0d0
3723          ssgradlipi=0.0
3724        endif
3725         num_conti=num_cont_hb(i)
3726 c        write(iout,*) "JESTEM W PETLI"
3727         call eelecij(i,i+3,ees,evdw1,eel_loc)
3728         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3729      &   call eturn4(i,eello_turn4)
3730         num_cont_hb(i)=num_conti
3731       enddo   ! i
3732 C Loop over all neighbouring boxes
3733 C      do xshift=-1,1
3734 C      do yshift=-1,1
3735 C      do zshift=-1,1
3736 c
3737 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3738 c
3739 CTU KURWA
3740       do i=iatel_s,iatel_e
3741 C        do i=75,75
3742 c        if (i.le.1) cycle
3743         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3744 C changes suggested by Ana to avoid out of bounds
3745 c     & .or.((i+2).gt.nres)
3746 c     & .or.((i-1).le.0)
3747 C end of changes by Ana
3748 c     &  .or. itype(i+2).eq.ntyp1
3749 c     &  .or. itype(i-1).eq.ntyp1
3750      &                ) cycle
3751         dxi=dc(1,i)
3752         dyi=dc(2,i)
3753         dzi=dc(3,i)
3754         dx_normi=dc_norm(1,i)
3755         dy_normi=dc_norm(2,i)
3756         dz_normi=dc_norm(3,i)
3757         xmedi=c(1,i)+0.5d0*dxi
3758         ymedi=c(2,i)+0.5d0*dyi
3759         zmedi=c(3,i)+0.5d0*dzi
3760           xmedi=mod(xmedi,boxxsize)
3761           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3762           ymedi=mod(ymedi,boxysize)
3763           if (ymedi.lt.0) ymedi=ymedi+boxysize
3764           zmedi=mod(zmedi,boxzsize)
3765           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3766        if ((zmedi.gt.bordlipbot)
3767      &.and.(zmedi.lt.bordliptop)) then
3768 C the energy transfer exist
3769         if (zmedi.lt.buflipbot) then
3770 C what fraction I am in
3771          fracinbuf=1.0d0-
3772      &        ((zmedi-bordlipbot)/lipbufthick)
3773 C lipbufthick is thickenes of lipid buffore
3774          sslipi=sscalelip(fracinbuf)
3775          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3776         elseif (zmedi.gt.bufliptop) then
3777          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3778          sslipi=sscalelip(fracinbuf)
3779          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3780         else
3781          sslipi=1.0d0
3782          ssgradlipi=0.0
3783         endif
3784        else
3785          sslipi=0.0d0
3786          ssgradlipi=0.0
3787        endif
3788 C         print *,sslipi,"TU?!"
3789 C          xmedi=xmedi+xshift*boxxsize
3790 C          ymedi=ymedi+yshift*boxysize
3791 C          zmedi=zmedi+zshift*boxzsize
3792
3793 C Return tom into box, boxxsize is size of box in x dimension
3794 c  164   continue
3795 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3796 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3797 C Condition for being inside the proper box
3798 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3799 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3800 c        go to 164
3801 c        endif
3802 c  165   continue
3803 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3804 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3805 C Condition for being inside the proper box
3806 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3807 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3808 c        go to 165
3809 c        endif
3810 c  166   continue
3811 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3812 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3813 cC Condition for being inside the proper box
3814 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3815 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3816 c        go to 166
3817 c        endif
3818
3819 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3820         num_conti=num_cont_hb(i)
3821 C I TU KURWA
3822         do j=ielstart(i),ielend(i)
3823 C          do j=16,17
3824 C          write (iout,*) i,j
3825 C         if (j.le.1) cycle
3826           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3827 C changes suggested by Ana to avoid out of bounds
3828 c     & .or.((j+2).gt.nres)
3829 c     & .or.((j-1).le.0)
3830 C end of changes by Ana
3831 c     & .or.itype(j+2).eq.ntyp1
3832 c     & .or.itype(j-1).eq.ntyp1
3833      &) cycle
3834           call eelecij(i,j,ees,evdw1,eel_loc)
3835         enddo ! j
3836         num_cont_hb(i)=num_conti
3837       enddo   ! i
3838 C     enddo   ! zshift
3839 C      enddo   ! yshift
3840 C      enddo   ! xshift
3841
3842 c      write (iout,*) "Number of loop steps in EELEC:",ind
3843 cd      do i=1,nres
3844 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3845 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3846 cd      enddo
3847 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3848 ccc      eel_loc=eel_loc+eello_turn3
3849 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3850       return
3851       end
3852 C-------------------------------------------------------------------------------
3853       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3854       implicit real*8 (a-h,o-z)
3855       include 'DIMENSIONS'
3856 #ifdef MPI
3857       include "mpif.h"
3858 #endif
3859       include 'COMMON.CONTROL'
3860       include 'COMMON.IOUNITS'
3861       include 'COMMON.GEO'
3862       include 'COMMON.VAR'
3863       include 'COMMON.LOCAL'
3864       include 'COMMON.CHAIN'
3865       include 'COMMON.DERIV'
3866       include 'COMMON.INTERACT'
3867       include 'COMMON.CONTACTS'
3868       include 'COMMON.TORSION'
3869       include 'COMMON.VECTORS'
3870       include 'COMMON.FFIELD'
3871       include 'COMMON.TIME1'
3872       include 'COMMON.SPLITELE'
3873       include 'COMMON.SHIELD'
3874       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3875      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3876       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3877      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3878      &    gmuij2(4),gmuji2(4)
3879       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3880      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3881      &    num_conti,j1,j2
3882 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3883 #ifdef MOMENT
3884       double precision scal_el /1.0d0/
3885 #else
3886       double precision scal_el /0.5d0/
3887 #endif
3888 C 12/13/98
3889 C 13-go grudnia roku pamietnego...
3890       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3891      &                   0.0d0,1.0d0,0.0d0,
3892      &                   0.0d0,0.0d0,1.0d0/
3893        integer xshift,yshift,zshift
3894 c          time00=MPI_Wtime()
3895 cd      write (iout,*) "eelecij",i,j
3896 c          ind=ind+1
3897           iteli=itel(i)
3898           itelj=itel(j)
3899           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3900           aaa=app(iteli,itelj)
3901           bbb=bpp(iteli,itelj)
3902           ael6i=ael6(iteli,itelj)
3903           ael3i=ael3(iteli,itelj)
3904           dxj=dc(1,j)
3905           dyj=dc(2,j)
3906           dzj=dc(3,j)
3907           dx_normj=dc_norm(1,j)
3908           dy_normj=dc_norm(2,j)
3909           dz_normj=dc_norm(3,j)
3910 C          xj=c(1,j)+0.5D0*dxj-xmedi
3911 C          yj=c(2,j)+0.5D0*dyj-ymedi
3912 C          zj=c(3,j)+0.5D0*dzj-zmedi
3913           xj=c(1,j)+0.5D0*dxj
3914           yj=c(2,j)+0.5D0*dyj
3915           zj=c(3,j)+0.5D0*dzj
3916           xj=mod(xj,boxxsize)
3917           if (xj.lt.0) xj=xj+boxxsize
3918           yj=mod(yj,boxysize)
3919           if (yj.lt.0) yj=yj+boxysize
3920           zj=mod(zj,boxzsize)
3921           if (zj.lt.0) zj=zj+boxzsize
3922           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3923        if ((zj.gt.bordlipbot)
3924      &.and.(zj.lt.bordliptop)) then
3925 C the energy transfer exist
3926         if (zj.lt.buflipbot) then
3927 C what fraction I am in
3928          fracinbuf=1.0d0-
3929      &        ((zj-bordlipbot)/lipbufthick)
3930 C lipbufthick is thickenes of lipid buffore
3931          sslipj=sscalelip(fracinbuf)
3932          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3933         elseif (zj.gt.bufliptop) then
3934          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3935          sslipj=sscalelip(fracinbuf)
3936          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3937         else
3938          sslipj=1.0d0
3939          ssgradlipj=0.0
3940         endif
3941        else
3942          sslipj=0.0d0
3943          ssgradlipj=0.0
3944        endif
3945       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3946       xj_safe=xj
3947       yj_safe=yj
3948       zj_safe=zj
3949       isubchap=0
3950       do xshift=-1,1
3951       do yshift=-1,1
3952       do zshift=-1,1
3953           xj=xj_safe+xshift*boxxsize
3954           yj=yj_safe+yshift*boxysize
3955           zj=zj_safe+zshift*boxzsize
3956           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3957           if(dist_temp.lt.dist_init) then
3958             dist_init=dist_temp
3959             xj_temp=xj
3960             yj_temp=yj
3961             zj_temp=zj
3962             isubchap=1
3963           endif
3964        enddo
3965        enddo
3966        enddo
3967        if (isubchap.eq.1) then
3968           xj=xj_temp-xmedi
3969           yj=yj_temp-ymedi
3970           zj=zj_temp-zmedi
3971        else
3972           xj=xj_safe-xmedi
3973           yj=yj_safe-ymedi
3974           zj=zj_safe-zmedi
3975        endif
3976 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3977 c  174   continue
3978 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3979 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3980 C Condition for being inside the proper box
3981 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3982 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3983 c        go to 174
3984 c        endif
3985 c  175   continue
3986 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3987 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3988 C Condition for being inside the proper box
3989 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3990 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3991 c        go to 175
3992 c        endif
3993 c  176   continue
3994 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3995 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3996 C Condition for being inside the proper box
3997 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3998 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3999 c        go to 176
4000 c        endif
4001 C        endif !endPBC condintion
4002 C        xj=xj-xmedi
4003 C        yj=yj-ymedi
4004 C        zj=zj-zmedi
4005           rij=xj*xj+yj*yj+zj*zj
4006
4007             sss=sscale(sqrt(rij))
4008             sssgrad=sscagrad(sqrt(rij))
4009 c            if (sss.gt.0.0d0) then
4010           rrmij=1.0D0/rij
4011           rij=dsqrt(rij)
4012           rmij=1.0D0/rij
4013           r3ij=rrmij*rmij
4014           r6ij=r3ij*r3ij
4015           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4016           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4017           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4018           fac=cosa-3.0D0*cosb*cosg
4019           ev1=aaa*r6ij*r6ij
4020 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4021           if (j.eq.i+2) ev1=scal_el*ev1
4022           ev2=bbb*r6ij
4023           fac3=ael6i*r6ij
4024           fac4=ael3i*r3ij
4025           evdwij=(ev1+ev2)
4026           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4027           el2=fac4*fac
4028 C MARYSIA
4029 C          eesij=(el1+el2)
4030 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4031           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4032           if (shield_mode.gt.0) then
4033 C          fac_shield(i)=0.4
4034 C          fac_shield(j)=0.6
4035           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4036           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4037           eesij=(el1+el2)
4038           ees=ees+eesij
4039 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
4040 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4041           else
4042           fac_shield(i)=1.0
4043           fac_shield(j)=1.0
4044           eesij=(el1+el2)
4045           ees=ees+eesij
4046      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4047 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4048           endif
4049           evdw1=evdw1+evdwij*sss
4050      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4051 C          print *,sslipi,sslipj,lipscale**2,
4052 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4053 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4054 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4055 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4056 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4057
4058           if (energy_dec) then
4059               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4060      &'evdw1',i,j,evdwij
4061      &,iteli,itelj,aaa,evdw1
4062               write (iout,*) sss
4063               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4064      &fac_shield(i),fac_shield(j)
4065           endif
4066
4067 C
4068 C Calculate contributions to the Cartesian gradient.
4069 C
4070 #ifdef SPLITELE
4071           facvdw=-6*rrmij*(ev1+evdwij)*sss
4072      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4073           facel=-3*rrmij*(el1+eesij)
4074      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4075           fac1=fac
4076           erij(1)=xj*rmij
4077           erij(2)=yj*rmij
4078           erij(3)=zj*rmij
4079
4080 *
4081 * Radial derivatives. First process both termini of the fragment (i,j)
4082 *
4083           ggg(1)=facel*xj
4084           ggg(2)=facel*yj
4085           ggg(3)=facel*zj
4086           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4087      &  (shield_mode.gt.0)) then
4088 C          print *,i,j
4089           do ilist=1,ishield_list(i)
4090            iresshield=shield_list(ilist,i)
4091            do k=1,3
4092            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4093      &      *2.0
4094            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4095      &              rlocshield
4096      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4097             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4098 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4099 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4100 C             if (iresshield.gt.i) then
4101 C               do ishi=i+1,iresshield-1
4102 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4103 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4104 C
4105 C              enddo
4106 C             else
4107 C               do ishi=iresshield,i
4108 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4109 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4110 C
4111 C               enddo
4112 C              endif
4113            enddo
4114           enddo
4115           do ilist=1,ishield_list(j)
4116            iresshield=shield_list(ilist,j)
4117            do k=1,3
4118            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4119      &     *2.0
4120            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4121      &              rlocshield
4122      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4123            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4124
4125 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4126 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4127 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4128 C             if (iresshield.gt.j) then
4129 C               do ishi=j+1,iresshield-1
4130 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4131 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4132 C
4133 C               enddo
4134 C            else
4135 C               do ishi=iresshield,j
4136 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4137 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4138 C               enddo
4139 C              endif
4140            enddo
4141           enddo
4142
4143           do k=1,3
4144             gshieldc(k,i)=gshieldc(k,i)+
4145      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4146             gshieldc(k,j)=gshieldc(k,j)+
4147      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4148             gshieldc(k,i-1)=gshieldc(k,i-1)+
4149      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4150             gshieldc(k,j-1)=gshieldc(k,j-1)+
4151      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4152
4153            enddo
4154            endif
4155 c          do k=1,3
4156 c            ghalf=0.5D0*ggg(k)
4157 c            gelc(k,i)=gelc(k,i)+ghalf
4158 c            gelc(k,j)=gelc(k,j)+ghalf
4159 c          enddo
4160 c 9/28/08 AL Gradient compotents will be summed only at the end
4161 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4162           do k=1,3
4163             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4164 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4165             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4166 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4167 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4168 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4169 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4170 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4171           enddo
4172 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4173 C Lipidic part for lipscale
4174             gelc_long(3,j)=gelc_long(3,j)+
4175      &     ssgradlipj*eesij/2.0d0*lipscale**2
4176
4177             gelc_long(3,i)=gelc_long(3,i)+
4178      &     ssgradlipi*eesij/2.0d0*lipscale**2
4179
4180 *
4181 * Loop over residues i+1 thru j-1.
4182 *
4183 cgrad          do k=i+1,j-1
4184 cgrad            do l=1,3
4185 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4186 cgrad            enddo
4187 cgrad          enddo
4188           if (sss.gt.0.0) then
4189           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4190      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4191
4192           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4193      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4194
4195           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4196      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4197           else
4198           ggg(1)=0.0
4199           ggg(2)=0.0
4200           ggg(3)=0.0
4201           endif
4202 c          do k=1,3
4203 c            ghalf=0.5D0*ggg(k)
4204 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4205 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4206 c          enddo
4207 c 9/28/08 AL Gradient compotents will be summed only at the end
4208           do k=1,3
4209             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4210             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4211           enddo
4212 C Lipidic part for scaling weight
4213            gvdwpp(3,j)=gvdwpp(3,j)+
4214      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4215            gvdwpp(3,i)=gvdwpp(3,i)+
4216      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4217
4218 *
4219 * Loop over residues i+1 thru j-1.
4220 *
4221 cgrad          do k=i+1,j-1
4222 cgrad            do l=1,3
4223 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226 #else
4227 C MARYSIA
4228           facvdw=(ev1+evdwij)*sss
4229      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4230           facel=(el1+eesij)
4231           fac1=fac
4232           fac=-3*rrmij*(facvdw+facvdw+facel)
4233           erij(1)=xj*rmij
4234           erij(2)=yj*rmij
4235           erij(3)=zj*rmij
4236 *
4237 * Radial derivatives. First process both termini of the fragment (i,j)
4238 *
4239           ggg(1)=fac*xj
4240 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4241           ggg(2)=fac*yj
4242 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4243           ggg(3)=fac*zj
4244 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4245 c          do k=1,3
4246 c            ghalf=0.5D0*ggg(k)
4247 c            gelc(k,i)=gelc(k,i)+ghalf
4248 c            gelc(k,j)=gelc(k,j)+ghalf
4249 c          enddo
4250 c 9/28/08 AL Gradient compotents will be summed only at the end
4251           do k=1,3
4252             gelc_long(k,j)=gelc(k,j)+ggg(k)
4253             gelc_long(k,i)=gelc(k,i)-ggg(k)
4254           enddo
4255 *
4256 * Loop over residues i+1 thru j-1.
4257 *
4258 cgrad          do k=i+1,j-1
4259 cgrad            do l=1,3
4260 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4261 cgrad            enddo
4262 cgrad          enddo
4263 c 9/28/08 AL Gradient compotents will be summed only at the end
4264           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4265      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4266
4267           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4268      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4269
4270           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4271      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4272           do k=1,3
4273             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4274             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4275           enddo
4276            gvdwpp(3,j)=gvdwpp(3,j)+
4277      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4278            gvdwpp(3,i)=gvdwpp(3,i)+
4279      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4280
4281 #endif
4282 *
4283 * Angular part
4284 *
4285           ecosa=2.0D0*fac3*fac1+fac4
4286           fac4=-3.0D0*fac4
4287           fac3=-6.0D0*fac3
4288           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4289           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4290           do k=1,3
4291             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4292             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4293           enddo
4294 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4295 cd   &          (dcosg(k),k=1,3)
4296           do k=1,3
4297             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4298      &      fac_shield(i)**2*fac_shield(j)**2
4299      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4300           enddo
4301 c          do k=1,3
4302 c            ghalf=0.5D0*ggg(k)
4303 c            gelc(k,i)=gelc(k,i)+ghalf
4304 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4305 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4306 c            gelc(k,j)=gelc(k,j)+ghalf
4307 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4308 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4309 c          enddo
4310 cgrad          do k=i+1,j-1
4311 cgrad            do l=1,3
4312 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4313 cgrad            enddo
4314 cgrad          enddo
4315 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4316           do k=1,3
4317             gelc(k,i)=gelc(k,i)
4318      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4319      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4320      &           *fac_shield(i)**2*fac_shield(j)**2
4321      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4322             gelc(k,j)=gelc(k,j)
4323      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4324      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4325      &           *fac_shield(i)**2*fac_shield(j)**2
4326      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4327             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4328             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4329           enddo
4330 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4331
4332 C MARYSIA
4333 c          endif !sscale
4334           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4335      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4336      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4337 C
4338 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4339 C   energy of a peptide unit is assumed in the form of a second-order
4340 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4341 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4342 C   are computed for EVERY pair of non-contiguous peptide groups.
4343 C
4344
4345           if (j.lt.nres-1) then
4346             j1=j+1
4347             j2=j-1
4348           else
4349             j1=j-1
4350             j2=j-2
4351           endif
4352           kkk=0
4353           lll=0
4354           do k=1,2
4355             do l=1,2
4356               kkk=kkk+1
4357               muij(kkk)=mu(k,i)*mu(l,j)
4358 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4359 #ifdef NEWCORR
4360              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4361 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4362              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4363              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4364 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4365              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4366 #endif
4367             enddo
4368           enddo
4369 cd         write (iout,*) 'EELEC: i',i,' j',j
4370 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4371 cd          write(iout,*) 'muij',muij
4372           ury=scalar(uy(1,i),erij)
4373           urz=scalar(uz(1,i),erij)
4374           vry=scalar(uy(1,j),erij)
4375           vrz=scalar(uz(1,j),erij)
4376           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4377           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4378           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4379           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4380           fac=dsqrt(-ael6i)*r3ij
4381           a22=a22*fac
4382           a23=a23*fac
4383           a32=a32*fac
4384           a33=a33*fac
4385 cd          write (iout,'(4i5,4f10.5)')
4386 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4387 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4388 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4389 cd     &      uy(:,j),uz(:,j)
4390 cd          write (iout,'(4f10.5)')
4391 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4392 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4393 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4394 cd           write (iout,'(9f10.5/)')
4395 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4396 C Derivatives of the elements of A in virtual-bond vectors
4397           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4398           do k=1,3
4399             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4400             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4401             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4402             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4403             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4404             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4405             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4406             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4407             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4408             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4409             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4410             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4411           enddo
4412 C Compute radial contributions to the gradient
4413           facr=-3.0d0*rrmij
4414           a22der=a22*facr
4415           a23der=a23*facr
4416           a32der=a32*facr
4417           a33der=a33*facr
4418           agg(1,1)=a22der*xj
4419           agg(2,1)=a22der*yj
4420           agg(3,1)=a22der*zj
4421           agg(1,2)=a23der*xj
4422           agg(2,2)=a23der*yj
4423           agg(3,2)=a23der*zj
4424           agg(1,3)=a32der*xj
4425           agg(2,3)=a32der*yj
4426           agg(3,3)=a32der*zj
4427           agg(1,4)=a33der*xj
4428           agg(2,4)=a33der*yj
4429           agg(3,4)=a33der*zj
4430 C Add the contributions coming from er
4431           fac3=-3.0d0*fac
4432           do k=1,3
4433             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4434             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4435             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4436             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4437           enddo
4438           do k=1,3
4439 C Derivatives in DC(i)
4440 cgrad            ghalf1=0.5d0*agg(k,1)
4441 cgrad            ghalf2=0.5d0*agg(k,2)
4442 cgrad            ghalf3=0.5d0*agg(k,3)
4443 cgrad            ghalf4=0.5d0*agg(k,4)
4444             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4445      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4446             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4447      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4448             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4449      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4450             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4451      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4452 C Derivatives in DC(i+1)
4453             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4454      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4455             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4456      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4457             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4458      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4459             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4460      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4461 C Derivatives in DC(j)
4462             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4463      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4464             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4465      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4466             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4467      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4468             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4469      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4470 C Derivatives in DC(j+1) or DC(nres-1)
4471             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4472      &      -3.0d0*vryg(k,3)*ury)
4473             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4474      &      -3.0d0*vrzg(k,3)*ury)
4475             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4476      &      -3.0d0*vryg(k,3)*urz)
4477             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4478      &      -3.0d0*vrzg(k,3)*urz)
4479 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4480 cgrad              do l=1,4
4481 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4482 cgrad              enddo
4483 cgrad            endif
4484           enddo
4485           acipa(1,1)=a22
4486           acipa(1,2)=a23
4487           acipa(2,1)=a32
4488           acipa(2,2)=a33
4489           a22=-a22
4490           a23=-a23
4491           do l=1,2
4492             do k=1,3
4493               agg(k,l)=-agg(k,l)
4494               aggi(k,l)=-aggi(k,l)
4495               aggi1(k,l)=-aggi1(k,l)
4496               aggj(k,l)=-aggj(k,l)
4497               aggj1(k,l)=-aggj1(k,l)
4498             enddo
4499           enddo
4500           if (j.lt.nres-1) then
4501             a22=-a22
4502             a32=-a32
4503             do l=1,3,2
4504               do k=1,3
4505                 agg(k,l)=-agg(k,l)
4506                 aggi(k,l)=-aggi(k,l)
4507                 aggi1(k,l)=-aggi1(k,l)
4508                 aggj(k,l)=-aggj(k,l)
4509                 aggj1(k,l)=-aggj1(k,l)
4510               enddo
4511             enddo
4512           else
4513             a22=-a22
4514             a23=-a23
4515             a32=-a32
4516             a33=-a33
4517             do l=1,4
4518               do k=1,3
4519                 agg(k,l)=-agg(k,l)
4520                 aggi(k,l)=-aggi(k,l)
4521                 aggi1(k,l)=-aggi1(k,l)
4522                 aggj(k,l)=-aggj(k,l)
4523                 aggj1(k,l)=-aggj1(k,l)
4524               enddo
4525             enddo
4526           endif
4527           ENDIF ! WCORR
4528           IF (wel_loc.gt.0.0d0) THEN
4529 C Contribution to the local-electrostatic energy coming from the i-j pair
4530           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4531      &     +a33*muij(4)
4532           if (shield_mode.eq.0) then
4533            fac_shield(i)=1.0
4534            fac_shield(j)=1.0
4535 C          else
4536 C           fac_shield(i)=0.4
4537 C           fac_shield(j)=0.6
4538           endif
4539           eel_loc_ij=eel_loc_ij
4540      &    *fac_shield(i)*fac_shield(j)
4541      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4542
4543 C Now derivative over eel_loc
4544           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4545      &  (shield_mode.gt.0)) then
4546 C          print *,i,j
4547
4548           do ilist=1,ishield_list(i)
4549            iresshield=shield_list(ilist,i)
4550            do k=1,3
4551            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4552      &                                          /fac_shield(i)
4553 C     &      *2.0
4554            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4555      &              rlocshield
4556      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4557             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4558      &      +rlocshield
4559            enddo
4560           enddo
4561           do ilist=1,ishield_list(j)
4562            iresshield=shield_list(ilist,j)
4563            do k=1,3
4564            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4565      &                                       /fac_shield(j)
4566 C     &     *2.0
4567            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4568      &              rlocshield
4569      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4570            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4571      &             +rlocshield
4572
4573            enddo
4574           enddo
4575
4576           do k=1,3
4577             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4578      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4579             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4580      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4581             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4582      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4583             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4584      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4585            enddo
4586            endif
4587
4588
4589 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4590 c     &                     ' eel_loc_ij',eel_loc_ij
4591 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4592 C Calculate patrial derivative for theta angle
4593 #ifdef NEWCORR
4594          geel_loc_ij=(a22*gmuij1(1)
4595      &     +a23*gmuij1(2)
4596      &     +a32*gmuij1(3)
4597      &     +a33*gmuij1(4))
4598      &    *fac_shield(i)*fac_shield(j)
4599      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4600
4601 c         write(iout,*) "derivative over thatai"
4602 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4603 c     &   a33*gmuij1(4)
4604          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4605      &      geel_loc_ij*wel_loc
4606 c         write(iout,*) "derivative over thatai-1"
4607 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4608 c     &   a33*gmuij2(4)
4609          geel_loc_ij=
4610      &     a22*gmuij2(1)
4611      &     +a23*gmuij2(2)
4612      &     +a32*gmuij2(3)
4613      &     +a33*gmuij2(4)
4614          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4615      &      geel_loc_ij*wel_loc
4616      &    *fac_shield(i)*fac_shield(j)
4617      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4618
4619
4620 c  Derivative over j residue
4621          geel_loc_ji=a22*gmuji1(1)
4622      &     +a23*gmuji1(2)
4623      &     +a32*gmuji1(3)
4624      &     +a33*gmuji1(4)
4625 c         write(iout,*) "derivative over thataj"
4626 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4627 c     &   a33*gmuji1(4)
4628
4629         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4630      &      geel_loc_ji*wel_loc
4631      &    *fac_shield(i)*fac_shield(j)
4632      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4633
4634          geel_loc_ji=
4635      &     +a22*gmuji2(1)
4636      &     +a23*gmuji2(2)
4637      &     +a32*gmuji2(3)
4638      &     +a33*gmuji2(4)
4639 c         write(iout,*) "derivative over thataj-1"
4640 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4641 c     &   a33*gmuji2(4)
4642          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4643      &      geel_loc_ji*wel_loc
4644      &    *fac_shield(i)*fac_shield(j)
4645      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4646
4647 #endif
4648 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4649
4650           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4651      &            'eelloc',i,j,eel_loc_ij
4652 c           if (eel_loc_ij.ne.0)
4653 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4654 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4655
4656           eel_loc=eel_loc+eel_loc_ij
4657 C Partial derivatives in virtual-bond dihedral angles gamma
4658           if (i.gt.1)
4659      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4660      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4661      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4662      &    *fac_shield(i)*fac_shield(j)
4663      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4664
4665           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4666      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4667      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4668      &    *fac_shield(i)*fac_shield(j)
4669      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4670
4671 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4672           do l=1,3
4673             ggg(l)=(agg(l,1)*muij(1)+
4674      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4675      &    *fac_shield(i)*fac_shield(j)
4676      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4677
4678             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4679             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4680 cgrad            ghalf=0.5d0*ggg(l)
4681 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4682 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4683           enddo
4684             gel_loc_long(3,j)=gel_loc_long(3,j)+
4685      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4686      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4687
4688             gel_loc_long(3,i)=gel_loc_long(3,i)+
4689      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4690      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4691
4692 cgrad          do k=i+1,j2
4693 cgrad            do l=1,3
4694 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4695 cgrad            enddo
4696 cgrad          enddo
4697 C Remaining derivatives of eello
4698           do l=1,3
4699             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4700      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4701      &    *fac_shield(i)*fac_shield(j)
4702      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4703
4704             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4705      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4706      &    *fac_shield(i)*fac_shield(j)
4707      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4708
4709             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4710      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4711      &    *fac_shield(i)*fac_shield(j)
4712      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4713
4714             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4715      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4716      &    *fac_shield(i)*fac_shield(j)
4717      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4718
4719           enddo
4720           ENDIF
4721 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4722 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4723           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4724      &       .and. num_conti.le.maxconts) then
4725 c            write (iout,*) i,j," entered corr"
4726 C
4727 C Calculate the contact function. The ith column of the array JCONT will
4728 C contain the numbers of atoms that make contacts with the atom I (of numbers
4729 C greater than I). The arrays FACONT and GACONT will contain the values of
4730 C the contact function and its derivative.
4731 c           r0ij=1.02D0*rpp(iteli,itelj)
4732 c           r0ij=1.11D0*rpp(iteli,itelj)
4733             r0ij=2.20D0*rpp(iteli,itelj)
4734 c           r0ij=1.55D0*rpp(iteli,itelj)
4735             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4736             if (fcont.gt.0.0D0) then
4737               num_conti=num_conti+1
4738               if (num_conti.gt.maxconts) then
4739                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4740      &                         ' will skip next contacts for this conf.'
4741               else
4742                 jcont_hb(num_conti,i)=j
4743 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4744 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4745                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4746      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4747 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4748 C  terms.
4749                 d_cont(num_conti,i)=rij
4750 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4751 C     --- Electrostatic-interaction matrix ---
4752                 a_chuj(1,1,num_conti,i)=a22
4753                 a_chuj(1,2,num_conti,i)=a23
4754                 a_chuj(2,1,num_conti,i)=a32
4755                 a_chuj(2,2,num_conti,i)=a33
4756 C     --- Gradient of rij
4757                 do kkk=1,3
4758                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4759                 enddo
4760                 kkll=0
4761                 do k=1,2
4762                   do l=1,2
4763                     kkll=kkll+1
4764                     do m=1,3
4765                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4766                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4767                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4768                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4769                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4770                     enddo
4771                   enddo
4772                 enddo
4773                 ENDIF
4774                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4775 C Calculate contact energies
4776                 cosa4=4.0D0*cosa
4777                 wij=cosa-3.0D0*cosb*cosg
4778                 cosbg1=cosb+cosg
4779                 cosbg2=cosb-cosg
4780 c               fac3=dsqrt(-ael6i)/r0ij**3
4781                 fac3=dsqrt(-ael6i)*r3ij
4782 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4783                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4784                 if (ees0tmp.gt.0) then
4785                   ees0pij=dsqrt(ees0tmp)
4786                 else
4787                   ees0pij=0
4788                 endif
4789 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4790                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4791                 if (ees0tmp.gt.0) then
4792                   ees0mij=dsqrt(ees0tmp)
4793                 else
4794                   ees0mij=0
4795                 endif
4796 c               ees0mij=0.0D0
4797                 if (shield_mode.eq.0) then
4798                 fac_shield(i)=1.0d0
4799                 fac_shield(j)=1.0d0
4800                 else
4801                 ees0plist(num_conti,i)=j
4802 C                fac_shield(i)=0.4d0
4803 C                fac_shield(j)=0.6d0
4804                 endif
4805                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4806      &          *fac_shield(i)*fac_shield(j)
4807                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4808      &          *fac_shield(i)*fac_shield(j)
4809 C Diagnostics. Comment out or remove after debugging!
4810 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4811 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4812 c               ees0m(num_conti,i)=0.0D0
4813 C End diagnostics.
4814 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4815 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4816 C Angular derivatives of the contact function
4817                 ees0pij1=fac3/ees0pij
4818                 ees0mij1=fac3/ees0mij
4819                 fac3p=-3.0D0*fac3*rrmij
4820                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4821                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4822 c               ees0mij1=0.0D0
4823                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4824                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4825                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4826                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4827                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4828                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4829                 ecosap=ecosa1+ecosa2
4830                 ecosbp=ecosb1+ecosb2
4831                 ecosgp=ecosg1+ecosg2
4832                 ecosam=ecosa1-ecosa2
4833                 ecosbm=ecosb1-ecosb2
4834                 ecosgm=ecosg1-ecosg2
4835 C Diagnostics
4836 c               ecosap=ecosa1
4837 c               ecosbp=ecosb1
4838 c               ecosgp=ecosg1
4839 c               ecosam=0.0D0
4840 c               ecosbm=0.0D0
4841 c               ecosgm=0.0D0
4842 C End diagnostics
4843                 facont_hb(num_conti,i)=fcont
4844                 fprimcont=fprimcont/rij
4845 cd              facont_hb(num_conti,i)=1.0D0
4846 C Following line is for diagnostics.
4847 cd              fprimcont=0.0D0
4848                 do k=1,3
4849                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4850                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4851                 enddo
4852                 do k=1,3
4853                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4854                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4855                 enddo
4856                 gggp(1)=gggp(1)+ees0pijp*xj
4857                 gggp(2)=gggp(2)+ees0pijp*yj
4858                 gggp(3)=gggp(3)+ees0pijp*zj
4859                 gggm(1)=gggm(1)+ees0mijp*xj
4860                 gggm(2)=gggm(2)+ees0mijp*yj
4861                 gggm(3)=gggm(3)+ees0mijp*zj
4862 C Derivatives due to the contact function
4863                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4864                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4865                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4866                 do k=1,3
4867 c
4868 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4869 c          following the change of gradient-summation algorithm.
4870 c
4871 cgrad                  ghalfp=0.5D0*gggp(k)
4872 cgrad                  ghalfm=0.5D0*gggm(k)
4873                   gacontp_hb1(k,num_conti,i)=!ghalfp
4874      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4875      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4876      &          *fac_shield(i)*fac_shield(j)
4877
4878                   gacontp_hb2(k,num_conti,i)=!ghalfp
4879      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4880      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4881      &          *fac_shield(i)*fac_shield(j)
4882
4883                   gacontp_hb3(k,num_conti,i)=gggp(k)
4884      &          *fac_shield(i)*fac_shield(j)
4885
4886                   gacontm_hb1(k,num_conti,i)=!ghalfm
4887      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4888      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4889      &          *fac_shield(i)*fac_shield(j)
4890
4891                   gacontm_hb2(k,num_conti,i)=!ghalfm
4892      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4893      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4894      &          *fac_shield(i)*fac_shield(j)
4895
4896                   gacontm_hb3(k,num_conti,i)=gggm(k)
4897      &          *fac_shield(i)*fac_shield(j)
4898
4899                 enddo
4900 C Diagnostics. Comment out or remove after debugging!
4901 cdiag           do k=1,3
4902 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4903 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4904 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4905 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4906 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4907 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4908 cdiag           enddo
4909               ENDIF ! wcorr
4910               endif  ! num_conti.le.maxconts
4911             endif  ! fcont.gt.0
4912           endif    ! j.gt.i+1
4913           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4914             do k=1,4
4915               do l=1,3
4916                 ghalf=0.5d0*agg(l,k)
4917                 aggi(l,k)=aggi(l,k)+ghalf
4918                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4919                 aggj(l,k)=aggj(l,k)+ghalf
4920               enddo
4921             enddo
4922             if (j.eq.nres-1 .and. i.lt.j-2) then
4923               do k=1,4
4924                 do l=1,3
4925                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4926                 enddo
4927               enddo
4928             endif
4929           endif
4930 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4931       return
4932       end
4933 C-----------------------------------------------------------------------------
4934       subroutine eturn3(i,eello_turn3)
4935 C Third- and fourth-order contributions from turns
4936       implicit real*8 (a-h,o-z)
4937       include 'DIMENSIONS'
4938       include 'COMMON.IOUNITS'
4939       include 'COMMON.GEO'
4940       include 'COMMON.VAR'
4941       include 'COMMON.LOCAL'
4942       include 'COMMON.CHAIN'
4943       include 'COMMON.DERIV'
4944       include 'COMMON.INTERACT'
4945       include 'COMMON.CONTACTS'
4946       include 'COMMON.TORSION'
4947       include 'COMMON.VECTORS'
4948       include 'COMMON.FFIELD'
4949       include 'COMMON.CONTROL'
4950       include 'COMMON.SHIELD'
4951       dimension ggg(3)
4952       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4953      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4954      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4955      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4956      &  auxgmat2(2,2),auxgmatt2(2,2)
4957       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4958      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4959       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4960      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4961      &    num_conti,j1,j2
4962       j=i+2
4963 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4964 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4965           zj=(c(3,j)+c(3,j+1))/2.0d0
4966 C          xj=mod(xj,boxxsize)
4967 C          if (xj.lt.0) xj=xj+boxxsize
4968 C          yj=mod(yj,boxysize)
4969 C          if (yj.lt.0) yj=yj+boxysize
4970           zj=mod(zj,boxzsize)
4971           if (zj.lt.0) zj=zj+boxzsize
4972           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4973        if ((zj.gt.bordlipbot)
4974      &.and.(zj.lt.bordliptop)) then
4975 C the energy transfer exist
4976         if (zj.lt.buflipbot) then
4977 C what fraction I am in
4978          fracinbuf=1.0d0-
4979      &        ((zj-bordlipbot)/lipbufthick)
4980 C lipbufthick is thickenes of lipid buffore
4981          sslipj=sscalelip(fracinbuf)
4982          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4983         elseif (zj.gt.bufliptop) then
4984          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4985          sslipj=sscalelip(fracinbuf)
4986          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4987         else
4988          sslipj=1.0d0
4989          ssgradlipj=0.0
4990         endif
4991        else
4992          sslipj=0.0d0
4993          ssgradlipj=0.0
4994        endif
4995 C      sslipj=0.0
4996 C      ssgradlipj=0.0d0
4997
4998 C      write (iout,*) "eturn3",i,j,j1,j2
4999       a_temp(1,1)=a22
5000       a_temp(1,2)=a23
5001       a_temp(2,1)=a32
5002       a_temp(2,2)=a33
5003 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5004 C
5005 C               Third-order contributions
5006 C
5007 C                 (i+2)o----(i+3)
5008 C                      | |
5009 C                      | |
5010 C                 (i+1)o----i
5011 C
5012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5013 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5014         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5015 c auxalary matices for theta gradient
5016 c auxalary matrix for i+1 and constant i+2
5017         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5018 c auxalary matrix for i+2 and constant i+1
5019         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5020         call transpose2(auxmat(1,1),auxmat1(1,1))
5021         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5022         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5023         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5024         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5025         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5026         if (shield_mode.eq.0) then
5027         fac_shield(i)=1.0d0
5028         fac_shield(j)=1.0d0
5029 C        else
5030 C        fac_shield(i)=0.4
5031 C        fac_shield(j)=0.6
5032         endif
5033 C         if (j.eq.78)
5034 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
5035         eello_turn3=eello_turn3+
5036 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5037      &0.5d0*(pizda(1,1)+pizda(2,2))
5038      &  *fac_shield(i)*fac_shield(j)
5039      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5040         eello_t3=
5041      &0.5d0*(pizda(1,1)+pizda(2,2))
5042      &  *fac_shield(i)*fac_shield(j)
5043 #ifdef NEWCORR
5044 C Derivatives in theta
5045         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5046      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5047      &   *fac_shield(i)*fac_shield(j)
5048      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5049
5050         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5051      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5052      &   *fac_shield(i)*fac_shield(j)
5053      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5054
5055 #endif
5056
5057 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5058 C Derivatives in shield mode
5059           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5060      &  (shield_mode.gt.0)) then
5061 C          print *,i,j
5062
5063           do ilist=1,ishield_list(i)
5064            iresshield=shield_list(ilist,i)
5065            do k=1,3
5066            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5067 C     &      *2.0
5068            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5069      &              rlocshield
5070      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5071             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5072      &      +rlocshield
5073            enddo
5074           enddo
5075           do ilist=1,ishield_list(j)
5076            iresshield=shield_list(ilist,j)
5077            do k=1,3
5078            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5079 C     &     *2.0
5080            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5081      &              rlocshield
5082      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5083            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5084      &             +rlocshield
5085
5086            enddo
5087           enddo
5088
5089           do k=1,3
5090             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5091      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5092             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5093      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5094             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5095      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5096             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5097      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5098            enddo
5099            endif
5100
5101 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5102 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5103 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5104 cd     &    ' eello_turn3_num',4*eello_turn3_num
5105 C Derivatives in gamma(i)
5106         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5107         call transpose2(auxmat2(1,1),auxmat3(1,1))
5108         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5109         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5110      &   *fac_shield(i)*fac_shield(j)
5111      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5112
5113 C Derivatives in gamma(i+1)
5114         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5115         call transpose2(auxmat2(1,1),auxmat3(1,1))
5116         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5117         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5118      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5119      &   *fac_shield(i)*fac_shield(j)
5120      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5121
5122 C Cartesian derivatives
5123         do l=1,3
5124 c            ghalf1=0.5d0*agg(l,1)
5125 c            ghalf2=0.5d0*agg(l,2)
5126 c            ghalf3=0.5d0*agg(l,3)
5127 c            ghalf4=0.5d0*agg(l,4)
5128           a_temp(1,1)=aggi(l,1)!+ghalf1
5129           a_temp(1,2)=aggi(l,2)!+ghalf2
5130           a_temp(2,1)=aggi(l,3)!+ghalf3
5131           a_temp(2,2)=aggi(l,4)!+ghalf4
5132           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5133           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5134      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5135      &   *fac_shield(i)*fac_shield(j)
5136      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5137
5138           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5139           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5140           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5141           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5142           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5143           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5144      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5145      &   *fac_shield(i)*fac_shield(j)
5146      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5147           a_temp(1,1)=aggj(l,1)!+ghalf1
5148           a_temp(1,2)=aggj(l,2)!+ghalf2
5149           a_temp(2,1)=aggj(l,3)!+ghalf3
5150           a_temp(2,2)=aggj(l,4)!+ghalf4
5151           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5152           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5153      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5154      &   *fac_shield(i)*fac_shield(j)
5155      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5156
5157           a_temp(1,1)=aggj1(l,1)
5158           a_temp(1,2)=aggj1(l,2)
5159           a_temp(2,1)=aggj1(l,3)
5160           a_temp(2,2)=aggj1(l,4)
5161           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5162           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5163      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5164      &   *fac_shield(i)*fac_shield(j)
5165      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5166         enddo
5167          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5168      &     ssgradlipi*eello_t3/4.0d0*lipscale
5169          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5170      &     ssgradlipj*eello_t3/4.0d0*lipscale
5171          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5172      &     ssgradlipi*eello_t3/4.0d0*lipscale
5173          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5174      &     ssgradlipj*eello_t3/4.0d0*lipscale
5175
5176 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5177       return
5178       end
5179 C-------------------------------------------------------------------------------
5180       subroutine eturn4(i,eello_turn4)
5181 C Third- and fourth-order contributions from turns
5182       implicit real*8 (a-h,o-z)
5183       include 'DIMENSIONS'
5184       include 'COMMON.IOUNITS'
5185       include 'COMMON.GEO'
5186       include 'COMMON.VAR'
5187       include 'COMMON.LOCAL'
5188       include 'COMMON.CHAIN'
5189       include 'COMMON.DERIV'
5190       include 'COMMON.INTERACT'
5191       include 'COMMON.CONTACTS'
5192       include 'COMMON.TORSION'
5193       include 'COMMON.VECTORS'
5194       include 'COMMON.FFIELD'
5195       include 'COMMON.CONTROL'
5196       include 'COMMON.SHIELD'
5197       dimension ggg(3)
5198       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5199      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5200      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5201      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5202      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5203      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5204      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5205       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5206      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5207       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5208      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5209      &    num_conti,j1,j2
5210       j=i+3
5211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5212 C
5213 C               Fourth-order contributions
5214 C
5215 C                 (i+3)o----(i+4)
5216 C                     /  |
5217 C               (i+2)o   |
5218 C                     \  |
5219 C                 (i+1)o----i
5220 C
5221 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5222 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5223 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5224 c        write(iout,*)"WCHODZE W PROGRAM"
5225           zj=(c(3,j)+c(3,j+1))/2.0d0
5226 C          xj=mod(xj,boxxsize)
5227 C          if (xj.lt.0) xj=xj+boxxsize
5228 C          yj=mod(yj,boxysize)
5229 C          if (yj.lt.0) yj=yj+boxysize
5230           zj=mod(zj,boxzsize)
5231           if (zj.lt.0) zj=zj+boxzsize
5232 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5233        if ((zj.gt.bordlipbot)
5234      &.and.(zj.lt.bordliptop)) then
5235 C the energy transfer exist
5236         if (zj.lt.buflipbot) then
5237 C what fraction I am in
5238          fracinbuf=1.0d0-
5239      &        ((zj-bordlipbot)/lipbufthick)
5240 C lipbufthick is thickenes of lipid buffore
5241          sslipj=sscalelip(fracinbuf)
5242          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5243         elseif (zj.gt.bufliptop) then
5244          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5245          sslipj=sscalelip(fracinbuf)
5246          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5247         else
5248          sslipj=1.0d0
5249          ssgradlipj=0.0
5250         endif
5251        else
5252          sslipj=0.0d0
5253          ssgradlipj=0.0
5254        endif
5255
5256         a_temp(1,1)=a22
5257         a_temp(1,2)=a23
5258         a_temp(2,1)=a32
5259         a_temp(2,2)=a33
5260         iti1=itype2loc(itype(i+1))
5261         iti2=itype2loc(itype(i+2))
5262         iti3=itype2loc(itype(i+3))
5263 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5264         call transpose2(EUg(1,1,i+1),e1t(1,1))
5265         call transpose2(Eug(1,1,i+2),e2t(1,1))
5266         call transpose2(Eug(1,1,i+3),e3t(1,1))
5267 C Ematrix derivative in theta
5268         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5269         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5270         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5271         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5272 c       eta1 in derivative theta
5273         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5274         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5275 c       auxgvec is derivative of Ub2 so i+3 theta
5276         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5277 c       auxalary matrix of E i+1
5278         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5279 c        s1=0.0
5280 c        gs1=0.0
5281         s1=scalar2(b1(1,i+2),auxvec(1))
5282 c derivative of theta i+2 with constant i+3
5283         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5284 c derivative of theta i+2 with constant i+2
5285         gs32=scalar2(b1(1,i+2),auxgvec(1))
5286 c derivative of E matix in theta of i+1
5287         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5288
5289         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5290 c       ea31 in derivative theta
5291         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5292         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5293 c auxilary matrix auxgvec of Ub2 with constant E matirx
5294         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5295 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5296         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5297
5298 c        s2=0.0
5299 c        gs2=0.0
5300         s2=scalar2(b1(1,i+1),auxvec(1))
5301 c derivative of theta i+1 with constant i+3
5302         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5303 c derivative of theta i+2 with constant i+1
5304         gs21=scalar2(b1(1,i+1),auxgvec(1))
5305 c derivative of theta i+3 with constant i+1
5306         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5307 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5308 c     &  gtb1(1,i+1)
5309         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5310 c two derivatives over diffetent matrices
5311 c gtae3e2 is derivative over i+3
5312         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5313 c ae3gte2 is derivative over i+2
5314         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5315         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5316 c three possible derivative over theta E matices
5317 c i+1
5318         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5319 c i+2
5320         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5321 c i+3
5322         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5323         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5324
5325         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5326         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5327         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5328         if (shield_mode.eq.0) then
5329         fac_shield(i)=1.0
5330         fac_shield(j)=1.0
5331 C        else
5332 C        fac_shield(i)=0.6
5333 C        fac_shield(j)=0.4
5334         endif
5335         eello_turn4=eello_turn4-(s1+s2+s3)
5336      &  *fac_shield(i)*fac_shield(j)
5337      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5338
5339         eello_t4=-(s1+s2+s3)
5340      &  *fac_shield(i)*fac_shield(j)
5341 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5342         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5343      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5344 C Now derivative over shield:
5345           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5346      &  (shield_mode.gt.0)) then
5347 C          print *,i,j
5348
5349           do ilist=1,ishield_list(i)
5350            iresshield=shield_list(ilist,i)
5351            do k=1,3
5352            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5353 C     &      *2.0
5354            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5355      &              rlocshield
5356      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5357             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5358      &      +rlocshield
5359            enddo
5360           enddo
5361           do ilist=1,ishield_list(j)
5362            iresshield=shield_list(ilist,j)
5363            do k=1,3
5364            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5365 C     &     *2.0
5366            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5367      &              rlocshield
5368      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5369            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5370      &             +rlocshield
5371
5372            enddo
5373           enddo
5374
5375           do k=1,3
5376             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5377      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5378             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5379      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5380             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5381      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5382             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5383      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5384            enddo
5385            endif
5386
5387
5388
5389
5390
5391
5392 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5393 cd     &    ' eello_turn4_num',8*eello_turn4_num
5394 #ifdef NEWCORR
5395         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5396      &                  -(gs13+gsE13+gsEE1)*wturn4
5397      &  *fac_shield(i)*fac_shield(j)
5398      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5399
5400         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5401      &                    -(gs23+gs21+gsEE2)*wturn4
5402      &  *fac_shield(i)*fac_shield(j)
5403      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5404
5405         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5406      &                    -(gs32+gsE31+gsEE3)*wturn4
5407      &  *fac_shield(i)*fac_shield(j)
5408      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5409
5410 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5411 c     &   gs2
5412 #endif
5413         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5414      &      'eturn4',i,j,-(s1+s2+s3)
5415 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5416 c     &    ' eello_turn4_num',8*eello_turn4_num
5417 C Derivatives in gamma(i)
5418         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5419         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5420         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5421         s1=scalar2(b1(1,i+2),auxvec(1))
5422         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5423         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5424         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5425      &  *fac_shield(i)*fac_shield(j)
5426      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5427
5428 C Derivatives in gamma(i+1)
5429         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5430         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5431         s2=scalar2(b1(1,i+1),auxvec(1))
5432         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5433         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5434         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5436      &  *fac_shield(i)*fac_shield(j)
5437      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5438
5439 C Derivatives in gamma(i+2)
5440         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5441         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5442         s1=scalar2(b1(1,i+2),auxvec(1))
5443         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5444         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5445         s2=scalar2(b1(1,i+1),auxvec(1))
5446         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5447         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5448         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5449         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5450      &  *fac_shield(i)*fac_shield(j)
5451      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5452
5453 C Cartesian derivatives
5454 C Derivatives of this turn contributions in DC(i+2)
5455         if (j.lt.nres-1) then
5456           do l=1,3
5457             a_temp(1,1)=agg(l,1)
5458             a_temp(1,2)=agg(l,2)
5459             a_temp(2,1)=agg(l,3)
5460             a_temp(2,2)=agg(l,4)
5461             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5462             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5463             s1=scalar2(b1(1,i+2),auxvec(1))
5464             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5465             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5466             s2=scalar2(b1(1,i+1),auxvec(1))
5467             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5468             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5469             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5470             ggg(l)=-(s1+s2+s3)
5471             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5472      &  *fac_shield(i)*fac_shield(j)
5473      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5474
5475           enddo
5476         endif
5477 C Remaining derivatives of this turn contribution
5478         do l=1,3
5479           a_temp(1,1)=aggi(l,1)
5480           a_temp(1,2)=aggi(l,2)
5481           a_temp(2,1)=aggi(l,3)
5482           a_temp(2,2)=aggi(l,4)
5483           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5484           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5485           s1=scalar2(b1(1,i+2),auxvec(1))
5486           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5487           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5488           s2=scalar2(b1(1,i+1),auxvec(1))
5489           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5490           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5491           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5492           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5493      &  *fac_shield(i)*fac_shield(j)
5494      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5495
5496           a_temp(1,1)=aggi1(l,1)
5497           a_temp(1,2)=aggi1(l,2)
5498           a_temp(2,1)=aggi1(l,3)
5499           a_temp(2,2)=aggi1(l,4)
5500           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5501           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5502           s1=scalar2(b1(1,i+2),auxvec(1))
5503           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5504           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5505           s2=scalar2(b1(1,i+1),auxvec(1))
5506           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5507           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5508           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5509           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5510      &  *fac_shield(i)*fac_shield(j)
5511      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5512
5513           a_temp(1,1)=aggj(l,1)
5514           a_temp(1,2)=aggj(l,2)
5515           a_temp(2,1)=aggj(l,3)
5516           a_temp(2,2)=aggj(l,4)
5517           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5518           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5519           s1=scalar2(b1(1,i+2),auxvec(1))
5520           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5521           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5522           s2=scalar2(b1(1,i+1),auxvec(1))
5523           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5524           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5525           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5526           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5527      &  *fac_shield(i)*fac_shield(j)
5528      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5529
5530           a_temp(1,1)=aggj1(l,1)
5531           a_temp(1,2)=aggj1(l,2)
5532           a_temp(2,1)=aggj1(l,3)
5533           a_temp(2,2)=aggj1(l,4)
5534           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5535           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5536           s1=scalar2(b1(1,i+2),auxvec(1))
5537           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5538           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5539           s2=scalar2(b1(1,i+1),auxvec(1))
5540           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5541           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5542           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5543 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5544           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5545      &  *fac_shield(i)*fac_shield(j)
5546      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5547         enddo
5548          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5549      &     ssgradlipi*eello_t4/4.0d0*lipscale
5550          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5551      &     ssgradlipj*eello_t4/4.0d0*lipscale
5552          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5553      &     ssgradlipi*eello_t4/4.0d0*lipscale
5554          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5555      &     ssgradlipj*eello_t4/4.0d0*lipscale
5556       return
5557       end
5558 C-----------------------------------------------------------------------------
5559       subroutine vecpr(u,v,w)
5560       implicit real*8(a-h,o-z)
5561       dimension u(3),v(3),w(3)
5562       w(1)=u(2)*v(3)-u(3)*v(2)
5563       w(2)=-u(1)*v(3)+u(3)*v(1)
5564       w(3)=u(1)*v(2)-u(2)*v(1)
5565       return
5566       end
5567 C-----------------------------------------------------------------------------
5568       subroutine unormderiv(u,ugrad,unorm,ungrad)
5569 C This subroutine computes the derivatives of a normalized vector u, given
5570 C the derivatives computed without normalization conditions, ugrad. Returns
5571 C ungrad.
5572       implicit none
5573       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5574       double precision vec(3)
5575       double precision scalar
5576       integer i,j
5577 c      write (2,*) 'ugrad',ugrad
5578 c      write (2,*) 'u',u
5579       do i=1,3
5580         vec(i)=scalar(ugrad(1,i),u(1))
5581       enddo
5582 c      write (2,*) 'vec',vec
5583       do i=1,3
5584         do j=1,3
5585           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5586         enddo
5587       enddo
5588 c      write (2,*) 'ungrad',ungrad
5589       return
5590       end
5591 C-----------------------------------------------------------------------------
5592       subroutine escp_soft_sphere(evdw2,evdw2_14)
5593 C
5594 C This subroutine calculates the excluded-volume interaction energy between
5595 C peptide-group centers and side chains and its gradient in virtual-bond and
5596 C side-chain vectors.
5597 C
5598       implicit real*8 (a-h,o-z)
5599       include 'DIMENSIONS'
5600       include 'COMMON.GEO'
5601       include 'COMMON.VAR'
5602       include 'COMMON.LOCAL'
5603       include 'COMMON.CHAIN'
5604       include 'COMMON.DERIV'
5605       include 'COMMON.INTERACT'
5606       include 'COMMON.FFIELD'
5607       include 'COMMON.IOUNITS'
5608       include 'COMMON.CONTROL'
5609       dimension ggg(3)
5610       evdw2=0.0D0
5611       evdw2_14=0.0d0
5612       r0_scp=4.5d0
5613 cd    print '(a)','Enter ESCP'
5614 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5615 C      do xshift=-1,1
5616 C      do yshift=-1,1
5617 C      do zshift=-1,1
5618       do i=iatscp_s,iatscp_e
5619         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5620         iteli=itel(i)
5621         xi=0.5D0*(c(1,i)+c(1,i+1))
5622         yi=0.5D0*(c(2,i)+c(2,i+1))
5623         zi=0.5D0*(c(3,i)+c(3,i+1))
5624 C Return atom into box, boxxsize is size of box in x dimension
5625 c  134   continue
5626 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5627 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5628 C Condition for being inside the proper box
5629 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5630 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5631 c        go to 134
5632 c        endif
5633 c  135   continue
5634 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5635 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5636 C Condition for being inside the proper box
5637 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5638 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5639 c        go to 135
5640 c c       endif
5641 c  136   continue
5642 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5643 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5644 cC Condition for being inside the proper box
5645 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5646 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5647 c        go to 136
5648 c        endif
5649           xi=mod(xi,boxxsize)
5650           if (xi.lt.0) xi=xi+boxxsize
5651           yi=mod(yi,boxysize)
5652           if (yi.lt.0) yi=yi+boxysize
5653           zi=mod(zi,boxzsize)
5654           if (zi.lt.0) zi=zi+boxzsize
5655 C          xi=xi+xshift*boxxsize
5656 C          yi=yi+yshift*boxysize
5657 C          zi=zi+zshift*boxzsize
5658         do iint=1,nscp_gr(i)
5659
5660         do j=iscpstart(i,iint),iscpend(i,iint)
5661           if (itype(j).eq.ntyp1) cycle
5662           itypj=iabs(itype(j))
5663 C Uncomment following three lines for SC-p interactions
5664 c         xj=c(1,nres+j)-xi
5665 c         yj=c(2,nres+j)-yi
5666 c         zj=c(3,nres+j)-zi
5667 C Uncomment following three lines for Ca-p interactions
5668           xj=c(1,j)
5669           yj=c(2,j)
5670           zj=c(3,j)
5671 c  174   continue
5672 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5673 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5674 C Condition for being inside the proper box
5675 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5676 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5677 c        go to 174
5678 c        endif
5679 c  175   continue
5680 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5681 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5682 cC Condition for being inside the proper box
5683 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5684 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5685 c        go to 175
5686 c        endif
5687 c  176   continue
5688 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5689 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5690 C Condition for being inside the proper box
5691 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5692 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5693 c        go to 176
5694           xj=mod(xj,boxxsize)
5695           if (xj.lt.0) xj=xj+boxxsize
5696           yj=mod(yj,boxysize)
5697           if (yj.lt.0) yj=yj+boxysize
5698           zj=mod(zj,boxzsize)
5699           if (zj.lt.0) zj=zj+boxzsize
5700       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5701       xj_safe=xj
5702       yj_safe=yj
5703       zj_safe=zj
5704       subchap=0
5705       do xshift=-1,1
5706       do yshift=-1,1
5707       do zshift=-1,1
5708           xj=xj_safe+xshift*boxxsize
5709           yj=yj_safe+yshift*boxysize
5710           zj=zj_safe+zshift*boxzsize
5711           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5712           if(dist_temp.lt.dist_init) then
5713             dist_init=dist_temp
5714             xj_temp=xj
5715             yj_temp=yj
5716             zj_temp=zj
5717             subchap=1
5718           endif
5719        enddo
5720        enddo
5721        enddo
5722        if (subchap.eq.1) then
5723           xj=xj_temp-xi
5724           yj=yj_temp-yi
5725           zj=zj_temp-zi
5726        else
5727           xj=xj_safe-xi
5728           yj=yj_safe-yi
5729           zj=zj_safe-zi
5730        endif
5731 c c       endif
5732 C          xj=xj-xi
5733 C          yj=yj-yi
5734 C          zj=zj-zi
5735           rij=xj*xj+yj*yj+zj*zj
5736
5737           r0ij=r0_scp
5738           r0ijsq=r0ij*r0ij
5739           if (rij.lt.r0ijsq) then
5740             evdwij=0.25d0*(rij-r0ijsq)**2
5741             fac=rij-r0ijsq
5742           else
5743             evdwij=0.0d0
5744             fac=0.0d0
5745           endif
5746           evdw2=evdw2+evdwij
5747 C
5748 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5749 C
5750           ggg(1)=xj*fac
5751           ggg(2)=yj*fac
5752           ggg(3)=zj*fac
5753 cgrad          if (j.lt.i) then
5754 cd          write (iout,*) 'j<i'
5755 C Uncomment following three lines for SC-p interactions
5756 c           do k=1,3
5757 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5758 c           enddo
5759 cgrad          else
5760 cd          write (iout,*) 'j>i'
5761 cgrad            do k=1,3
5762 cgrad              ggg(k)=-ggg(k)
5763 C Uncomment following line for SC-p interactions
5764 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5765 cgrad            enddo
5766 cgrad          endif
5767 cgrad          do k=1,3
5768 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5769 cgrad          enddo
5770 cgrad          kstart=min0(i+1,j)
5771 cgrad          kend=max0(i-1,j-1)
5772 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5773 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5774 cgrad          do k=kstart,kend
5775 cgrad            do l=1,3
5776 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5777 cgrad            enddo
5778 cgrad          enddo
5779           do k=1,3
5780             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5781             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5782           enddo
5783         enddo
5784
5785         enddo ! iint
5786       enddo ! i
5787 C      enddo !zshift
5788 C      enddo !yshift
5789 C      enddo !xshift
5790       return
5791       end
5792 C-----------------------------------------------------------------------------
5793       subroutine escp(evdw2,evdw2_14)
5794 C
5795 C This subroutine calculates the excluded-volume interaction energy between
5796 C peptide-group centers and side chains and its gradient in virtual-bond and
5797 C side-chain vectors.
5798 C
5799       implicit real*8 (a-h,o-z)
5800       include 'DIMENSIONS'
5801       include 'COMMON.GEO'
5802       include 'COMMON.VAR'
5803       include 'COMMON.LOCAL'
5804       include 'COMMON.CHAIN'
5805       include 'COMMON.DERIV'
5806       include 'COMMON.INTERACT'
5807       include 'COMMON.FFIELD'
5808       include 'COMMON.IOUNITS'
5809       include 'COMMON.CONTROL'
5810       include 'COMMON.SPLITELE'
5811       dimension ggg(3)
5812       evdw2=0.0D0
5813       evdw2_14=0.0d0
5814 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5815 cd    print '(a)','Enter ESCP'
5816 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5817 C      do xshift=-1,1
5818 C      do yshift=-1,1
5819 C      do zshift=-1,1
5820       do i=iatscp_s,iatscp_e
5821         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5822         iteli=itel(i)
5823         xi=0.5D0*(c(1,i)+c(1,i+1))
5824         yi=0.5D0*(c(2,i)+c(2,i+1))
5825         zi=0.5D0*(c(3,i)+c(3,i+1))
5826           xi=mod(xi,boxxsize)
5827           if (xi.lt.0) xi=xi+boxxsize
5828           yi=mod(yi,boxysize)
5829           if (yi.lt.0) yi=yi+boxysize
5830           zi=mod(zi,boxzsize)
5831           if (zi.lt.0) zi=zi+boxzsize
5832 c          xi=xi+xshift*boxxsize
5833 c          yi=yi+yshift*boxysize
5834 c          zi=zi+zshift*boxzsize
5835 c        print *,xi,yi,zi,'polozenie i'
5836 C Return atom into box, boxxsize is size of box in x dimension
5837 c  134   continue
5838 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5839 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5840 C Condition for being inside the proper box
5841 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5842 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5843 c        go to 134
5844 c        endif
5845 c  135   continue
5846 c          print *,xi,boxxsize,"pierwszy"
5847
5848 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5849 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5850 C Condition for being inside the proper box
5851 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5852 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5853 c        go to 135
5854 c        endif
5855 c  136   continue
5856 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5857 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5858 C Condition for being inside the proper box
5859 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5860 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5861 c        go to 136
5862 c        endif
5863         do iint=1,nscp_gr(i)
5864
5865         do j=iscpstart(i,iint),iscpend(i,iint)
5866           itypj=iabs(itype(j))
5867           if (itypj.eq.ntyp1) cycle
5868 C Uncomment following three lines for SC-p interactions
5869 c         xj=c(1,nres+j)-xi
5870 c         yj=c(2,nres+j)-yi
5871 c         zj=c(3,nres+j)-zi
5872 C Uncomment following three lines for Ca-p interactions
5873           xj=c(1,j)
5874           yj=c(2,j)
5875           zj=c(3,j)
5876           xj=mod(xj,boxxsize)
5877           if (xj.lt.0) xj=xj+boxxsize
5878           yj=mod(yj,boxysize)
5879           if (yj.lt.0) yj=yj+boxysize
5880           zj=mod(zj,boxzsize)
5881           if (zj.lt.0) zj=zj+boxzsize
5882 c  174   continue
5883 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5884 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5885 C Condition for being inside the proper box
5886 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5887 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5888 c        go to 174
5889 c        endif
5890 c  175   continue
5891 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5892 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5893 cC Condition for being inside the proper box
5894 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5895 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5896 c        go to 175
5897 c        endif
5898 c  176   continue
5899 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5900 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5901 C Condition for being inside the proper box
5902 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5903 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5904 c        go to 176
5905 c        endif
5906 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5907       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5908       xj_safe=xj
5909       yj_safe=yj
5910       zj_safe=zj
5911       subchap=0
5912       do xshift=-1,1
5913       do yshift=-1,1
5914       do zshift=-1,1
5915           xj=xj_safe+xshift*boxxsize
5916           yj=yj_safe+yshift*boxysize
5917           zj=zj_safe+zshift*boxzsize
5918           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5919           if(dist_temp.lt.dist_init) then
5920             dist_init=dist_temp
5921             xj_temp=xj
5922             yj_temp=yj
5923             zj_temp=zj
5924             subchap=1
5925           endif
5926        enddo
5927        enddo
5928        enddo
5929        if (subchap.eq.1) then
5930           xj=xj_temp-xi
5931           yj=yj_temp-yi
5932           zj=zj_temp-zi
5933        else
5934           xj=xj_safe-xi
5935           yj=yj_safe-yi
5936           zj=zj_safe-zi
5937        endif
5938 c          print *,xj,yj,zj,'polozenie j'
5939           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5940 c          print *,rrij
5941           sss=sscale(1.0d0/(dsqrt(rrij)))
5942 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5943 c          if (sss.eq.0) print *,'czasem jest OK'
5944           if (sss.le.0.0d0) cycle
5945           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5946           fac=rrij**expon2
5947           e1=fac*fac*aad(itypj,iteli)
5948           e2=fac*bad(itypj,iteli)
5949           if (iabs(j-i) .le. 2) then
5950             e1=scal14*e1
5951             e2=scal14*e2
5952             evdw2_14=evdw2_14+(e1+e2)*sss
5953           endif
5954           evdwij=e1+e2
5955           evdw2=evdw2+evdwij*sss
5956           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5957      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5958      &       bad(itypj,iteli)
5959 C
5960 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5961 C
5962           fac=-(evdwij+e1)*rrij*sss
5963           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5964           ggg(1)=xj*fac
5965           ggg(2)=yj*fac
5966           ggg(3)=zj*fac
5967 cgrad          if (j.lt.i) then
5968 cd          write (iout,*) 'j<i'
5969 C Uncomment following three lines for SC-p interactions
5970 c           do k=1,3
5971 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5972 c           enddo
5973 cgrad          else
5974 cd          write (iout,*) 'j>i'
5975 cgrad            do k=1,3
5976 cgrad              ggg(k)=-ggg(k)
5977 C Uncomment following line for SC-p interactions
5978 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5979 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5980 cgrad            enddo
5981 cgrad          endif
5982 cgrad          do k=1,3
5983 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5984 cgrad          enddo
5985 cgrad          kstart=min0(i+1,j)
5986 cgrad          kend=max0(i-1,j-1)
5987 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5988 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5989 cgrad          do k=kstart,kend
5990 cgrad            do l=1,3
5991 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5992 cgrad            enddo
5993 cgrad          enddo
5994           do k=1,3
5995             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5996             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5997           enddo
5998 c        endif !endif for sscale cutoff
5999         enddo ! j
6000
6001         enddo ! iint
6002       enddo ! i
6003 c      enddo !zshift
6004 c      enddo !yshift
6005 c      enddo !xshift
6006       do i=1,nct
6007         do j=1,3
6008           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
6009           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
6010           gradx_scp(j,i)=expon*gradx_scp(j,i)
6011         enddo
6012       enddo
6013 C******************************************************************************
6014 C
6015 C                              N O T E !!!
6016 C
6017 C To save time the factor EXPON has been extracted from ALL components
6018 C of GVDWC and GRADX. Remember to multiply them by this factor before further
6019 C use!
6020 C
6021 C******************************************************************************
6022       return
6023       end
6024 C--------------------------------------------------------------------------
6025       subroutine edis(ehpb)
6026 C
6027 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6028 C
6029       implicit real*8 (a-h,o-z)
6030       include 'DIMENSIONS'
6031       include 'COMMON.SBRIDGE'
6032       include 'COMMON.CHAIN'
6033       include 'COMMON.DERIV'
6034       include 'COMMON.VAR'
6035       include 'COMMON.INTERACT'
6036       include 'COMMON.IOUNITS'
6037       include 'COMMON.CONTROL'
6038       dimension ggg(3)
6039       ehpb=0.0D0
6040       do i=1,3
6041        ggg(i)=0.0d0
6042       enddo
6043 C      write (iout,*) ,"link_end",link_end,constr_dist
6044 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6045 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
6046       if (link_end.eq.0) return
6047       do i=link_start,link_end
6048 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6049 C CA-CA distance used in regularization of structure.
6050         ii=ihpb(i)
6051         jj=jhpb(i)
6052 C iii and jjj point to the residues for which the distance is assigned.
6053         if (ii.gt.nres) then
6054           iii=ii-nres
6055           jjj=jj-nres
6056         else
6057           iii=ii
6058           jjj=jj
6059         endif
6060 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6061 c     &    dhpb(i),dhpb1(i),forcon(i)
6062 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6063 C    distance and angle dependent SS bond potential.
6064 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6065 C     & iabs(itype(jjj)).eq.1) then
6066 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6067 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6068         if (.not.dyn_ss .and. i.le.nss) then
6069 C 15/02/13 CC dynamic SSbond - additional check
6070          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6071      & iabs(itype(jjj)).eq.1) then
6072           call ssbond_ene(iii,jjj,eij)
6073           ehpb=ehpb+2*eij
6074          endif
6075 cd          write (iout,*) "eij",eij
6076 cd   &   ' waga=',waga,' fac=',fac
6077         else if (ii.gt.nres .and. jj.gt.nres) then
6078 c Restraints from contact prediction
6079           dd=dist(ii,jj)
6080           if (constr_dist.eq.11) then
6081             ehpb=ehpb+fordepth(i)**4.0d0
6082      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6083             fac=fordepth(i)**4.0d0
6084      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6085           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6086      &    ehpb,fordepth(i),dd
6087            else
6088           if (dhpb1(i).gt.0.0d0) then
6089             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6090             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6091 c            write (iout,*) "beta nmr",
6092 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6093           else
6094             dd=dist(ii,jj)
6095             rdis=dd-dhpb(i)
6096 C Get the force constant corresponding to this distance.
6097             waga=forcon(i)
6098 C Calculate the contribution to energy.
6099             ehpb=ehpb+waga*rdis*rdis
6100 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6101 C
6102 C Evaluate gradient.
6103 C
6104             fac=waga*rdis/dd
6105           endif
6106           endif
6107           do j=1,3
6108             ggg(j)=fac*(c(j,jj)-c(j,ii))
6109           enddo
6110           do j=1,3
6111             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6112             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6113           enddo
6114           do k=1,3
6115             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6116             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6117           enddo
6118         else
6119 C Calculate the distance between the two points and its difference from the
6120 C target distance.
6121           dd=dist(ii,jj)
6122           if (constr_dist.eq.11) then
6123             ehpb=ehpb+fordepth(i)**4.0d0
6124      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6125             fac=fordepth(i)**4.0d0
6126      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6127           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6128      &    ehpb,fordepth(i),dd
6129            else
6130           if (dhpb1(i).gt.0.0d0) then
6131             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6132             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6133 c            write (iout,*) "alph nmr",
6134 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6135           else
6136             rdis=dd-dhpb(i)
6137 C Get the force constant corresponding to this distance.
6138             waga=forcon(i)
6139 C Calculate the contribution to energy.
6140             ehpb=ehpb+waga*rdis*rdis
6141 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6142 C
6143 C Evaluate gradient.
6144 C
6145             fac=waga*rdis/dd
6146           endif
6147           endif
6148             do j=1,3
6149               ggg(j)=fac*(c(j,jj)-c(j,ii))
6150             enddo
6151 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6152 C If this is a SC-SC distance, we need to calculate the contributions to the
6153 C Cartesian gradient in the SC vectors (ghpbx).
6154           if (iii.lt.ii) then
6155           do j=1,3
6156             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6157             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6158           enddo
6159           endif
6160 cgrad        do j=iii,jjj-1
6161 cgrad          do k=1,3
6162 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6163 cgrad          enddo
6164 cgrad        enddo
6165           do k=1,3
6166             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6167             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6168           enddo
6169         endif
6170       enddo
6171       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6172       return
6173       end
6174 C--------------------------------------------------------------------------
6175       subroutine ssbond_ene(i,j,eij)
6176 C
6177 C Calculate the distance and angle dependent SS-bond potential energy
6178 C using a free-energy function derived based on RHF/6-31G** ab initio
6179 C calculations of diethyl disulfide.
6180 C
6181 C A. Liwo and U. Kozlowska, 11/24/03
6182 C
6183       implicit real*8 (a-h,o-z)
6184       include 'DIMENSIONS'
6185       include 'COMMON.SBRIDGE'
6186       include 'COMMON.CHAIN'
6187       include 'COMMON.DERIV'
6188       include 'COMMON.LOCAL'
6189       include 'COMMON.INTERACT'
6190       include 'COMMON.VAR'
6191       include 'COMMON.IOUNITS'
6192       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6193       itypi=iabs(itype(i))
6194       xi=c(1,nres+i)
6195       yi=c(2,nres+i)
6196       zi=c(3,nres+i)
6197       dxi=dc_norm(1,nres+i)
6198       dyi=dc_norm(2,nres+i)
6199       dzi=dc_norm(3,nres+i)
6200 c      dsci_inv=dsc_inv(itypi)
6201       dsci_inv=vbld_inv(nres+i)
6202       itypj=iabs(itype(j))
6203 c      dscj_inv=dsc_inv(itypj)
6204       dscj_inv=vbld_inv(nres+j)
6205       xj=c(1,nres+j)-xi
6206       yj=c(2,nres+j)-yi
6207       zj=c(3,nres+j)-zi
6208       dxj=dc_norm(1,nres+j)
6209       dyj=dc_norm(2,nres+j)
6210       dzj=dc_norm(3,nres+j)
6211       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6212       rij=dsqrt(rrij)
6213       erij(1)=xj*rij
6214       erij(2)=yj*rij
6215       erij(3)=zj*rij
6216       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6217       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6218       om12=dxi*dxj+dyi*dyj+dzi*dzj
6219       do k=1,3
6220         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6221         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6222       enddo
6223       rij=1.0d0/rij
6224       deltad=rij-d0cm
6225       deltat1=1.0d0-om1
6226       deltat2=1.0d0+om2
6227       deltat12=om2-om1+2.0d0
6228       cosphi=om12-om1*om2
6229       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6230      &  +akct*deltad*deltat12
6231      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6232 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6233 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6234 c     &  " deltat12",deltat12," eij",eij
6235       ed=2*akcm*deltad+akct*deltat12
6236       pom1=akct*deltad
6237       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6238       eom1=-2*akth*deltat1-pom1-om2*pom2
6239       eom2= 2*akth*deltat2+pom1-om1*pom2
6240       eom12=pom2
6241       do k=1,3
6242         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6243         ghpbx(k,i)=ghpbx(k,i)-ggk
6244      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6245      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6246         ghpbx(k,j)=ghpbx(k,j)+ggk
6247      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6248      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6249         ghpbc(k,i)=ghpbc(k,i)-ggk
6250         ghpbc(k,j)=ghpbc(k,j)+ggk
6251       enddo
6252 C
6253 C Calculate the components of the gradient in DC and X
6254 C
6255 cgrad      do k=i,j-1
6256 cgrad        do l=1,3
6257 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6258 cgrad        enddo
6259 cgrad      enddo
6260       return
6261       end
6262 C--------------------------------------------------------------------------
6263       subroutine ebond(estr)
6264 c
6265 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6266 c
6267       implicit real*8 (a-h,o-z)
6268       include 'DIMENSIONS'
6269       include 'COMMON.LOCAL'
6270       include 'COMMON.GEO'
6271       include 'COMMON.INTERACT'
6272       include 'COMMON.DERIV'
6273       include 'COMMON.VAR'
6274       include 'COMMON.CHAIN'
6275       include 'COMMON.IOUNITS'
6276       include 'COMMON.NAMES'
6277       include 'COMMON.FFIELD'
6278       include 'COMMON.CONTROL'
6279       include 'COMMON.SETUP'
6280       double precision u(3),ud(3)
6281       estr=0.0d0
6282       estr1=0.0d0
6283       do i=ibondp_start,ibondp_end
6284         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6285 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6286 c          do j=1,3
6287 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6288 c     &      *dc(j,i-1)/vbld(i)
6289 c          enddo
6290 c          if (energy_dec) write(iout,*)
6291 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6292 c        else
6293 C       Checking if it involves dummy (NH3+ or COO-) group
6294          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6295 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6296         diff = vbld(i)-vbldpDUM
6297         if (energy_dec) write(iout,*) "dum_bond",i,diff
6298          else
6299 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6300         diff = vbld(i)-vbldp0
6301          endif
6302         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6303      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6304         estr=estr+diff*diff
6305         do j=1,3
6306           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6307         enddo
6308 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6309 c        endif
6310       enddo
6311
6312       estr=0.5d0*AKP*estr+estr1
6313 c
6314 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6315 c
6316       do i=ibond_start,ibond_end
6317         iti=iabs(itype(i))
6318         if (iti.ne.10 .and. iti.ne.ntyp1) then
6319           nbi=nbondterm(iti)
6320           if (nbi.eq.1) then
6321             diff=vbld(i+nres)-vbldsc0(1,iti)
6322             if (energy_dec)  write (iout,*)
6323      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6324      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6325             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6326             do j=1,3
6327               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6328             enddo
6329           else
6330             do j=1,nbi
6331               diff=vbld(i+nres)-vbldsc0(j,iti)
6332               ud(j)=aksc(j,iti)*diff
6333               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6334             enddo
6335             uprod=u(1)
6336             do j=2,nbi
6337               uprod=uprod*u(j)
6338             enddo
6339             usum=0.0d0
6340             usumsqder=0.0d0
6341             do j=1,nbi
6342               uprod1=1.0d0
6343               uprod2=1.0d0
6344               do k=1,nbi
6345                 if (k.ne.j) then
6346                   uprod1=uprod1*u(k)
6347                   uprod2=uprod2*u(k)*u(k)
6348                 endif
6349               enddo
6350               usum=usum+uprod1
6351               usumsqder=usumsqder+ud(j)*uprod2
6352             enddo
6353             estr=estr+uprod/usum
6354             do j=1,3
6355              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6356             enddo
6357           endif
6358         endif
6359       enddo
6360       return
6361       end
6362 #ifdef CRYST_THETA
6363 C--------------------------------------------------------------------------
6364       subroutine ebend(etheta,ethetacnstr)
6365 C
6366 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6367 C angles gamma and its derivatives in consecutive thetas and gammas.
6368 C
6369       implicit real*8 (a-h,o-z)
6370       include 'DIMENSIONS'
6371       include 'COMMON.LOCAL'
6372       include 'COMMON.GEO'
6373       include 'COMMON.INTERACT'
6374       include 'COMMON.DERIV'
6375       include 'COMMON.VAR'
6376       include 'COMMON.CHAIN'
6377       include 'COMMON.IOUNITS'
6378       include 'COMMON.NAMES'
6379       include 'COMMON.FFIELD'
6380       include 'COMMON.CONTROL'
6381       include 'COMMON.TORCNSTR'
6382       common /calcthet/ term1,term2,termm,diffak,ratak,
6383      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6384      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6385       double precision y(2),z(2)
6386       delta=0.02d0*pi
6387 c      time11=dexp(-2*time)
6388 c      time12=1.0d0
6389       etheta=0.0D0
6390 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6391       do i=ithet_start,ithet_end
6392         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6393      &  .or.itype(i).eq.ntyp1) cycle
6394 C Zero the energy function and its derivative at 0 or pi.
6395         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6396         it=itype(i-1)
6397         ichir1=isign(1,itype(i-2))
6398         ichir2=isign(1,itype(i))
6399          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6400          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6401          if (itype(i-1).eq.10) then
6402           itype1=isign(10,itype(i-2))
6403           ichir11=isign(1,itype(i-2))
6404           ichir12=isign(1,itype(i-2))
6405           itype2=isign(10,itype(i))
6406           ichir21=isign(1,itype(i))
6407           ichir22=isign(1,itype(i))
6408          endif
6409
6410         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6411 #ifdef OSF
6412           phii=phi(i)
6413           if (phii.ne.phii) phii=150.0
6414 #else
6415           phii=phi(i)
6416 #endif
6417           y(1)=dcos(phii)
6418           y(2)=dsin(phii)
6419         else
6420           y(1)=0.0D0
6421           y(2)=0.0D0
6422         endif
6423         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6424 #ifdef OSF
6425           phii1=phi(i+1)
6426           if (phii1.ne.phii1) phii1=150.0
6427           phii1=pinorm(phii1)
6428           z(1)=cos(phii1)
6429 #else
6430           phii1=phi(i+1)
6431 #endif
6432           z(1)=dcos(phii1)
6433           z(2)=dsin(phii1)
6434         else
6435           z(1)=0.0D0
6436           z(2)=0.0D0
6437         endif
6438 C Calculate the "mean" value of theta from the part of the distribution
6439 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6440 C In following comments this theta will be referred to as t_c.
6441         thet_pred_mean=0.0d0
6442         do k=1,2
6443             athetk=athet(k,it,ichir1,ichir2)
6444             bthetk=bthet(k,it,ichir1,ichir2)
6445           if (it.eq.10) then
6446              athetk=athet(k,itype1,ichir11,ichir12)
6447              bthetk=bthet(k,itype2,ichir21,ichir22)
6448           endif
6449          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6450 c         write(iout,*) 'chuj tu', y(k),z(k)
6451         enddo
6452         dthett=thet_pred_mean*ssd
6453         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6454 C Derivatives of the "mean" values in gamma1 and gamma2.
6455         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6456      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6457          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6458      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6459          if (it.eq.10) then
6460       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6461      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6462         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6463      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6464          endif
6465         if (theta(i).gt.pi-delta) then
6466           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6467      &         E_tc0)
6468           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6469           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6470           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6471      &        E_theta)
6472           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6473      &        E_tc)
6474         else if (theta(i).lt.delta) then
6475           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6476           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6477           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6478      &        E_theta)
6479           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6480           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6481      &        E_tc)
6482         else
6483           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6484      &        E_theta,E_tc)
6485         endif
6486         etheta=etheta+ethetai
6487         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6488      &      'ebend',i,ethetai,theta(i),itype(i)
6489         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6490         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6491         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6492       enddo
6493       ethetacnstr=0.0d0
6494 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6495       do i=ithetaconstr_start,ithetaconstr_end
6496         itheta=itheta_constr(i)
6497         thetiii=theta(itheta)
6498         difi=pinorm(thetiii-theta_constr0(i))
6499         if (difi.gt.theta_drange(i)) then
6500           difi=difi-theta_drange(i)
6501           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6502           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6503      &    +for_thet_constr(i)*difi**3
6504         else if (difi.lt.-drange(i)) then
6505           difi=difi+drange(i)
6506           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6507           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6508      &    +for_thet_constr(i)*difi**3
6509         else
6510           difi=0.0
6511         endif
6512        if (energy_dec) then
6513         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6514      &    i,itheta,rad2deg*thetiii,
6515      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6516      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6517      &    gloc(itheta+nphi-2,icg)
6518         endif
6519       enddo
6520
6521 C Ufff.... We've done all this!!!
6522       return
6523       end
6524 C---------------------------------------------------------------------------
6525       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6526      &     E_tc)
6527       implicit real*8 (a-h,o-z)
6528       include 'DIMENSIONS'
6529       include 'COMMON.LOCAL'
6530       include 'COMMON.IOUNITS'
6531       common /calcthet/ term1,term2,termm,diffak,ratak,
6532      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6533      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6534 C Calculate the contributions to both Gaussian lobes.
6535 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6536 C The "polynomial part" of the "standard deviation" of this part of
6537 C the distributioni.
6538 ccc        write (iout,*) thetai,thet_pred_mean
6539         sig=polthet(3,it)
6540         do j=2,0,-1
6541           sig=sig*thet_pred_mean+polthet(j,it)
6542         enddo
6543 C Derivative of the "interior part" of the "standard deviation of the"
6544 C gamma-dependent Gaussian lobe in t_c.
6545         sigtc=3*polthet(3,it)
6546         do j=2,1,-1
6547           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6548         enddo
6549         sigtc=sig*sigtc
6550 C Set the parameters of both Gaussian lobes of the distribution.
6551 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6552         fac=sig*sig+sigc0(it)
6553         sigcsq=fac+fac
6554         sigc=1.0D0/sigcsq
6555 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6556         sigsqtc=-4.0D0*sigcsq*sigtc
6557 c       print *,i,sig,sigtc,sigsqtc
6558 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6559         sigtc=-sigtc/(fac*fac)
6560 C Following variable is sigma(t_c)**(-2)
6561         sigcsq=sigcsq*sigcsq
6562         sig0i=sig0(it)
6563         sig0inv=1.0D0/sig0i**2
6564         delthec=thetai-thet_pred_mean
6565         delthe0=thetai-theta0i
6566         term1=-0.5D0*sigcsq*delthec*delthec
6567         term2=-0.5D0*sig0inv*delthe0*delthe0
6568 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6569 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6570 C NaNs in taking the logarithm. We extract the largest exponent which is added
6571 C to the energy (this being the log of the distribution) at the end of energy
6572 C term evaluation for this virtual-bond angle.
6573         if (term1.gt.term2) then
6574           termm=term1
6575           term2=dexp(term2-termm)
6576           term1=1.0d0
6577         else
6578           termm=term2
6579           term1=dexp(term1-termm)
6580           term2=1.0d0
6581         endif
6582 C The ratio between the gamma-independent and gamma-dependent lobes of
6583 C the distribution is a Gaussian function of thet_pred_mean too.
6584         diffak=gthet(2,it)-thet_pred_mean
6585         ratak=diffak/gthet(3,it)**2
6586         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6587 C Let's differentiate it in thet_pred_mean NOW.
6588         aktc=ak*ratak
6589 C Now put together the distribution terms to make complete distribution.
6590         termexp=term1+ak*term2
6591         termpre=sigc+ak*sig0i
6592 C Contribution of the bending energy from this theta is just the -log of
6593 C the sum of the contributions from the two lobes and the pre-exponential
6594 C factor. Simple enough, isn't it?
6595         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6596 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6597 C NOW the derivatives!!!
6598 C 6/6/97 Take into account the deformation.
6599         E_theta=(delthec*sigcsq*term1
6600      &       +ak*delthe0*sig0inv*term2)/termexp
6601         E_tc=((sigtc+aktc*sig0i)/termpre
6602      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6603      &       aktc*term2)/termexp)
6604       return
6605       end
6606 c-----------------------------------------------------------------------------
6607       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6608       implicit real*8 (a-h,o-z)
6609       include 'DIMENSIONS'
6610       include 'COMMON.LOCAL'
6611       include 'COMMON.IOUNITS'
6612       common /calcthet/ term1,term2,termm,diffak,ratak,
6613      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6614      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6615       delthec=thetai-thet_pred_mean
6616       delthe0=thetai-theta0i
6617 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6618       t3 = thetai-thet_pred_mean
6619       t6 = t3**2
6620       t9 = term1
6621       t12 = t3*sigcsq
6622       t14 = t12+t6*sigsqtc
6623       t16 = 1.0d0
6624       t21 = thetai-theta0i
6625       t23 = t21**2
6626       t26 = term2
6627       t27 = t21*t26
6628       t32 = termexp
6629       t40 = t32**2
6630       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6631      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6632      & *(-t12*t9-ak*sig0inv*t27)
6633       return
6634       end
6635 #else
6636 C--------------------------------------------------------------------------
6637       subroutine ebend(etheta,ethetacnstr)
6638 C
6639 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6640 C angles gamma and its derivatives in consecutive thetas and gammas.
6641 C ab initio-derived potentials from
6642 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6643 C
6644       implicit real*8 (a-h,o-z)
6645       include 'DIMENSIONS'
6646       include 'COMMON.LOCAL'
6647       include 'COMMON.GEO'
6648       include 'COMMON.INTERACT'
6649       include 'COMMON.DERIV'
6650       include 'COMMON.VAR'
6651       include 'COMMON.CHAIN'
6652       include 'COMMON.IOUNITS'
6653       include 'COMMON.NAMES'
6654       include 'COMMON.FFIELD'
6655       include 'COMMON.CONTROL'
6656       include 'COMMON.TORCNSTR'
6657       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6658      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6659      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6660      & sinph1ph2(maxdouble,maxdouble)
6661       logical lprn /.false./, lprn1 /.false./
6662       etheta=0.0D0
6663       do i=ithet_start,ithet_end
6664 c        print *,i,itype(i-1),itype(i),itype(i-2)
6665         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6666      &  .or.itype(i).eq.ntyp1) cycle
6667 C        print *,i,theta(i)
6668         if (iabs(itype(i+1)).eq.20) iblock=2
6669         if (iabs(itype(i+1)).ne.20) iblock=1
6670         dethetai=0.0d0
6671         dephii=0.0d0
6672         dephii1=0.0d0
6673         theti2=0.5d0*theta(i)
6674         ityp2=ithetyp((itype(i-1)))
6675         do k=1,nntheterm
6676           coskt(k)=dcos(k*theti2)
6677           sinkt(k)=dsin(k*theti2)
6678         enddo
6679 C        print *,ethetai
6680         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6681 #ifdef OSF
6682           phii=phi(i)
6683           if (phii.ne.phii) phii=150.0
6684 #else
6685           phii=phi(i)
6686 #endif
6687           ityp1=ithetyp((itype(i-2)))
6688 C propagation of chirality for glycine type
6689           do k=1,nsingle
6690             cosph1(k)=dcos(k*phii)
6691             sinph1(k)=dsin(k*phii)
6692           enddo
6693         else
6694           phii=0.0d0
6695           do k=1,nsingle
6696           ityp1=ithetyp((itype(i-2)))
6697             cosph1(k)=0.0d0
6698             sinph1(k)=0.0d0
6699           enddo
6700         endif
6701         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6702 #ifdef OSF
6703           phii1=phi(i+1)
6704           if (phii1.ne.phii1) phii1=150.0
6705           phii1=pinorm(phii1)
6706 #else
6707           phii1=phi(i+1)
6708 #endif
6709           ityp3=ithetyp((itype(i)))
6710           do k=1,nsingle
6711             cosph2(k)=dcos(k*phii1)
6712             sinph2(k)=dsin(k*phii1)
6713           enddo
6714         else
6715           phii1=0.0d0
6716           ityp3=ithetyp((itype(i)))
6717           do k=1,nsingle
6718             cosph2(k)=0.0d0
6719             sinph2(k)=0.0d0
6720           enddo
6721         endif
6722         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6723         do k=1,ndouble
6724           do l=1,k-1
6725             ccl=cosph1(l)*cosph2(k-l)
6726             ssl=sinph1(l)*sinph2(k-l)
6727             scl=sinph1(l)*cosph2(k-l)
6728             csl=cosph1(l)*sinph2(k-l)
6729             cosph1ph2(l,k)=ccl-ssl
6730             cosph1ph2(k,l)=ccl+ssl
6731             sinph1ph2(l,k)=scl+csl
6732             sinph1ph2(k,l)=scl-csl
6733           enddo
6734         enddo
6735         if (lprn) then
6736         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6737      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6738         write (iout,*) "coskt and sinkt"
6739         do k=1,nntheterm
6740           write (iout,*) k,coskt(k),sinkt(k)
6741         enddo
6742         endif
6743         do k=1,ntheterm
6744           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6745           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6746      &      *coskt(k)
6747           if (lprn)
6748      &    write (iout,*) "k",k,"
6749      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6750      &     " ethetai",ethetai
6751         enddo
6752         if (lprn) then
6753         write (iout,*) "cosph and sinph"
6754         do k=1,nsingle
6755           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6756         enddo
6757         write (iout,*) "cosph1ph2 and sinph2ph2"
6758         do k=2,ndouble
6759           do l=1,k-1
6760             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6761      &         sinph1ph2(l,k),sinph1ph2(k,l)
6762           enddo
6763         enddo
6764         write(iout,*) "ethetai",ethetai
6765         endif
6766 C       print *,ethetai
6767         do m=1,ntheterm2
6768           do k=1,nsingle
6769             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6770      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6771      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6772      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6773             ethetai=ethetai+sinkt(m)*aux
6774             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6775             dephii=dephii+k*sinkt(m)*(
6776      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6777      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6778             dephii1=dephii1+k*sinkt(m)*(
6779      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6780      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6781             if (lprn)
6782      &      write (iout,*) "m",m," k",k," bbthet",
6783      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6784      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6785      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6786      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6787 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6788           enddo
6789         enddo
6790 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6791 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6792 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6793 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6794         if (lprn)
6795      &  write(iout,*) "ethetai",ethetai
6796 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6797         do m=1,ntheterm3
6798           do k=2,ndouble
6799             do l=1,k-1
6800               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6801      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6802      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6803      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6804               ethetai=ethetai+sinkt(m)*aux
6805               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6806               dephii=dephii+l*sinkt(m)*(
6807      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6808      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6809      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6810      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6811               dephii1=dephii1+(k-l)*sinkt(m)*(
6812      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6813      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6814      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6815      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6816               if (lprn) then
6817               write (iout,*) "m",m," k",k," l",l," ffthet",
6818      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6819      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6820      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6821      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6822      &            " ethetai",ethetai
6823               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6824      &            cosph1ph2(k,l)*sinkt(m),
6825      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6826               endif
6827             enddo
6828           enddo
6829         enddo
6830 10      continue
6831 c        lprn1=.true.
6832 C        print *,ethetai
6833         if (lprn1)
6834      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6835      &   i,theta(i)*rad2deg,phii*rad2deg,
6836      &   phii1*rad2deg,ethetai
6837 c        lprn1=.false.
6838         etheta=etheta+ethetai
6839         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6840         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6841         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6842       enddo
6843 C now constrains
6844       ethetacnstr=0.0d0
6845 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6846       do i=ithetaconstr_start,ithetaconstr_end
6847         itheta=itheta_constr(i)
6848         thetiii=theta(itheta)
6849         difi=pinorm(thetiii-theta_constr0(i))
6850         if (difi.gt.theta_drange(i)) then
6851           difi=difi-theta_drange(i)
6852           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6853           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6854      &    +for_thet_constr(i)*difi**3
6855         else if (difi.lt.-drange(i)) then
6856           difi=difi+drange(i)
6857           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6858           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6859      &    +for_thet_constr(i)*difi**3
6860         else
6861           difi=0.0
6862         endif
6863        if (energy_dec) then
6864         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6865      &    i,itheta,rad2deg*thetiii,
6866      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6867      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6868      &    gloc(itheta+nphi-2,icg)
6869         endif
6870       enddo
6871
6872       return
6873       end
6874 #endif
6875 #ifdef CRYST_SC
6876 c-----------------------------------------------------------------------------
6877       subroutine esc(escloc)
6878 C Calculate the local energy of a side chain and its derivatives in the
6879 C corresponding virtual-bond valence angles THETA and the spherical angles
6880 C ALPHA and OMEGA.
6881       implicit real*8 (a-h,o-z)
6882       include 'DIMENSIONS'
6883       include 'COMMON.GEO'
6884       include 'COMMON.LOCAL'
6885       include 'COMMON.VAR'
6886       include 'COMMON.INTERACT'
6887       include 'COMMON.DERIV'
6888       include 'COMMON.CHAIN'
6889       include 'COMMON.IOUNITS'
6890       include 'COMMON.NAMES'
6891       include 'COMMON.FFIELD'
6892       include 'COMMON.CONTROL'
6893       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6894      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6895       common /sccalc/ time11,time12,time112,theti,it,nlobit
6896       delta=0.02d0*pi
6897       escloc=0.0D0
6898 c     write (iout,'(a)') 'ESC'
6899       do i=loc_start,loc_end
6900         it=itype(i)
6901         if (it.eq.ntyp1) cycle
6902         if (it.eq.10) goto 1
6903         nlobit=nlob(iabs(it))
6904 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6905 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6906         theti=theta(i+1)-pipol
6907         x(1)=dtan(theti)
6908         x(2)=alph(i)
6909         x(3)=omeg(i)
6910
6911         if (x(2).gt.pi-delta) then
6912           xtemp(1)=x(1)
6913           xtemp(2)=pi-delta
6914           xtemp(3)=x(3)
6915           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6916           xtemp(2)=pi
6917           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6918           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6919      &        escloci,dersc(2))
6920           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6921      &        ddersc0(1),dersc(1))
6922           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6923      &        ddersc0(3),dersc(3))
6924           xtemp(2)=pi-delta
6925           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6926           xtemp(2)=pi
6927           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6928           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6929      &            dersc0(2),esclocbi,dersc02)
6930           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6931      &            dersc12,dersc01)
6932           call splinthet(x(2),0.5d0*delta,ss,ssd)
6933           dersc0(1)=dersc01
6934           dersc0(2)=dersc02
6935           dersc0(3)=0.0d0
6936           do k=1,3
6937             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6938           enddo
6939           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6940 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6941 c    &             esclocbi,ss,ssd
6942           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6943 c         escloci=esclocbi
6944 c         write (iout,*) escloci
6945         else if (x(2).lt.delta) then
6946           xtemp(1)=x(1)
6947           xtemp(2)=delta
6948           xtemp(3)=x(3)
6949           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6950           xtemp(2)=0.0d0
6951           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6952           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6953      &        escloci,dersc(2))
6954           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6955      &        ddersc0(1),dersc(1))
6956           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6957      &        ddersc0(3),dersc(3))
6958           xtemp(2)=delta
6959           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6960           xtemp(2)=0.0d0
6961           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6962           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6963      &            dersc0(2),esclocbi,dersc02)
6964           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6965      &            dersc12,dersc01)
6966           dersc0(1)=dersc01
6967           dersc0(2)=dersc02
6968           dersc0(3)=0.0d0
6969           call splinthet(x(2),0.5d0*delta,ss,ssd)
6970           do k=1,3
6971             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6972           enddo
6973           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6974 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6975 c    &             esclocbi,ss,ssd
6976           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6977 c         write (iout,*) escloci
6978         else
6979           call enesc(x,escloci,dersc,ddummy,.false.)
6980         endif
6981
6982         escloc=escloc+escloci
6983         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6984      &     'escloc',i,escloci
6985 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6986
6987         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6988      &   wscloc*dersc(1)
6989         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6990         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6991     1   continue
6992       enddo
6993       return
6994       end
6995 C---------------------------------------------------------------------------
6996       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6997       implicit real*8 (a-h,o-z)
6998       include 'DIMENSIONS'
6999       include 'COMMON.GEO'
7000       include 'COMMON.LOCAL'
7001       include 'COMMON.IOUNITS'
7002       common /sccalc/ time11,time12,time112,theti,it,nlobit
7003       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7004       double precision contr(maxlob,-1:1)
7005       logical mixed
7006 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7007         escloc_i=0.0D0
7008         do j=1,3
7009           dersc(j)=0.0D0
7010           if (mixed) ddersc(j)=0.0d0
7011         enddo
7012         x3=x(3)
7013
7014 C Because of periodicity of the dependence of the SC energy in omega we have
7015 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7016 C To avoid underflows, first compute & store the exponents.
7017
7018         do iii=-1,1
7019
7020           x(3)=x3+iii*dwapi
7021
7022           do j=1,nlobit
7023             do k=1,3
7024               z(k)=x(k)-censc(k,j,it)
7025             enddo
7026             do k=1,3
7027               Axk=0.0D0
7028               do l=1,3
7029                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7030               enddo
7031               Ax(k,j,iii)=Axk
7032             enddo
7033             expfac=0.0D0
7034             do k=1,3
7035               expfac=expfac+Ax(k,j,iii)*z(k)
7036             enddo
7037             contr(j,iii)=expfac
7038           enddo ! j
7039
7040         enddo ! iii
7041
7042         x(3)=x3
7043 C As in the case of ebend, we want to avoid underflows in exponentiation and
7044 C subsequent NaNs and INFs in energy calculation.
7045 C Find the largest exponent
7046         emin=contr(1,-1)
7047         do iii=-1,1
7048           do j=1,nlobit
7049             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7050           enddo
7051         enddo
7052         emin=0.5D0*emin
7053 cd      print *,'it=',it,' emin=',emin
7054
7055 C Compute the contribution to SC energy and derivatives
7056         do iii=-1,1
7057
7058           do j=1,nlobit
7059 #ifdef OSF
7060             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7061             if(adexp.ne.adexp) adexp=1.0
7062             expfac=dexp(adexp)
7063 #else
7064             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7065 #endif
7066 cd          print *,'j=',j,' expfac=',expfac
7067             escloc_i=escloc_i+expfac
7068             do k=1,3
7069               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7070             enddo
7071             if (mixed) then
7072               do k=1,3,2
7073                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7074      &            +gaussc(k,2,j,it))*expfac
7075               enddo
7076             endif
7077           enddo
7078
7079         enddo ! iii
7080
7081         dersc(1)=dersc(1)/cos(theti)**2
7082         ddersc(1)=ddersc(1)/cos(theti)**2
7083         ddersc(3)=ddersc(3)
7084
7085         escloci=-(dlog(escloc_i)-emin)
7086         do j=1,3
7087           dersc(j)=dersc(j)/escloc_i
7088         enddo
7089         if (mixed) then
7090           do j=1,3,2
7091             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7092           enddo
7093         endif
7094       return
7095       end
7096 C------------------------------------------------------------------------------
7097       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7098       implicit real*8 (a-h,o-z)
7099       include 'DIMENSIONS'
7100       include 'COMMON.GEO'
7101       include 'COMMON.LOCAL'
7102       include 'COMMON.IOUNITS'
7103       common /sccalc/ time11,time12,time112,theti,it,nlobit
7104       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7105       double precision contr(maxlob)
7106       logical mixed
7107
7108       escloc_i=0.0D0
7109
7110       do j=1,3
7111         dersc(j)=0.0D0
7112       enddo
7113
7114       do j=1,nlobit
7115         do k=1,2
7116           z(k)=x(k)-censc(k,j,it)
7117         enddo
7118         z(3)=dwapi
7119         do k=1,3
7120           Axk=0.0D0
7121           do l=1,3
7122             Axk=Axk+gaussc(l,k,j,it)*z(l)
7123           enddo
7124           Ax(k,j)=Axk
7125         enddo
7126         expfac=0.0D0
7127         do k=1,3
7128           expfac=expfac+Ax(k,j)*z(k)
7129         enddo
7130         contr(j)=expfac
7131       enddo ! j
7132
7133 C As in the case of ebend, we want to avoid underflows in exponentiation and
7134 C subsequent NaNs and INFs in energy calculation.
7135 C Find the largest exponent
7136       emin=contr(1)
7137       do j=1,nlobit
7138         if (emin.gt.contr(j)) emin=contr(j)
7139       enddo
7140       emin=0.5D0*emin
7141
7142 C Compute the contribution to SC energy and derivatives
7143
7144       dersc12=0.0d0
7145       do j=1,nlobit
7146         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7147         escloc_i=escloc_i+expfac
7148         do k=1,2
7149           dersc(k)=dersc(k)+Ax(k,j)*expfac
7150         enddo
7151         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7152      &            +gaussc(1,2,j,it))*expfac
7153         dersc(3)=0.0d0
7154       enddo
7155
7156       dersc(1)=dersc(1)/cos(theti)**2
7157       dersc12=dersc12/cos(theti)**2
7158       escloci=-(dlog(escloc_i)-emin)
7159       do j=1,2
7160         dersc(j)=dersc(j)/escloc_i
7161       enddo
7162       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7163       return
7164       end
7165 #else
7166 c----------------------------------------------------------------------------------
7167       subroutine esc(escloc)
7168 C Calculate the local energy of a side chain and its derivatives in the
7169 C corresponding virtual-bond valence angles THETA and the spherical angles
7170 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7171 C added by Urszula Kozlowska. 07/11/2007
7172 C
7173       implicit real*8 (a-h,o-z)
7174       include 'DIMENSIONS'
7175       include 'COMMON.GEO'
7176       include 'COMMON.LOCAL'
7177       include 'COMMON.VAR'
7178       include 'COMMON.SCROT'
7179       include 'COMMON.INTERACT'
7180       include 'COMMON.DERIV'
7181       include 'COMMON.CHAIN'
7182       include 'COMMON.IOUNITS'
7183       include 'COMMON.NAMES'
7184       include 'COMMON.FFIELD'
7185       include 'COMMON.CONTROL'
7186       include 'COMMON.VECTORS'
7187       double precision x_prime(3),y_prime(3),z_prime(3)
7188      &    , sumene,dsc_i,dp2_i,x(65),
7189      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7190      &    de_dxx,de_dyy,de_dzz,de_dt
7191       double precision s1_t,s1_6_t,s2_t,s2_6_t
7192       double precision
7193      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7194      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7195      & dt_dCi(3),dt_dCi1(3)
7196       common /sccalc/ time11,time12,time112,theti,it,nlobit
7197       delta=0.02d0*pi
7198       escloc=0.0D0
7199       do i=loc_start,loc_end
7200         if (itype(i).eq.ntyp1) cycle
7201         costtab(i+1) =dcos(theta(i+1))
7202         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7203         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7204         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7205         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7206         cosfac=dsqrt(cosfac2)
7207         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7208         sinfac=dsqrt(sinfac2)
7209         it=iabs(itype(i))
7210         if (it.eq.10) goto 1
7211 c
7212 C  Compute the axes of tghe local cartesian coordinates system; store in
7213 c   x_prime, y_prime and z_prime
7214 c
7215         do j=1,3
7216           x_prime(j) = 0.00
7217           y_prime(j) = 0.00
7218           z_prime(j) = 0.00
7219         enddo
7220 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7221 C     &   dc_norm(3,i+nres)
7222         do j = 1,3
7223           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7224           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7225         enddo
7226         do j = 1,3
7227           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7228         enddo
7229 c       write (2,*) "i",i
7230 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7231 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7232 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7233 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7234 c      & " xy",scalar(x_prime(1),y_prime(1)),
7235 c      & " xz",scalar(x_prime(1),z_prime(1)),
7236 c      & " yy",scalar(y_prime(1),y_prime(1)),
7237 c      & " yz",scalar(y_prime(1),z_prime(1)),
7238 c      & " zz",scalar(z_prime(1),z_prime(1))
7239 c
7240 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7241 C to local coordinate system. Store in xx, yy, zz.
7242 c
7243         xx=0.0d0
7244         yy=0.0d0
7245         zz=0.0d0
7246         do j = 1,3
7247           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7248           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7249           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7250         enddo
7251
7252         xxtab(i)=xx
7253         yytab(i)=yy
7254         zztab(i)=zz
7255 C
7256 C Compute the energy of the ith side cbain
7257 C
7258 c        write (2,*) "xx",xx," yy",yy," zz",zz
7259         it=iabs(itype(i))
7260         do j = 1,65
7261           x(j) = sc_parmin(j,it)
7262         enddo
7263 #ifdef CHECK_COORD
7264 Cc diagnostics - remove later
7265         xx1 = dcos(alph(2))
7266         yy1 = dsin(alph(2))*dcos(omeg(2))
7267         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7268         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7269      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7270      &    xx1,yy1,zz1
7271 C,"  --- ", xx_w,yy_w,zz_w
7272 c end diagnostics
7273 #endif
7274         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7275      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7276      &   + x(10)*yy*zz
7277         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7278      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7279      & + x(20)*yy*zz
7280         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7281      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7282      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7283      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7284      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7285      &  +x(40)*xx*yy*zz
7286         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7287      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7288      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7289      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7290      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7291      &  +x(60)*xx*yy*zz
7292         dsc_i   = 0.743d0+x(61)
7293         dp2_i   = 1.9d0+x(62)
7294         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7295      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7296         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7297      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7298         s1=(1+x(63))/(0.1d0 + dscp1)
7299         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7300         s2=(1+x(65))/(0.1d0 + dscp2)
7301         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7302         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7303      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7304 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7305 c     &   sumene4,
7306 c     &   dscp1,dscp2,sumene
7307 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7308         escloc = escloc + sumene
7309 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7310 c     & ,zz,xx,yy
7311 c#define DEBUG
7312 #ifdef DEBUG
7313 C
7314 C This section to check the numerical derivatives of the energy of ith side
7315 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7316 C #define DEBUG in the code to turn it on.
7317 C
7318         write (2,*) "sumene               =",sumene
7319         aincr=1.0d-7
7320         xxsave=xx
7321         xx=xx+aincr
7322         write (2,*) xx,yy,zz
7323         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7324         de_dxx_num=(sumenep-sumene)/aincr
7325         xx=xxsave
7326         write (2,*) "xx+ sumene from enesc=",sumenep
7327         yysave=yy
7328         yy=yy+aincr
7329         write (2,*) xx,yy,zz
7330         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7331         de_dyy_num=(sumenep-sumene)/aincr
7332         yy=yysave
7333         write (2,*) "yy+ sumene from enesc=",sumenep
7334         zzsave=zz
7335         zz=zz+aincr
7336         write (2,*) xx,yy,zz
7337         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7338         de_dzz_num=(sumenep-sumene)/aincr
7339         zz=zzsave
7340         write (2,*) "zz+ sumene from enesc=",sumenep
7341         costsave=cost2tab(i+1)
7342         sintsave=sint2tab(i+1)
7343         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7344         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7345         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7346         de_dt_num=(sumenep-sumene)/aincr
7347         write (2,*) " t+ sumene from enesc=",sumenep
7348         cost2tab(i+1)=costsave
7349         sint2tab(i+1)=sintsave
7350 C End of diagnostics section.
7351 #endif
7352 C
7353 C Compute the gradient of esc
7354 C
7355 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7356         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7357         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7358         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7359         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7360         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7361         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7362         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7363         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7364         pom1=(sumene3*sint2tab(i+1)+sumene1)
7365      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7366         pom2=(sumene4*cost2tab(i+1)+sumene2)
7367      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7368         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7369         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7370      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7371      &  +x(40)*yy*zz
7372         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7373         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7374      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7375      &  +x(60)*yy*zz
7376         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7377      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7378      &        +(pom1+pom2)*pom_dx
7379 #ifdef DEBUG
7380         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7381 #endif
7382 C
7383         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7384         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7385      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7386      &  +x(40)*xx*zz
7387         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7388         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7389      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7390      &  +x(59)*zz**2 +x(60)*xx*zz
7391         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7392      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7393      &        +(pom1-pom2)*pom_dy
7394 #ifdef DEBUG
7395         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7396 #endif
7397 C
7398         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7399      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7400      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7401      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7402      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7403      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7404      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7405      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7406 #ifdef DEBUG
7407         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7408 #endif
7409 C
7410         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7411      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7412      &  +pom1*pom_dt1+pom2*pom_dt2
7413 #ifdef DEBUG
7414         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7415 #endif
7416 c#undef DEBUG
7417 c
7418 C
7419        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7420        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7421        cosfac2xx=cosfac2*xx
7422        sinfac2yy=sinfac2*yy
7423        do k = 1,3
7424          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7425      &      vbld_inv(i+1)
7426          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7427      &      vbld_inv(i)
7428          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7429          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7430 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7431 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7432 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7433 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7434          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7435          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7436          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7437          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7438          dZZ_Ci1(k)=0.0d0
7439          dZZ_Ci(k)=0.0d0
7440          do j=1,3
7441            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7442      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7443            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7444      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7445          enddo
7446
7447          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7448          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7449          dZZ_XYZ(k)=vbld_inv(i+nres)*
7450      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7451 c
7452          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7453          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7454        enddo
7455
7456        do k=1,3
7457          dXX_Ctab(k,i)=dXX_Ci(k)
7458          dXX_C1tab(k,i)=dXX_Ci1(k)
7459          dYY_Ctab(k,i)=dYY_Ci(k)
7460          dYY_C1tab(k,i)=dYY_Ci1(k)
7461          dZZ_Ctab(k,i)=dZZ_Ci(k)
7462          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7463          dXX_XYZtab(k,i)=dXX_XYZ(k)
7464          dYY_XYZtab(k,i)=dYY_XYZ(k)
7465          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7466        enddo
7467
7468        do k = 1,3
7469 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7470 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7471 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7472 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7473 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7474 c     &    dt_dci(k)
7475 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7476 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7477          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7478      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7479          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7480      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7481          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7482      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7483        enddo
7484 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7485 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7486
7487 C to check gradient call subroutine check_grad
7488
7489     1 continue
7490       enddo
7491       return
7492       end
7493 c------------------------------------------------------------------------------
7494       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7495       implicit none
7496       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7497      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7498       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7499      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7500      &   + x(10)*yy*zz
7501       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7502      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7503      & + x(20)*yy*zz
7504       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7505      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7506      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7507      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7508      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7509      &  +x(40)*xx*yy*zz
7510       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7511      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7512      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7513      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7514      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7515      &  +x(60)*xx*yy*zz
7516       dsc_i   = 0.743d0+x(61)
7517       dp2_i   = 1.9d0+x(62)
7518       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7519      &          *(xx*cost2+yy*sint2))
7520       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7521      &          *(xx*cost2-yy*sint2))
7522       s1=(1+x(63))/(0.1d0 + dscp1)
7523       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7524       s2=(1+x(65))/(0.1d0 + dscp2)
7525       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7526       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7527      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7528       enesc=sumene
7529       return
7530       end
7531 #endif
7532 c------------------------------------------------------------------------------
7533       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7534 C
7535 C This procedure calculates two-body contact function g(rij) and its derivative:
7536 C
7537 C           eps0ij                                     !       x < -1
7538 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7539 C            0                                         !       x > 1
7540 C
7541 C where x=(rij-r0ij)/delta
7542 C
7543 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7544 C
7545       implicit none
7546       double precision rij,r0ij,eps0ij,fcont,fprimcont
7547       double precision x,x2,x4,delta
7548 c     delta=0.02D0*r0ij
7549 c      delta=0.2D0*r0ij
7550       x=(rij-r0ij)/delta
7551       if (x.lt.-1.0D0) then
7552         fcont=eps0ij
7553         fprimcont=0.0D0
7554       else if (x.le.1.0D0) then
7555         x2=x*x
7556         x4=x2*x2
7557         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7558         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7559       else
7560         fcont=0.0D0
7561         fprimcont=0.0D0
7562       endif
7563       return
7564       end
7565 c------------------------------------------------------------------------------
7566       subroutine splinthet(theti,delta,ss,ssder)
7567       implicit real*8 (a-h,o-z)
7568       include 'DIMENSIONS'
7569       include 'COMMON.VAR'
7570       include 'COMMON.GEO'
7571       thetup=pi-delta
7572       thetlow=delta
7573       if (theti.gt.pipol) then
7574         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7575       else
7576         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7577         ssder=-ssder
7578       endif
7579       return
7580       end
7581 c------------------------------------------------------------------------------
7582       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7583       implicit none
7584       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7585       double precision ksi,ksi2,ksi3,a1,a2,a3
7586       a1=fprim0*delta/(f1-f0)
7587       a2=3.0d0-2.0d0*a1
7588       a3=a1-2.0d0
7589       ksi=(x-x0)/delta
7590       ksi2=ksi*ksi
7591       ksi3=ksi2*ksi
7592       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7593       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7594       return
7595       end
7596 c------------------------------------------------------------------------------
7597       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7598       implicit none
7599       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7600       double precision ksi,ksi2,ksi3,a1,a2,a3
7601       ksi=(x-x0)/delta
7602       ksi2=ksi*ksi
7603       ksi3=ksi2*ksi
7604       a1=fprim0x*delta
7605       a2=3*(f1x-f0x)-2*fprim0x*delta
7606       a3=fprim0x*delta-2*(f1x-f0x)
7607       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7608       return
7609       end
7610 C-----------------------------------------------------------------------------
7611 #ifdef CRYST_TOR
7612 C-----------------------------------------------------------------------------
7613       subroutine etor(etors,edihcnstr)
7614       implicit real*8 (a-h,o-z)
7615       include 'DIMENSIONS'
7616       include 'COMMON.VAR'
7617       include 'COMMON.GEO'
7618       include 'COMMON.LOCAL'
7619       include 'COMMON.TORSION'
7620       include 'COMMON.INTERACT'
7621       include 'COMMON.DERIV'
7622       include 'COMMON.CHAIN'
7623       include 'COMMON.NAMES'
7624       include 'COMMON.IOUNITS'
7625       include 'COMMON.FFIELD'
7626       include 'COMMON.TORCNSTR'
7627       include 'COMMON.CONTROL'
7628       logical lprn
7629 C Set lprn=.true. for debugging
7630       lprn=.false.
7631 c      lprn=.true.
7632       etors=0.0D0
7633       do i=iphi_start,iphi_end
7634       etors_ii=0.0D0
7635         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7636      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7637         itori=itortyp(itype(i-2))
7638         itori1=itortyp(itype(i-1))
7639         phii=phi(i)
7640         gloci=0.0D0
7641 C Proline-Proline pair is a special case...
7642         if (itori.eq.3 .and. itori1.eq.3) then
7643           if (phii.gt.-dwapi3) then
7644             cosphi=dcos(3*phii)
7645             fac=1.0D0/(1.0D0-cosphi)
7646             etorsi=v1(1,3,3)*fac
7647             etorsi=etorsi+etorsi
7648             etors=etors+etorsi-v1(1,3,3)
7649             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7650             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7651           endif
7652           do j=1,3
7653             v1ij=v1(j+1,itori,itori1)
7654             v2ij=v2(j+1,itori,itori1)
7655             cosphi=dcos(j*phii)
7656             sinphi=dsin(j*phii)
7657             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7658             if (energy_dec) etors_ii=etors_ii+
7659      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7660             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7661           enddo
7662         else
7663           do j=1,nterm_old
7664             v1ij=v1(j,itori,itori1)
7665             v2ij=v2(j,itori,itori1)
7666             cosphi=dcos(j*phii)
7667             sinphi=dsin(j*phii)
7668             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7669             if (energy_dec) etors_ii=etors_ii+
7670      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7671             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7672           enddo
7673         endif
7674         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7675              'etor',i,etors_ii
7676         if (lprn)
7677      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7678      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7679      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7680         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7681 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7682       enddo
7683 ! 6/20/98 - dihedral angle constraints
7684       edihcnstr=0.0d0
7685       do i=1,ndih_constr
7686         itori=idih_constr(i)
7687         phii=phi(itori)
7688         difi=phii-phi0(i)
7689         if (difi.gt.drange(i)) then
7690           difi=difi-drange(i)
7691           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7692           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7693         else if (difi.lt.-drange(i)) then
7694           difi=difi+drange(i)
7695           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7696           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7697         endif
7698 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7699 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7700       enddo
7701 !      write (iout,*) 'edihcnstr',edihcnstr
7702       return
7703       end
7704 c------------------------------------------------------------------------------
7705       subroutine etor_d(etors_d)
7706       etors_d=0.0d0
7707       return
7708       end
7709 c----------------------------------------------------------------------------
7710 #else
7711       subroutine etor(etors,edihcnstr)
7712       implicit real*8 (a-h,o-z)
7713       include 'DIMENSIONS'
7714       include 'COMMON.VAR'
7715       include 'COMMON.GEO'
7716       include 'COMMON.LOCAL'
7717       include 'COMMON.TORSION'
7718       include 'COMMON.INTERACT'
7719       include 'COMMON.DERIV'
7720       include 'COMMON.CHAIN'
7721       include 'COMMON.NAMES'
7722       include 'COMMON.IOUNITS'
7723       include 'COMMON.FFIELD'
7724       include 'COMMON.TORCNSTR'
7725       include 'COMMON.CONTROL'
7726       logical lprn
7727 C Set lprn=.true. for debugging
7728       lprn=.false.
7729 c     lprn=.true.
7730       etors=0.0D0
7731       do i=iphi_start,iphi_end
7732 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7733 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7734 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7735 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7736         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7737      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7738 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7739 C For introducing the NH3+ and COO- group please check the etor_d for reference
7740 C and guidance
7741         etors_ii=0.0D0
7742          if (iabs(itype(i)).eq.20) then
7743          iblock=2
7744          else
7745          iblock=1
7746          endif
7747         itori=itortyp(itype(i-2))
7748         itori1=itortyp(itype(i-1))
7749         phii=phi(i)
7750         gloci=0.0D0
7751 C Regular cosine and sine terms
7752         do j=1,nterm(itori,itori1,iblock)
7753           v1ij=v1(j,itori,itori1,iblock)
7754           v2ij=v2(j,itori,itori1,iblock)
7755           cosphi=dcos(j*phii)
7756           sinphi=dsin(j*phii)
7757           etors=etors+v1ij*cosphi+v2ij*sinphi
7758           if (energy_dec) etors_ii=etors_ii+
7759      &                v1ij*cosphi+v2ij*sinphi
7760           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7761         enddo
7762 C Lorentz terms
7763 C                         v1
7764 C  E = SUM ----------------------------------- - v1
7765 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7766 C
7767         cosphi=dcos(0.5d0*phii)
7768         sinphi=dsin(0.5d0*phii)
7769         do j=1,nlor(itori,itori1,iblock)
7770           vl1ij=vlor1(j,itori,itori1)
7771           vl2ij=vlor2(j,itori,itori1)
7772           vl3ij=vlor3(j,itori,itori1)
7773           pom=vl2ij*cosphi+vl3ij*sinphi
7774           pom1=1.0d0/(pom*pom+1.0d0)
7775           etors=etors+vl1ij*pom1
7776           if (energy_dec) etors_ii=etors_ii+
7777      &                vl1ij*pom1
7778           pom=-pom*pom1*pom1
7779           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7780         enddo
7781 C Subtract the constant term
7782         etors=etors-v0(itori,itori1,iblock)
7783           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7784      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7785         if (lprn)
7786      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7787      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7788      &  (v1(j,itori,itori1,iblock),j=1,6),
7789      &  (v2(j,itori,itori1,iblock),j=1,6)
7790         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7791 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7792       enddo
7793 ! 6/20/98 - dihedral angle constraints
7794       edihcnstr=0.0d0
7795 c      do i=1,ndih_constr
7796       do i=idihconstr_start,idihconstr_end
7797         itori=idih_constr(i)
7798         phii=phi(itori)
7799         difi=pinorm(phii-phi0(i))
7800         if (difi.gt.drange(i)) then
7801           difi=difi-drange(i)
7802           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7803           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7804         else if (difi.lt.-drange(i)) then
7805           difi=difi+drange(i)
7806           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7807           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7808         else
7809           difi=0.0
7810         endif
7811        if (energy_dec) then
7812         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7813      &    i,itori,rad2deg*phii,
7814      &    rad2deg*phi0(i),  rad2deg*drange(i),
7815      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7816         endif
7817       enddo
7818 cd       write (iout,*) 'edihcnstr',edihcnstr
7819       return
7820       end
7821 c----------------------------------------------------------------------------
7822       subroutine etor_d(etors_d)
7823 C 6/23/01 Compute double torsional energy
7824       implicit real*8 (a-h,o-z)
7825       include 'DIMENSIONS'
7826       include 'COMMON.VAR'
7827       include 'COMMON.GEO'
7828       include 'COMMON.LOCAL'
7829       include 'COMMON.TORSION'
7830       include 'COMMON.INTERACT'
7831       include 'COMMON.DERIV'
7832       include 'COMMON.CHAIN'
7833       include 'COMMON.NAMES'
7834       include 'COMMON.IOUNITS'
7835       include 'COMMON.FFIELD'
7836       include 'COMMON.TORCNSTR'
7837       logical lprn
7838 C Set lprn=.true. for debugging
7839       lprn=.false.
7840 c     lprn=.true.
7841       etors_d=0.0D0
7842 c      write(iout,*) "a tu??"
7843       do i=iphid_start,iphid_end
7844 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7845 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7846 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7847 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7848 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7849          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7850      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7851      &  (itype(i+1).eq.ntyp1)) cycle
7852 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7853         itori=itortyp(itype(i-2))
7854         itori1=itortyp(itype(i-1))
7855         itori2=itortyp(itype(i))
7856         phii=phi(i)
7857         phii1=phi(i+1)
7858         gloci1=0.0D0
7859         gloci2=0.0D0
7860         iblock=1
7861         if (iabs(itype(i+1)).eq.20) iblock=2
7862 C Iblock=2 Proline type
7863 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7864 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7865 C        if (itype(i+1).eq.ntyp1) iblock=3
7866 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7867 C IS or IS NOT need for this
7868 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7869 C        is (itype(i-3).eq.ntyp1) ntblock=2
7870 C        ntblock is N-terminal blocking group
7871
7872 C Regular cosine and sine terms
7873         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7874 C Example of changes for NH3+ blocking group
7875 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7876 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7877           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7878           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7879           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7880           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7881           cosphi1=dcos(j*phii)
7882           sinphi1=dsin(j*phii)
7883           cosphi2=dcos(j*phii1)
7884           sinphi2=dsin(j*phii1)
7885           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7886      &     v2cij*cosphi2+v2sij*sinphi2
7887           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7888           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7889         enddo
7890         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7891           do l=1,k-1
7892             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7893             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7894             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7895             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7896             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7897             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7898             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7899             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7900             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7901      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7902             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7903      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7904             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7905      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7906           enddo
7907         enddo
7908         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7909         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7910       enddo
7911       return
7912       end
7913 #endif
7914 C----------------------------------------------------------------------------------
7915 C The rigorous attempt to derive energy function
7916       subroutine etor_kcc(etors,edihcnstr)
7917       implicit real*8 (a-h,o-z)
7918       include 'DIMENSIONS'
7919       include 'COMMON.VAR'
7920       include 'COMMON.GEO'
7921       include 'COMMON.LOCAL'
7922       include 'COMMON.TORSION'
7923       include 'COMMON.INTERACT'
7924       include 'COMMON.DERIV'
7925       include 'COMMON.CHAIN'
7926       include 'COMMON.NAMES'
7927       include 'COMMON.IOUNITS'
7928       include 'COMMON.FFIELD'
7929       include 'COMMON.TORCNSTR'
7930       include 'COMMON.CONTROL'
7931       logical lprn
7932 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7933 C Set lprn=.true. for debugging
7934       lprn=.false.
7935 c     lprn=.true.
7936 C      print *,"wchodze kcc"
7937       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7938       if (tor_mode.ne.2) then
7939       etors=0.0D0
7940       endif
7941       do i=iphi_start,iphi_end
7942 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7943 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7944 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7945 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7946         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7947      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7948         itori=itortyp_kcc(itype(i-2))
7949         itori1=itortyp_kcc(itype(i-1))
7950         phii=phi(i)
7951         glocig=0.0D0
7952         glocit1=0.0d0
7953         glocit2=0.0d0
7954         sumnonchebyshev=0.0d0
7955         sumchebyshev=0.0d0
7956 C to avoid multiple devision by 2
7957 c        theti22=0.5d0*theta(i)
7958 C theta 12 is the theta_1 /2
7959 C theta 22 is theta_2 /2
7960 c        theti12=0.5d0*theta(i-1)
7961 C and appropriate sinus function
7962         sinthet1=dsin(theta(i-1))
7963         sinthet2=dsin(theta(i))
7964         costhet1=dcos(theta(i-1))
7965         costhet2=dcos(theta(i))
7966 c Cosines of halves thetas
7967         costheti12=0.5d0*(1.0d0+costhet1)
7968         costheti22=0.5d0*(1.0d0+costhet2)
7969 C to speed up lets store its mutliplication
7970         sint1t2=sinthet2*sinthet1
7971         sint1t2n=1.0d0
7972 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7973 C +d_n*sin(n*gamma)) *
7974 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7975 C we have two sum 1) Non-Chebyshev which is with n and gamma
7976         etori=0.0d0
7977         do j=1,nterm_kcc(itori,itori1)
7978
7979           nval=nterm_kcc_Tb(itori,itori1)
7980           v1ij=v1_kcc(j,itori,itori1)
7981           v2ij=v2_kcc(j,itori,itori1)
7982 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7983 C v1ij is c_n and d_n in euation above
7984           cosphi=dcos(j*phii)
7985           sinphi=dsin(j*phii)
7986           sint1t2n1=sint1t2n
7987           sint1t2n=sint1t2n*sint1t2
7988           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7989      &        costheti12)
7990           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7991      &        v11_chyb(1,j,itori,itori1),costheti12)
7992 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7993 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7994           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7995      &        costheti22)
7996           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7997      &        v21_chyb(1,j,itori,itori1),costheti22)
7998 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7999 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
8000           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
8001      &        costheti12)
8002           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8003      &        v12_chyb(1,j,itori,itori1),costheti12)
8004 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8005 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8006           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8007      &        costheti22)
8008           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8009      &        v22_chyb(1,j,itori,itori1),costheti22)
8010 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8011 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8012 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8013 C          if (energy_dec) etors_ii=etors_ii+
8014 C     &                v1ij*cosphi+v2ij*sinphi
8015 C glocig is the gradient local i site in gamma
8016           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8017           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8018           etori=etori+sint1t2n*(actval1+actval2)
8019           glocig=glocig+
8020      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8021      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8022 C now gradient over theta_1
8023           glocit1=glocit1+
8024      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8025      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8026           glocit2=glocit2+
8027      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8028      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8029
8030 C now the Czebyshev polinominal sum
8031 c        do k=1,nterm_kcc_Tb(itori,itori1)
8032 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
8033 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
8034 C         thybt1(k)=0.0
8035 C         thybt2(k)=0.0
8036 c        enddo
8037 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8038 C     &         gradtschebyshev
8039 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8040 C     &         dcos(theti22)**2),
8041 C     &         dsin(theti22)
8042
8043 C now overal sumation
8044 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8045         enddo ! j
8046         etors=etors+etori
8047 C derivative over gamma
8048         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8049 C derivative over theta1
8050         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8051 C now derivative over theta2
8052         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8053         if (lprn)
8054      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8055      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8056       enddo
8057 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8058 ! 6/20/98 - dihedral angle constraints
8059       if (tor_mode.ne.2) then
8060       edihcnstr=0.0d0
8061 c      do i=1,ndih_constr
8062       do i=idihconstr_start,idihconstr_end
8063         itori=idih_constr(i)
8064         phii=phi(itori)
8065         difi=pinorm(phii-phi0(i))
8066         if (difi.gt.drange(i)) then
8067           difi=difi-drange(i)
8068           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8069           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8070         else if (difi.lt.-drange(i)) then
8071           difi=difi+drange(i)
8072           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8073           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8074         else
8075           difi=0.0
8076         endif
8077        enddo
8078        endif
8079       return
8080       end
8081
8082 C The rigorous attempt to derive energy function
8083       subroutine ebend_kcc(etheta,ethetacnstr)
8084
8085       implicit real*8 (a-h,o-z)
8086       include 'DIMENSIONS'
8087       include 'COMMON.VAR'
8088       include 'COMMON.GEO'
8089       include 'COMMON.LOCAL'
8090       include 'COMMON.TORSION'
8091       include 'COMMON.INTERACT'
8092       include 'COMMON.DERIV'
8093       include 'COMMON.CHAIN'
8094       include 'COMMON.NAMES'
8095       include 'COMMON.IOUNITS'
8096       include 'COMMON.FFIELD'
8097       include 'COMMON.TORCNSTR'
8098       include 'COMMON.CONTROL'
8099       logical lprn
8100       double precision thybt1(maxtermkcc)
8101 C Set lprn=.true. for debugging
8102       lprn=.false.
8103 c     lprn=.true.
8104 C      print *,"wchodze kcc"
8105       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8106       if (tor_mode.ne.2) etheta=0.0D0
8107       do i=ithet_start,ithet_end
8108 c        print *,i,itype(i-1),itype(i),itype(i-2)
8109         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8110      &  .or.itype(i).eq.ntyp1) cycle
8111          iti=itortyp_kcc(itype(i-1))
8112         sinthet=dsin(theta(i)/2.0d0)
8113         costhet=dcos(theta(i)/2.0d0)
8114          do j=1,nbend_kcc_Tb(iti)
8115           thybt1(j)=v1bend_chyb(j,iti)
8116          enddo
8117          sumth1thyb=tschebyshev
8118      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8119         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8120      &    sumth1thyb
8121         ihelp=nbend_kcc_Tb(iti)-1
8122         gradthybt1=gradtschebyshev
8123      &         (0,ihelp,thybt1(1),costhet)
8124         etheta=etheta+sumth1thyb
8125 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8126         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8127      &   gradthybt1*sinthet*(-0.5d0)
8128       enddo
8129       if (tor_mode.ne.2) then
8130       ethetacnstr=0.0d0
8131 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8132       do i=ithetaconstr_start,ithetaconstr_end
8133         itheta=itheta_constr(i)
8134         thetiii=theta(itheta)
8135         difi=pinorm(thetiii-theta_constr0(i))
8136         if (difi.gt.theta_drange(i)) then
8137           difi=difi-theta_drange(i)
8138           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8139           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8140      &    +for_thet_constr(i)*difi**3
8141         else if (difi.lt.-drange(i)) then
8142           difi=difi+drange(i)
8143           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8144           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8145      &    +for_thet_constr(i)*difi**3
8146         else
8147           difi=0.0
8148         endif
8149        if (energy_dec) then
8150         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8151      &    i,itheta,rad2deg*thetiii,
8152      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8153      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8154      &    gloc(itheta+nphi-2,icg)
8155         endif
8156       enddo
8157       endif
8158       return
8159       end
8160 c------------------------------------------------------------------------------
8161       subroutine eback_sc_corr(esccor)
8162 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8163 c        conformational states; temporarily implemented as differences
8164 c        between UNRES torsional potentials (dependent on three types of
8165 c        residues) and the torsional potentials dependent on all 20 types
8166 c        of residues computed from AM1  energy surfaces of terminally-blocked
8167 c        amino-acid residues.
8168       implicit real*8 (a-h,o-z)
8169       include 'DIMENSIONS'
8170       include 'COMMON.VAR'
8171       include 'COMMON.GEO'
8172       include 'COMMON.LOCAL'
8173       include 'COMMON.TORSION'
8174       include 'COMMON.SCCOR'
8175       include 'COMMON.INTERACT'
8176       include 'COMMON.DERIV'
8177       include 'COMMON.CHAIN'
8178       include 'COMMON.NAMES'
8179       include 'COMMON.IOUNITS'
8180       include 'COMMON.FFIELD'
8181       include 'COMMON.CONTROL'
8182       logical lprn
8183 C Set lprn=.true. for debugging
8184       lprn=.false.
8185 c      lprn=.true.
8186 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8187       esccor=0.0D0
8188       do i=itau_start,itau_end
8189         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8190         esccor_ii=0.0D0
8191         isccori=isccortyp(itype(i-2))
8192         isccori1=isccortyp(itype(i-1))
8193 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8194         phii=phi(i)
8195         do intertyp=1,3 !intertyp
8196 cc Added 09 May 2012 (Adasko)
8197 cc  Intertyp means interaction type of backbone mainchain correlation:
8198 c   1 = SC...Ca...Ca...Ca
8199 c   2 = Ca...Ca...Ca...SC
8200 c   3 = SC...Ca...Ca...SCi
8201         gloci=0.0D0
8202         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8203      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8204      &      (itype(i-1).eq.ntyp1)))
8205      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8206      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8207      &     .or.(itype(i).eq.ntyp1)))
8208      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8209      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8210      &      (itype(i-3).eq.ntyp1)))) cycle
8211         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8212         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8213      & cycle
8214        do j=1,nterm_sccor(isccori,isccori1)
8215           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8216           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8217           cosphi=dcos(j*tauangle(intertyp,i))
8218           sinphi=dsin(j*tauangle(intertyp,i))
8219           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8220           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8221         enddo
8222 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8223         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8224         if (lprn)
8225      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8226      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8227      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8228      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8229         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8230        enddo !intertyp
8231       enddo
8232
8233       return
8234       end
8235 c----------------------------------------------------------------------------
8236       subroutine multibody(ecorr)
8237 C This subroutine calculates multi-body contributions to energy following
8238 C the idea of Skolnick et al. If side chains I and J make a contact and
8239 C at the same time side chains I+1 and J+1 make a contact, an extra
8240 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8241       implicit real*8 (a-h,o-z)
8242       include 'DIMENSIONS'
8243       include 'COMMON.IOUNITS'
8244       include 'COMMON.DERIV'
8245       include 'COMMON.INTERACT'
8246       include 'COMMON.CONTACTS'
8247       double precision gx(3),gx1(3)
8248       logical lprn
8249
8250 C Set lprn=.true. for debugging
8251       lprn=.false.
8252
8253       if (lprn) then
8254         write (iout,'(a)') 'Contact function values:'
8255         do i=nnt,nct-2
8256           write (iout,'(i2,20(1x,i2,f10.5))')
8257      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8258         enddo
8259       endif
8260       ecorr=0.0D0
8261       do i=nnt,nct
8262         do j=1,3
8263           gradcorr(j,i)=0.0D0
8264           gradxorr(j,i)=0.0D0
8265         enddo
8266       enddo
8267       do i=nnt,nct-2
8268
8269         DO ISHIFT = 3,4
8270
8271         i1=i+ishift
8272         num_conti=num_cont(i)
8273         num_conti1=num_cont(i1)
8274         do jj=1,num_conti
8275           j=jcont(jj,i)
8276           do kk=1,num_conti1
8277             j1=jcont(kk,i1)
8278             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8279 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8280 cd   &                   ' ishift=',ishift
8281 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8282 C The system gains extra energy.
8283               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8284             endif   ! j1==j+-ishift
8285           enddo     ! kk
8286         enddo       ! jj
8287
8288         ENDDO ! ISHIFT
8289
8290       enddo         ! i
8291       return
8292       end
8293 c------------------------------------------------------------------------------
8294       double precision function esccorr(i,j,k,l,jj,kk)
8295       implicit real*8 (a-h,o-z)
8296       include 'DIMENSIONS'
8297       include 'COMMON.IOUNITS'
8298       include 'COMMON.DERIV'
8299       include 'COMMON.INTERACT'
8300       include 'COMMON.CONTACTS'
8301       include 'COMMON.SHIELD'
8302       double precision gx(3),gx1(3)
8303       logical lprn
8304       lprn=.false.
8305       eij=facont(jj,i)
8306       ekl=facont(kk,k)
8307 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8308 C Calculate the multi-body contribution to energy.
8309 C Calculate multi-body contributions to the gradient.
8310 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8311 cd   & k,l,(gacont(m,kk,k),m=1,3)
8312       do m=1,3
8313         gx(m) =ekl*gacont(m,jj,i)
8314         gx1(m)=eij*gacont(m,kk,k)
8315         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8316         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8317         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8318         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8319       enddo
8320       do m=i,j-1
8321         do ll=1,3
8322           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8323         enddo
8324       enddo
8325       do m=k,l-1
8326         do ll=1,3
8327           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8328         enddo
8329       enddo
8330       esccorr=-eij*ekl
8331       return
8332       end
8333 c------------------------------------------------------------------------------
8334       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8335 C This subroutine calculates multi-body contributions to hydrogen-bonding
8336       implicit real*8 (a-h,o-z)
8337       include 'DIMENSIONS'
8338       include 'COMMON.IOUNITS'
8339 #ifdef MPI
8340       include "mpif.h"
8341       parameter (max_cont=maxconts)
8342       parameter (max_dim=26)
8343       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8344       double precision zapas(max_dim,maxconts,max_fg_procs),
8345      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8346       common /przechowalnia/ zapas
8347       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8348      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8349 #endif
8350       include 'COMMON.SETUP'
8351       include 'COMMON.FFIELD'
8352       include 'COMMON.DERIV'
8353       include 'COMMON.INTERACT'
8354       include 'COMMON.CONTACTS'
8355       include 'COMMON.CONTROL'
8356       include 'COMMON.LOCAL'
8357       double precision gx(3),gx1(3),time00
8358       logical lprn,ldone
8359
8360 C Set lprn=.true. for debugging
8361       lprn=.false.
8362 #ifdef MPI
8363       n_corr=0
8364       n_corr1=0
8365       if (nfgtasks.le.1) goto 30
8366       if (lprn) then
8367         write (iout,'(a)') 'Contact function values before RECEIVE:'
8368         do i=nnt,nct-2
8369           write (iout,'(2i3,50(1x,i2,f5.2))')
8370      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8371      &    j=1,num_cont_hb(i))
8372         enddo
8373       endif
8374       call flush(iout)
8375       do i=1,ntask_cont_from
8376         ncont_recv(i)=0
8377       enddo
8378       do i=1,ntask_cont_to
8379         ncont_sent(i)=0
8380       enddo
8381 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8382 c     & ntask_cont_to
8383 C Make the list of contacts to send to send to other procesors
8384 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8385 c      call flush(iout)
8386       do i=iturn3_start,iturn3_end
8387 c        write (iout,*) "make contact list turn3",i," num_cont",
8388 c     &    num_cont_hb(i)
8389         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8390       enddo
8391       do i=iturn4_start,iturn4_end
8392 c        write (iout,*) "make contact list turn4",i," num_cont",
8393 c     &   num_cont_hb(i)
8394         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8395       enddo
8396       do ii=1,nat_sent
8397         i=iat_sent(ii)
8398 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8399 c     &    num_cont_hb(i)
8400         do j=1,num_cont_hb(i)
8401         do k=1,4
8402           jjc=jcont_hb(j,i)
8403           iproc=iint_sent_local(k,jjc,ii)
8404 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8405           if (iproc.gt.0) then
8406             ncont_sent(iproc)=ncont_sent(iproc)+1
8407             nn=ncont_sent(iproc)
8408             zapas(1,nn,iproc)=i
8409             zapas(2,nn,iproc)=jjc
8410             zapas(3,nn,iproc)=facont_hb(j,i)
8411             zapas(4,nn,iproc)=ees0p(j,i)
8412             zapas(5,nn,iproc)=ees0m(j,i)
8413             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8414             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8415             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8416             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8417             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8418             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8419             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8420             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8421             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8422             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8423             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8424             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8425             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8426             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8427             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8428             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8429             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8430             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8431             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8432             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8433             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8434           endif
8435         enddo
8436         enddo
8437       enddo
8438       if (lprn) then
8439       write (iout,*)
8440      &  "Numbers of contacts to be sent to other processors",
8441      &  (ncont_sent(i),i=1,ntask_cont_to)
8442       write (iout,*) "Contacts sent"
8443       do ii=1,ntask_cont_to
8444         nn=ncont_sent(ii)
8445         iproc=itask_cont_to(ii)
8446         write (iout,*) nn," contacts to processor",iproc,
8447      &   " of CONT_TO_COMM group"
8448         do i=1,nn
8449           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8450         enddo
8451       enddo
8452       call flush(iout)
8453       endif
8454       CorrelType=477
8455       CorrelID=fg_rank+1
8456       CorrelType1=478
8457       CorrelID1=nfgtasks+fg_rank+1
8458       ireq=0
8459 C Receive the numbers of needed contacts from other processors
8460       do ii=1,ntask_cont_from
8461         iproc=itask_cont_from(ii)
8462         ireq=ireq+1
8463         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8464      &    FG_COMM,req(ireq),IERR)
8465       enddo
8466 c      write (iout,*) "IRECV ended"
8467 c      call flush(iout)
8468 C Send the number of contacts needed by other processors
8469       do ii=1,ntask_cont_to
8470         iproc=itask_cont_to(ii)
8471         ireq=ireq+1
8472         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8473      &    FG_COMM,req(ireq),IERR)
8474       enddo
8475 c      write (iout,*) "ISEND ended"
8476 c      write (iout,*) "number of requests (nn)",ireq
8477       call flush(iout)
8478       if (ireq.gt.0)
8479      &  call MPI_Waitall(ireq,req,status_array,ierr)
8480 c      write (iout,*)
8481 c     &  "Numbers of contacts to be received from other processors",
8482 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8483 c      call flush(iout)
8484 C Receive contacts
8485       ireq=0
8486       do ii=1,ntask_cont_from
8487         iproc=itask_cont_from(ii)
8488         nn=ncont_recv(ii)
8489 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8490 c     &   " of CONT_TO_COMM group"
8491         call flush(iout)
8492         if (nn.gt.0) then
8493           ireq=ireq+1
8494           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8495      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8496 c          write (iout,*) "ireq,req",ireq,req(ireq)
8497         endif
8498       enddo
8499 C Send the contacts to processors that need them
8500       do ii=1,ntask_cont_to
8501         iproc=itask_cont_to(ii)
8502         nn=ncont_sent(ii)
8503 c        write (iout,*) nn," contacts to processor",iproc,
8504 c     &   " of CONT_TO_COMM group"
8505         if (nn.gt.0) then
8506           ireq=ireq+1
8507           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8508      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8509 c          write (iout,*) "ireq,req",ireq,req(ireq)
8510 c          do i=1,nn
8511 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8512 c          enddo
8513         endif
8514       enddo
8515 c      write (iout,*) "number of requests (contacts)",ireq
8516 c      write (iout,*) "req",(req(i),i=1,4)
8517 c      call flush(iout)
8518       if (ireq.gt.0)
8519      & call MPI_Waitall(ireq,req,status_array,ierr)
8520       do iii=1,ntask_cont_from
8521         iproc=itask_cont_from(iii)
8522         nn=ncont_recv(iii)
8523         if (lprn) then
8524         write (iout,*) "Received",nn," contacts from processor",iproc,
8525      &   " of CONT_FROM_COMM group"
8526         call flush(iout)
8527         do i=1,nn
8528           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8529         enddo
8530         call flush(iout)
8531         endif
8532         do i=1,nn
8533           ii=zapas_recv(1,i,iii)
8534 c Flag the received contacts to prevent double-counting
8535           jj=-zapas_recv(2,i,iii)
8536 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8537 c          call flush(iout)
8538           nnn=num_cont_hb(ii)+1
8539           num_cont_hb(ii)=nnn
8540           jcont_hb(nnn,ii)=jj
8541           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8542           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8543           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8544           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8545           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8546           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8547           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8548           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8549           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8550           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8551           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8552           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8553           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8554           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8555           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8556           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8557           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8558           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8559           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8560           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8561           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8562           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8563           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8564           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8565         enddo
8566       enddo
8567       call flush(iout)
8568       if (lprn) then
8569         write (iout,'(a)') 'Contact function values after receive:'
8570         do i=nnt,nct-2
8571           write (iout,'(2i3,50(1x,i3,f5.2))')
8572      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8573      &    j=1,num_cont_hb(i))
8574         enddo
8575         call flush(iout)
8576       endif
8577    30 continue
8578 #endif
8579       if (lprn) then
8580         write (iout,'(a)') 'Contact function values:'
8581         do i=nnt,nct-2
8582           write (iout,'(2i3,50(1x,i3,f5.2))')
8583      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8584      &    j=1,num_cont_hb(i))
8585         enddo
8586       endif
8587       ecorr=0.0D0
8588 C Remove the loop below after debugging !!!
8589       do i=nnt,nct
8590         do j=1,3
8591           gradcorr(j,i)=0.0D0
8592           gradxorr(j,i)=0.0D0
8593         enddo
8594       enddo
8595 C Calculate the local-electrostatic correlation terms
8596       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8597         i1=i+1
8598         num_conti=num_cont_hb(i)
8599         num_conti1=num_cont_hb(i+1)
8600         do jj=1,num_conti
8601           j=jcont_hb(jj,i)
8602           jp=iabs(j)
8603           do kk=1,num_conti1
8604             j1=jcont_hb(kk,i1)
8605             jp1=iabs(j1)
8606 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8607 c     &         ' jj=',jj,' kk=',kk
8608             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8609      &          .or. j.lt.0 .and. j1.gt.0) .and.
8610      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8611 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8612 C The system gains extra energy.
8613               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8614               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8615      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8616               n_corr=n_corr+1
8617             else if (j1.eq.j) then
8618 C Contacts I-J and I-(J+1) occur simultaneously.
8619 C The system loses extra energy.
8620 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8621             endif
8622           enddo ! kk
8623           do kk=1,num_conti
8624             j1=jcont_hb(kk,i)
8625 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8626 c    &         ' jj=',jj,' kk=',kk
8627             if (j1.eq.j+1) then
8628 C Contacts I-J and (I+1)-J occur simultaneously.
8629 C The system loses extra energy.
8630 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8631             endif ! j1==j+1
8632           enddo ! kk
8633         enddo ! jj
8634       enddo ! i
8635       return
8636       end
8637 c------------------------------------------------------------------------------
8638       subroutine add_hb_contact(ii,jj,itask)
8639       implicit real*8 (a-h,o-z)
8640       include "DIMENSIONS"
8641       include "COMMON.IOUNITS"
8642       integer max_cont
8643       integer max_dim
8644       parameter (max_cont=maxconts)
8645       parameter (max_dim=26)
8646       include "COMMON.CONTACTS"
8647       double precision zapas(max_dim,maxconts,max_fg_procs),
8648      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8649       common /przechowalnia/ zapas
8650       integer i,j,ii,jj,iproc,itask(4),nn
8651 c      write (iout,*) "itask",itask
8652       do i=1,2
8653         iproc=itask(i)
8654         if (iproc.gt.0) then
8655           do j=1,num_cont_hb(ii)
8656             jjc=jcont_hb(j,ii)
8657 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8658             if (jjc.eq.jj) then
8659               ncont_sent(iproc)=ncont_sent(iproc)+1
8660               nn=ncont_sent(iproc)
8661               zapas(1,nn,iproc)=ii
8662               zapas(2,nn,iproc)=jjc
8663               zapas(3,nn,iproc)=facont_hb(j,ii)
8664               zapas(4,nn,iproc)=ees0p(j,ii)
8665               zapas(5,nn,iproc)=ees0m(j,ii)
8666               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8667               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8668               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8669               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8670               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8671               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8672               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8673               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8674               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8675               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8676               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8677               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8678               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8679               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8680               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8681               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8682               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8683               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8684               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8685               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8686               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8687               exit
8688             endif
8689           enddo
8690         endif
8691       enddo
8692       return
8693       end
8694 c------------------------------------------------------------------------------
8695       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8696      &  n_corr1)
8697 C This subroutine calculates multi-body contributions to hydrogen-bonding
8698       implicit real*8 (a-h,o-z)
8699       include 'DIMENSIONS'
8700       include 'COMMON.IOUNITS'
8701 #ifdef MPI
8702       include "mpif.h"
8703       parameter (max_cont=maxconts)
8704       parameter (max_dim=70)
8705       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8706       double precision zapas(max_dim,maxconts,max_fg_procs),
8707      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8708       common /przechowalnia/ zapas
8709       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8710      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8711 #endif
8712       include 'COMMON.SETUP'
8713       include 'COMMON.FFIELD'
8714       include 'COMMON.DERIV'
8715       include 'COMMON.LOCAL'
8716       include 'COMMON.INTERACT'
8717       include 'COMMON.CONTACTS'
8718       include 'COMMON.CHAIN'
8719       include 'COMMON.CONTROL'
8720       include 'COMMON.SHIELD'
8721       double precision gx(3),gx1(3)
8722       integer num_cont_hb_old(maxres)
8723       logical lprn,ldone
8724       double precision eello4,eello5,eelo6,eello_turn6
8725       external eello4,eello5,eello6,eello_turn6
8726 C Set lprn=.true. for debugging
8727       lprn=.false.
8728       eturn6=0.0d0
8729 #ifdef MPI
8730       do i=1,nres
8731         num_cont_hb_old(i)=num_cont_hb(i)
8732       enddo
8733       n_corr=0
8734       n_corr1=0
8735       if (nfgtasks.le.1) goto 30
8736       if (lprn) then
8737         write (iout,'(a)') 'Contact function values before RECEIVE:'
8738         do i=nnt,nct-2
8739           write (iout,'(2i3,50(1x,i2,f5.2))')
8740      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8741      &    j=1,num_cont_hb(i))
8742         enddo
8743       endif
8744       call flush(iout)
8745       do i=1,ntask_cont_from
8746         ncont_recv(i)=0
8747       enddo
8748       do i=1,ntask_cont_to
8749         ncont_sent(i)=0
8750       enddo
8751 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8752 c     & ntask_cont_to
8753 C Make the list of contacts to send to send to other procesors
8754       do i=iturn3_start,iturn3_end
8755 c        write (iout,*) "make contact list turn3",i," num_cont",
8756 c     &    num_cont_hb(i)
8757         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8758       enddo
8759       do i=iturn4_start,iturn4_end
8760 c        write (iout,*) "make contact list turn4",i," num_cont",
8761 c     &   num_cont_hb(i)
8762         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8763       enddo
8764       do ii=1,nat_sent
8765         i=iat_sent(ii)
8766 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8767 c     &    num_cont_hb(i)
8768         do j=1,num_cont_hb(i)
8769         do k=1,4
8770           jjc=jcont_hb(j,i)
8771           iproc=iint_sent_local(k,jjc,ii)
8772 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8773           if (iproc.ne.0) then
8774             ncont_sent(iproc)=ncont_sent(iproc)+1
8775             nn=ncont_sent(iproc)
8776             zapas(1,nn,iproc)=i
8777             zapas(2,nn,iproc)=jjc
8778             zapas(3,nn,iproc)=d_cont(j,i)
8779             ind=3
8780             do kk=1,3
8781               ind=ind+1
8782               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8783             enddo
8784             do kk=1,2
8785               do ll=1,2
8786                 ind=ind+1
8787                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8788               enddo
8789             enddo
8790             do jj=1,5
8791               do kk=1,3
8792                 do ll=1,2
8793                   do mm=1,2
8794                     ind=ind+1
8795                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8796                   enddo
8797                 enddo
8798               enddo
8799             enddo
8800           endif
8801         enddo
8802         enddo
8803       enddo
8804       if (lprn) then
8805       write (iout,*)
8806      &  "Numbers of contacts to be sent to other processors",
8807      &  (ncont_sent(i),i=1,ntask_cont_to)
8808       write (iout,*) "Contacts sent"
8809       do ii=1,ntask_cont_to
8810         nn=ncont_sent(ii)
8811         iproc=itask_cont_to(ii)
8812         write (iout,*) nn," contacts to processor",iproc,
8813      &   " of CONT_TO_COMM group"
8814         do i=1,nn
8815           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8816         enddo
8817       enddo
8818       call flush(iout)
8819       endif
8820       CorrelType=477
8821       CorrelID=fg_rank+1
8822       CorrelType1=478
8823       CorrelID1=nfgtasks+fg_rank+1
8824       ireq=0
8825 C Receive the numbers of needed contacts from other processors
8826       do ii=1,ntask_cont_from
8827         iproc=itask_cont_from(ii)
8828         ireq=ireq+1
8829         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8830      &    FG_COMM,req(ireq),IERR)
8831       enddo
8832 c      write (iout,*) "IRECV ended"
8833 c      call flush(iout)
8834 C Send the number of contacts needed by other processors
8835       do ii=1,ntask_cont_to
8836         iproc=itask_cont_to(ii)
8837         ireq=ireq+1
8838         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8839      &    FG_COMM,req(ireq),IERR)
8840       enddo
8841 c      write (iout,*) "ISEND ended"
8842 c      write (iout,*) "number of requests (nn)",ireq
8843       call flush(iout)
8844       if (ireq.gt.0)
8845      &  call MPI_Waitall(ireq,req,status_array,ierr)
8846 c      write (iout,*)
8847 c     &  "Numbers of contacts to be received from other processors",
8848 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8849 c      call flush(iout)
8850 C Receive contacts
8851       ireq=0
8852       do ii=1,ntask_cont_from
8853         iproc=itask_cont_from(ii)
8854         nn=ncont_recv(ii)
8855 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8856 c     &   " of CONT_TO_COMM group"
8857         call flush(iout)
8858         if (nn.gt.0) then
8859           ireq=ireq+1
8860           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8861      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8862 c          write (iout,*) "ireq,req",ireq,req(ireq)
8863         endif
8864       enddo
8865 C Send the contacts to processors that need them
8866       do ii=1,ntask_cont_to
8867         iproc=itask_cont_to(ii)
8868         nn=ncont_sent(ii)
8869 c        write (iout,*) nn," contacts to processor",iproc,
8870 c     &   " of CONT_TO_COMM group"
8871         if (nn.gt.0) then
8872           ireq=ireq+1
8873           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8874      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8875 c          write (iout,*) "ireq,req",ireq,req(ireq)
8876 c          do i=1,nn
8877 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8878 c          enddo
8879         endif
8880       enddo
8881 c      write (iout,*) "number of requests (contacts)",ireq
8882 c      write (iout,*) "req",(req(i),i=1,4)
8883 c      call flush(iout)
8884       if (ireq.gt.0)
8885      & call MPI_Waitall(ireq,req,status_array,ierr)
8886       do iii=1,ntask_cont_from
8887         iproc=itask_cont_from(iii)
8888         nn=ncont_recv(iii)
8889         if (lprn) then
8890         write (iout,*) "Received",nn," contacts from processor",iproc,
8891      &   " of CONT_FROM_COMM group"
8892         call flush(iout)
8893         do i=1,nn
8894           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8895         enddo
8896         call flush(iout)
8897         endif
8898         do i=1,nn
8899           ii=zapas_recv(1,i,iii)
8900 c Flag the received contacts to prevent double-counting
8901           jj=-zapas_recv(2,i,iii)
8902 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8903 c          call flush(iout)
8904           nnn=num_cont_hb(ii)+1
8905           num_cont_hb(ii)=nnn
8906           jcont_hb(nnn,ii)=jj
8907           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8908           ind=3
8909           do kk=1,3
8910             ind=ind+1
8911             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8912           enddo
8913           do kk=1,2
8914             do ll=1,2
8915               ind=ind+1
8916               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8917             enddo
8918           enddo
8919           do jj=1,5
8920             do kk=1,3
8921               do ll=1,2
8922                 do mm=1,2
8923                   ind=ind+1
8924                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8925                 enddo
8926               enddo
8927             enddo
8928           enddo
8929         enddo
8930       enddo
8931       call flush(iout)
8932       if (lprn) then
8933         write (iout,'(a)') 'Contact function values after receive:'
8934         do i=nnt,nct-2
8935           write (iout,'(2i3,50(1x,i3,5f6.3))')
8936      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8937      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8938         enddo
8939         call flush(iout)
8940       endif
8941    30 continue
8942 #endif
8943       if (lprn) then
8944         write (iout,'(a)') 'Contact function values:'
8945         do i=nnt,nct-2
8946           write (iout,'(2i3,50(1x,i2,5f6.3))')
8947      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8948      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8949         enddo
8950       endif
8951       ecorr=0.0D0
8952       ecorr5=0.0d0
8953       ecorr6=0.0d0
8954 C Remove the loop below after debugging !!!
8955       do i=nnt,nct
8956         do j=1,3
8957           gradcorr(j,i)=0.0D0
8958           gradxorr(j,i)=0.0D0
8959         enddo
8960       enddo
8961 C Calculate the dipole-dipole interaction energies
8962       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8963       do i=iatel_s,iatel_e+1
8964         num_conti=num_cont_hb(i)
8965         do jj=1,num_conti
8966           j=jcont_hb(jj,i)
8967 #ifdef MOMENT
8968           call dipole(i,j,jj)
8969 #endif
8970         enddo
8971       enddo
8972       endif
8973 C Calculate the local-electrostatic correlation terms
8974 c                write (iout,*) "gradcorr5 in eello5 before loop"
8975 c                do iii=1,nres
8976 c                  write (iout,'(i5,3f10.5)')
8977 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8978 c                enddo
8979       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8980 c        write (iout,*) "corr loop i",i
8981         i1=i+1
8982         num_conti=num_cont_hb(i)
8983         num_conti1=num_cont_hb(i+1)
8984         do jj=1,num_conti
8985           j=jcont_hb(jj,i)
8986           jp=iabs(j)
8987           do kk=1,num_conti1
8988             j1=jcont_hb(kk,i1)
8989             jp1=iabs(j1)
8990 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8991 c     &         ' jj=',jj,' kk=',kk
8992 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8993             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8994      &          .or. j.lt.0 .and. j1.gt.0) .and.
8995      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8996 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8997 C The system gains extra energy.
8998               n_corr=n_corr+1
8999               sqd1=dsqrt(d_cont(jj,i))
9000               sqd2=dsqrt(d_cont(kk,i1))
9001               sred_geom = sqd1*sqd2
9002               IF (sred_geom.lt.cutoff_corr) THEN
9003                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9004      &            ekont,fprimcont)
9005 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9006 cd     &         ' jj=',jj,' kk=',kk
9007                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9008                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9009                 do l=1,3
9010                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9011                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9012                 enddo
9013                 n_corr1=n_corr1+1
9014 cd               write (iout,*) 'sred_geom=',sred_geom,
9015 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9016 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9017 cd               write (iout,*) "g_contij",g_contij
9018 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9019 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9020                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9021                 if (wcorr4.gt.0.0d0)
9022      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9023 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9024                   if (energy_dec.and.wcorr4.gt.0.0d0)
9025      1                 write (iout,'(a6,4i5,0pf7.3)')
9026      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9027 c                write (iout,*) "gradcorr5 before eello5"
9028 c                do iii=1,nres
9029 c                  write (iout,'(i5,3f10.5)')
9030 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9031 c                enddo
9032                 if (wcorr5.gt.0.0d0)
9033      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9034 c                write (iout,*) "gradcorr5 after eello5"
9035 c                do iii=1,nres
9036 c                  write (iout,'(i5,3f10.5)')
9037 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9038 c                enddo
9039                   if (energy_dec.and.wcorr5.gt.0.0d0)
9040      1                 write (iout,'(a6,4i5,0pf7.3)')
9041      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9042 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9043 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9044                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9045      &               .or. wturn6.eq.0.0d0))then
9046 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9047                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9048                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9049      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9050 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9051 cd     &            'ecorr6=',ecorr6
9052 cd                write (iout,'(4e15.5)') sred_geom,
9053 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9054 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9055 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9056                 else if (wturn6.gt.0.0d0
9057      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9058 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9059                   eturn6=eturn6+eello_turn6(i,jj,kk)
9060                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9061      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9062 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9063                 endif
9064               ENDIF
9065 1111          continue
9066             endif
9067           enddo ! kk
9068         enddo ! jj
9069       enddo ! i
9070       do i=1,nres
9071         num_cont_hb(i)=num_cont_hb_old(i)
9072       enddo
9073 c                write (iout,*) "gradcorr5 in eello5"
9074 c                do iii=1,nres
9075 c                  write (iout,'(i5,3f10.5)')
9076 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9077 c                enddo
9078       return
9079       end
9080 c------------------------------------------------------------------------------
9081       subroutine add_hb_contact_eello(ii,jj,itask)
9082       implicit real*8 (a-h,o-z)
9083       include "DIMENSIONS"
9084       include "COMMON.IOUNITS"
9085       integer max_cont
9086       integer max_dim
9087       parameter (max_cont=maxconts)
9088       parameter (max_dim=70)
9089       include "COMMON.CONTACTS"
9090       double precision zapas(max_dim,maxconts,max_fg_procs),
9091      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9092       common /przechowalnia/ zapas
9093       integer i,j,ii,jj,iproc,itask(4),nn
9094 c      write (iout,*) "itask",itask
9095       do i=1,2
9096         iproc=itask(i)
9097         if (iproc.gt.0) then
9098           do j=1,num_cont_hb(ii)
9099             jjc=jcont_hb(j,ii)
9100 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9101             if (jjc.eq.jj) then
9102               ncont_sent(iproc)=ncont_sent(iproc)+1
9103               nn=ncont_sent(iproc)
9104               zapas(1,nn,iproc)=ii
9105               zapas(2,nn,iproc)=jjc
9106               zapas(3,nn,iproc)=d_cont(j,ii)
9107               ind=3
9108               do kk=1,3
9109                 ind=ind+1
9110                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9111               enddo
9112               do kk=1,2
9113                 do ll=1,2
9114                   ind=ind+1
9115                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9116                 enddo
9117               enddo
9118               do jj=1,5
9119                 do kk=1,3
9120                   do ll=1,2
9121                     do mm=1,2
9122                       ind=ind+1
9123                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9124                     enddo
9125                   enddo
9126                 enddo
9127               enddo
9128               exit
9129             endif
9130           enddo
9131         endif
9132       enddo
9133       return
9134       end
9135 c------------------------------------------------------------------------------
9136       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9137       implicit real*8 (a-h,o-z)
9138       include 'DIMENSIONS'
9139       include 'COMMON.IOUNITS'
9140       include 'COMMON.DERIV'
9141       include 'COMMON.INTERACT'
9142       include 'COMMON.CONTACTS'
9143       include 'COMMON.SHIELD'
9144       include 'COMMON.CONTROL'
9145       double precision gx(3),gx1(3)
9146       logical lprn
9147       lprn=.false.
9148 C      print *,"wchodze",fac_shield(i),shield_mode
9149       eij=facont_hb(jj,i)
9150       ekl=facont_hb(kk,k)
9151       ees0pij=ees0p(jj,i)
9152       ees0pkl=ees0p(kk,k)
9153       ees0mij=ees0m(jj,i)
9154       ees0mkl=ees0m(kk,k)
9155       ekont=eij*ekl
9156       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9157 C*
9158 C     & fac_shield(i)**2*fac_shield(j)**2
9159 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9160 C Following 4 lines for diagnostics.
9161 cd    ees0pkl=0.0D0
9162 cd    ees0pij=1.0D0
9163 cd    ees0mkl=0.0D0
9164 cd    ees0mij=1.0D0
9165 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9166 c     & 'Contacts ',i,j,
9167 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9168 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9169 c     & 'gradcorr_long'
9170 C Calculate the multi-body contribution to energy.
9171 C      ecorr=ecorr+ekont*ees
9172 C Calculate multi-body contributions to the gradient.
9173       coeffpees0pij=coeffp*ees0pij
9174       coeffmees0mij=coeffm*ees0mij
9175       coeffpees0pkl=coeffp*ees0pkl
9176       coeffmees0mkl=coeffm*ees0mkl
9177       do ll=1,3
9178 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9179         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9180      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9181      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9182         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9183      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9184      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9185 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9186         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9187      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9188      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9189         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9190      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9191      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9192         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9193      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9194      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9195         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9196         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9197         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9198      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9199      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9200         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9201         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9202 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9203       enddo
9204 c      write (iout,*)
9205 cgrad      do m=i+1,j-1
9206 cgrad        do ll=1,3
9207 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9208 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9209 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9210 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9211 cgrad        enddo
9212 cgrad      enddo
9213 cgrad      do m=k+1,l-1
9214 cgrad        do ll=1,3
9215 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9216 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9217 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9218 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9219 cgrad        enddo
9220 cgrad      enddo
9221 c      write (iout,*) "ehbcorr",ekont*ees
9222 C      print *,ekont,ees,i,k
9223       ehbcorr=ekont*ees
9224 C now gradient over shielding
9225 C      return
9226       if (shield_mode.gt.0) then
9227        j=ees0plist(jj,i)
9228        l=ees0plist(kk,k)
9229 C        print *,i,j,fac_shield(i),fac_shield(j),
9230 C     &fac_shield(k),fac_shield(l)
9231         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9232      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9233           do ilist=1,ishield_list(i)
9234            iresshield=shield_list(ilist,i)
9235            do m=1,3
9236            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9237 C     &      *2.0
9238            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9239      &              rlocshield
9240      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9241             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9242      &+rlocshield
9243            enddo
9244           enddo
9245           do ilist=1,ishield_list(j)
9246            iresshield=shield_list(ilist,j)
9247            do m=1,3
9248            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9249 C     &     *2.0
9250            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9251      &              rlocshield
9252      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9253            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9254      &     +rlocshield
9255            enddo
9256           enddo
9257
9258           do ilist=1,ishield_list(k)
9259            iresshield=shield_list(ilist,k)
9260            do m=1,3
9261            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9262 C     &     *2.0
9263            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9264      &              rlocshield
9265      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9266            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9267      &     +rlocshield
9268            enddo
9269           enddo
9270           do ilist=1,ishield_list(l)
9271            iresshield=shield_list(ilist,l)
9272            do m=1,3
9273            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9274 C     &     *2.0
9275            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9276      &              rlocshield
9277      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9278            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9279      &     +rlocshield
9280            enddo
9281           enddo
9282 C          print *,gshieldx(m,iresshield)
9283           do m=1,3
9284             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9285      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9286             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9287      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9288             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9289      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9290             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9291      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9292
9293             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9294      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9295             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9296      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9297             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9298      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9299             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9300      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9301
9302            enddo
9303       endif
9304       endif
9305       return
9306       end
9307 #ifdef MOMENT
9308 C---------------------------------------------------------------------------
9309       subroutine dipole(i,j,jj)
9310       implicit real*8 (a-h,o-z)
9311       include 'DIMENSIONS'
9312       include 'COMMON.IOUNITS'
9313       include 'COMMON.CHAIN'
9314       include 'COMMON.FFIELD'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9322      &  auxmat(2,2)
9323       iti1 = itortyp(itype(i+1))
9324       if (j.lt.nres-1) then
9325         itj1 = itype2loc(itype(j+1))
9326       else
9327         itj1=nloctyp
9328       endif
9329       do iii=1,2
9330         dipi(iii,1)=Ub2(iii,i)
9331         dipderi(iii)=Ub2der(iii,i)
9332         dipi(iii,2)=b1(iii,i+1)
9333         dipj(iii,1)=Ub2(iii,j)
9334         dipderj(iii)=Ub2der(iii,j)
9335         dipj(iii,2)=b1(iii,j+1)
9336       enddo
9337       kkk=0
9338       do iii=1,2
9339         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9340         do jjj=1,2
9341           kkk=kkk+1
9342           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9343         enddo
9344       enddo
9345       do kkk=1,5
9346         do lll=1,3
9347           mmm=0
9348           do iii=1,2
9349             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9350      &        auxvec(1))
9351             do jjj=1,2
9352               mmm=mmm+1
9353               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9354             enddo
9355           enddo
9356         enddo
9357       enddo
9358       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9359       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9360       do iii=1,2
9361         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9362       enddo
9363       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9364       do iii=1,2
9365         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9366       enddo
9367       return
9368       end
9369 #endif
9370 C---------------------------------------------------------------------------
9371       subroutine calc_eello(i,j,k,l,jj,kk)
9372 C
9373 C This subroutine computes matrices and vectors needed to calculate
9374 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9375 C
9376       implicit real*8 (a-h,o-z)
9377       include 'DIMENSIONS'
9378       include 'COMMON.IOUNITS'
9379       include 'COMMON.CHAIN'
9380       include 'COMMON.DERIV'
9381       include 'COMMON.INTERACT'
9382       include 'COMMON.CONTACTS'
9383       include 'COMMON.TORSION'
9384       include 'COMMON.VAR'
9385       include 'COMMON.GEO'
9386       include 'COMMON.FFIELD'
9387       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9388      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9389       logical lprn
9390       common /kutas/ lprn
9391 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9392 cd     & ' jj=',jj,' kk=',kk
9393 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9394 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9395 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9396       do iii=1,2
9397         do jjj=1,2
9398           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9399           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9400         enddo
9401       enddo
9402       call transpose2(aa1(1,1),aa1t(1,1))
9403       call transpose2(aa2(1,1),aa2t(1,1))
9404       do kkk=1,5
9405         do lll=1,3
9406           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9407      &      aa1tder(1,1,lll,kkk))
9408           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9409      &      aa2tder(1,1,lll,kkk))
9410         enddo
9411       enddo
9412       if (l.eq.j+1) then
9413 C parallel orientation of the two CA-CA-CA frames.
9414         if (i.gt.1) then
9415           iti=itype2loc(itype(i))
9416         else
9417           iti=nloctyp
9418         endif
9419         itk1=itype2loc(itype(k+1))
9420         itj=itype2loc(itype(j))
9421         if (l.lt.nres-1) then
9422           itl1=itype2loc(itype(l+1))
9423         else
9424           itl1=nloctyp
9425         endif
9426 C A1 kernel(j+1) A2T
9427 cd        do iii=1,2
9428 cd          write (iout,'(3f10.5,5x,3f10.5)')
9429 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9430 cd        enddo
9431         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9432      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9433      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9434 C Following matrices are needed only for 6-th order cumulants
9435         IF (wcorr6.gt.0.0d0) THEN
9436         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9437      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9438      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9439         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9440      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9441      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9442      &   ADtEAderx(1,1,1,1,1,1))
9443         lprn=.false.
9444         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9445      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9446      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9447      &   ADtEA1derx(1,1,1,1,1,1))
9448         ENDIF
9449 C End 6-th order cumulants
9450 cd        lprn=.false.
9451 cd        if (lprn) then
9452 cd        write (2,*) 'In calc_eello6'
9453 cd        do iii=1,2
9454 cd          write (2,*) 'iii=',iii
9455 cd          do kkk=1,5
9456 cd            write (2,*) 'kkk=',kkk
9457 cd            do jjj=1,2
9458 cd              write (2,'(3(2f10.5),5x)')
9459 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9460 cd            enddo
9461 cd          enddo
9462 cd        enddo
9463 cd        endif
9464         call transpose2(EUgder(1,1,k),auxmat(1,1))
9465         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9466         call transpose2(EUg(1,1,k),auxmat(1,1))
9467         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9468         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9469         do iii=1,2
9470           do kkk=1,5
9471             do lll=1,3
9472               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9473      &          EAEAderx(1,1,lll,kkk,iii,1))
9474             enddo
9475           enddo
9476         enddo
9477 C A1T kernel(i+1) A2
9478         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9479      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9480      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9481 C Following matrices are needed only for 6-th order cumulants
9482         IF (wcorr6.gt.0.0d0) THEN
9483         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9484      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9485      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9486         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9487      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9488      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9489      &   ADtEAderx(1,1,1,1,1,2))
9490         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9491      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9492      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9493      &   ADtEA1derx(1,1,1,1,1,2))
9494         ENDIF
9495 C End 6-th order cumulants
9496         call transpose2(EUgder(1,1,l),auxmat(1,1))
9497         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9498         call transpose2(EUg(1,1,l),auxmat(1,1))
9499         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9500         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9501         do iii=1,2
9502           do kkk=1,5
9503             do lll=1,3
9504               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9505      &          EAEAderx(1,1,lll,kkk,iii,2))
9506             enddo
9507           enddo
9508         enddo
9509 C AEAb1 and AEAb2
9510 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9511 C They are needed only when the fifth- or the sixth-order cumulants are
9512 C indluded.
9513         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9514         call transpose2(AEA(1,1,1),auxmat(1,1))
9515         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9516         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9517         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9518         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9519         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9520         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9521         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9522         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9523         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9524         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9525         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9526         call transpose2(AEA(1,1,2),auxmat(1,1))
9527         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9528         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9529         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9530         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9531         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9532         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9533         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9534         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9535         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9536         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9537         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9538 C Calculate the Cartesian derivatives of the vectors.
9539         do iii=1,2
9540           do kkk=1,5
9541             do lll=1,3
9542               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9543               call matvec2(auxmat(1,1),b1(1,i),
9544      &          AEAb1derx(1,lll,kkk,iii,1,1))
9545               call matvec2(auxmat(1,1),Ub2(1,i),
9546      &          AEAb2derx(1,lll,kkk,iii,1,1))
9547               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9548      &          AEAb1derx(1,lll,kkk,iii,2,1))
9549               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9550      &          AEAb2derx(1,lll,kkk,iii,2,1))
9551               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9552               call matvec2(auxmat(1,1),b1(1,j),
9553      &          AEAb1derx(1,lll,kkk,iii,1,2))
9554               call matvec2(auxmat(1,1),Ub2(1,j),
9555      &          AEAb2derx(1,lll,kkk,iii,1,2))
9556               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9557      &          AEAb1derx(1,lll,kkk,iii,2,2))
9558               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9559      &          AEAb2derx(1,lll,kkk,iii,2,2))
9560             enddo
9561           enddo
9562         enddo
9563         ENDIF
9564 C End vectors
9565       else
9566 C Antiparallel orientation of the two CA-CA-CA frames.
9567         if (i.gt.1) then
9568           iti=itype2loc(itype(i))
9569         else
9570           iti=nloctyp
9571         endif
9572         itk1=itype2loc(itype(k+1))
9573         itl=itype2loc(itype(l))
9574         itj=itype2loc(itype(j))
9575         if (j.lt.nres-1) then
9576           itj1=itype2loc(itype(j+1))
9577         else
9578           itj1=nloctyp
9579         endif
9580 C A2 kernel(j-1)T A1T
9581         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9582      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9583      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9584 C Following matrices are needed only for 6-th order cumulants
9585         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9586      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9587         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9588      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9589      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9590         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9591      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9592      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9593      &   ADtEAderx(1,1,1,1,1,1))
9594         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9595      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9596      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9597      &   ADtEA1derx(1,1,1,1,1,1))
9598         ENDIF
9599 C End 6-th order cumulants
9600         call transpose2(EUgder(1,1,k),auxmat(1,1))
9601         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9602         call transpose2(EUg(1,1,k),auxmat(1,1))
9603         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9604         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9605         do iii=1,2
9606           do kkk=1,5
9607             do lll=1,3
9608               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9609      &          EAEAderx(1,1,lll,kkk,iii,1))
9610             enddo
9611           enddo
9612         enddo
9613 C A2T kernel(i+1)T A1
9614         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9615      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9616      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9617 C Following matrices are needed only for 6-th order cumulants
9618         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9619      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9620         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9621      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9622      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9623         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9624      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9625      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9626      &   ADtEAderx(1,1,1,1,1,2))
9627         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9628      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9629      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9630      &   ADtEA1derx(1,1,1,1,1,2))
9631         ENDIF
9632 C End 6-th order cumulants
9633         call transpose2(EUgder(1,1,j),auxmat(1,1))
9634         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9635         call transpose2(EUg(1,1,j),auxmat(1,1))
9636         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9637         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9638         do iii=1,2
9639           do kkk=1,5
9640             do lll=1,3
9641               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9642      &          EAEAderx(1,1,lll,kkk,iii,2))
9643             enddo
9644           enddo
9645         enddo
9646 C AEAb1 and AEAb2
9647 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9648 C They are needed only when the fifth- or the sixth-order cumulants are
9649 C indluded.
9650         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9651      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9652         call transpose2(AEA(1,1,1),auxmat(1,1))
9653         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9654         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9655         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9656         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9657         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9658         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9659         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9660         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9661         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9662         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9663         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9664         call transpose2(AEA(1,1,2),auxmat(1,1))
9665         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9666         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9667         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9668         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9669         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9670         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9671         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9672         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9673         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9674         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9675         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9676 C Calculate the Cartesian derivatives of the vectors.
9677         do iii=1,2
9678           do kkk=1,5
9679             do lll=1,3
9680               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9681               call matvec2(auxmat(1,1),b1(1,i),
9682      &          AEAb1derx(1,lll,kkk,iii,1,1))
9683               call matvec2(auxmat(1,1),Ub2(1,i),
9684      &          AEAb2derx(1,lll,kkk,iii,1,1))
9685               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9686      &          AEAb1derx(1,lll,kkk,iii,2,1))
9687               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9688      &          AEAb2derx(1,lll,kkk,iii,2,1))
9689               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9690               call matvec2(auxmat(1,1),b1(1,l),
9691      &          AEAb1derx(1,lll,kkk,iii,1,2))
9692               call matvec2(auxmat(1,1),Ub2(1,l),
9693      &          AEAb2derx(1,lll,kkk,iii,1,2))
9694               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9695      &          AEAb1derx(1,lll,kkk,iii,2,2))
9696               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9697      &          AEAb2derx(1,lll,kkk,iii,2,2))
9698             enddo
9699           enddo
9700         enddo
9701         ENDIF
9702 C End vectors
9703       endif
9704       return
9705       end
9706 C---------------------------------------------------------------------------
9707       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9708      &  KK,KKderg,AKA,AKAderg,AKAderx)
9709       implicit none
9710       integer nderg
9711       logical transp
9712       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9713      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9714      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9715       integer iii,kkk,lll
9716       integer jjj,mmm
9717       logical lprn
9718       common /kutas/ lprn
9719       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9720       do iii=1,nderg
9721         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9722      &    AKAderg(1,1,iii))
9723       enddo
9724 cd      if (lprn) write (2,*) 'In kernel'
9725       do kkk=1,5
9726 cd        if (lprn) write (2,*) 'kkk=',kkk
9727         do lll=1,3
9728           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9729      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9730 cd          if (lprn) then
9731 cd            write (2,*) 'lll=',lll
9732 cd            write (2,*) 'iii=1'
9733 cd            do jjj=1,2
9734 cd              write (2,'(3(2f10.5),5x)')
9735 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9736 cd            enddo
9737 cd          endif
9738           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9739      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9740 cd          if (lprn) then
9741 cd            write (2,*) 'lll=',lll
9742 cd            write (2,*) 'iii=2'
9743 cd            do jjj=1,2
9744 cd              write (2,'(3(2f10.5),5x)')
9745 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9746 cd            enddo
9747 cd          endif
9748         enddo
9749       enddo
9750       return
9751       end
9752 C---------------------------------------------------------------------------
9753       double precision function eello4(i,j,k,l,jj,kk)
9754       implicit real*8 (a-h,o-z)
9755       include 'DIMENSIONS'
9756       include 'COMMON.IOUNITS'
9757       include 'COMMON.CHAIN'
9758       include 'COMMON.DERIV'
9759       include 'COMMON.INTERACT'
9760       include 'COMMON.CONTACTS'
9761       include 'COMMON.TORSION'
9762       include 'COMMON.VAR'
9763       include 'COMMON.GEO'
9764       double precision pizda(2,2),ggg1(3),ggg2(3)
9765 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9766 cd        eello4=0.0d0
9767 cd        return
9768 cd      endif
9769 cd      print *,'eello4:',i,j,k,l,jj,kk
9770 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9771 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9772 cold      eij=facont_hb(jj,i)
9773 cold      ekl=facont_hb(kk,k)
9774 cold      ekont=eij*ekl
9775       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9776 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9777       gcorr_loc(k-1)=gcorr_loc(k-1)
9778      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9779       if (l.eq.j+1) then
9780         gcorr_loc(l-1)=gcorr_loc(l-1)
9781      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9782       else
9783         gcorr_loc(j-1)=gcorr_loc(j-1)
9784      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9785       endif
9786       do iii=1,2
9787         do kkk=1,5
9788           do lll=1,3
9789             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9790      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9791 cd            derx(lll,kkk,iii)=0.0d0
9792           enddo
9793         enddo
9794       enddo
9795 cd      gcorr_loc(l-1)=0.0d0
9796 cd      gcorr_loc(j-1)=0.0d0
9797 cd      gcorr_loc(k-1)=0.0d0
9798 cd      eel4=1.0d0
9799 cd      write (iout,*)'Contacts have occurred for peptide groups',
9800 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9801 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9802       if (j.lt.nres-1) then
9803         j1=j+1
9804         j2=j-1
9805       else
9806         j1=j-1
9807         j2=j-2
9808       endif
9809       if (l.lt.nres-1) then
9810         l1=l+1
9811         l2=l-1
9812       else
9813         l1=l-1
9814         l2=l-2
9815       endif
9816       do ll=1,3
9817 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9818 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9819         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9820         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9821 cgrad        ghalf=0.5d0*ggg1(ll)
9822         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9823         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9824         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9825         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9826         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9827         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9828 cgrad        ghalf=0.5d0*ggg2(ll)
9829         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9830         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9831         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9832         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9833         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9834         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9835       enddo
9836 cgrad      do m=i+1,j-1
9837 cgrad        do ll=1,3
9838 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9839 cgrad        enddo
9840 cgrad      enddo
9841 cgrad      do m=k+1,l-1
9842 cgrad        do ll=1,3
9843 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9844 cgrad        enddo
9845 cgrad      enddo
9846 cgrad      do m=i+2,j2
9847 cgrad        do ll=1,3
9848 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9849 cgrad        enddo
9850 cgrad      enddo
9851 cgrad      do m=k+2,l2
9852 cgrad        do ll=1,3
9853 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9854 cgrad        enddo
9855 cgrad      enddo
9856 cd      do iii=1,nres-3
9857 cd        write (2,*) iii,gcorr_loc(iii)
9858 cd      enddo
9859       eello4=ekont*eel4
9860 cd      write (2,*) 'ekont',ekont
9861 cd      write (iout,*) 'eello4',ekont*eel4
9862       return
9863       end
9864 C---------------------------------------------------------------------------
9865       double precision function eello5(i,j,k,l,jj,kk)
9866       implicit real*8 (a-h,o-z)
9867       include 'DIMENSIONS'
9868       include 'COMMON.IOUNITS'
9869       include 'COMMON.CHAIN'
9870       include 'COMMON.DERIV'
9871       include 'COMMON.INTERACT'
9872       include 'COMMON.CONTACTS'
9873       include 'COMMON.TORSION'
9874       include 'COMMON.VAR'
9875       include 'COMMON.GEO'
9876       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9877       double precision ggg1(3),ggg2(3)
9878 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9879 C                                                                              C
9880 C                            Parallel chains                                   C
9881 C                                                                              C
9882 C          o             o                   o             o                   C
9883 C         /l\           / \             \   / \           / \   /              C
9884 C        /   \         /   \             \ /   \         /   \ /               C
9885 C       j| o |l1       | o |              o| o |         | o |o                C
9886 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9887 C      \i/   \         /   \ /             /   \         /   \                 C
9888 C       o    k1             o                                                  C
9889 C         (I)          (II)                (III)          (IV)                 C
9890 C                                                                              C
9891 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9892 C                                                                              C
9893 C                            Antiparallel chains                               C
9894 C                                                                              C
9895 C          o             o                   o             o                   C
9896 C         /j\           / \             \   / \           / \   /              C
9897 C        /   \         /   \             \ /   \         /   \ /               C
9898 C      j1| o |l        | o |              o| o |         | o |o                C
9899 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9900 C      \i/   \         /   \ /             /   \         /   \                 C
9901 C       o     k1            o                                                  C
9902 C         (I)          (II)                (III)          (IV)                 C
9903 C                                                                              C
9904 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9905 C                                                                              C
9906 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9907 C                                                                              C
9908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9909 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9910 cd        eello5=0.0d0
9911 cd        return
9912 cd      endif
9913 cd      write (iout,*)
9914 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9915 cd     &   ' and',k,l
9916       itk=itype2loc(itype(k))
9917       itl=itype2loc(itype(l))
9918       itj=itype2loc(itype(j))
9919       eello5_1=0.0d0
9920       eello5_2=0.0d0
9921       eello5_3=0.0d0
9922       eello5_4=0.0d0
9923 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9924 cd     &   eel5_3_num,eel5_4_num)
9925       do iii=1,2
9926         do kkk=1,5
9927           do lll=1,3
9928             derx(lll,kkk,iii)=0.0d0
9929           enddo
9930         enddo
9931       enddo
9932 cd      eij=facont_hb(jj,i)
9933 cd      ekl=facont_hb(kk,k)
9934 cd      ekont=eij*ekl
9935 cd      write (iout,*)'Contacts have occurred for peptide groups',
9936 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9937 cd      goto 1111
9938 C Contribution from the graph I.
9939 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9940 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9941       call transpose2(EUg(1,1,k),auxmat(1,1))
9942       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9943       vv(1)=pizda(1,1)-pizda(2,2)
9944       vv(2)=pizda(1,2)+pizda(2,1)
9945       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9946      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9947 C Explicit gradient in virtual-dihedral angles.
9948       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9949      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9950      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9951       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9952       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9953       vv(1)=pizda(1,1)-pizda(2,2)
9954       vv(2)=pizda(1,2)+pizda(2,1)
9955       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9956      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9957      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9958       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9959       vv(1)=pizda(1,1)-pizda(2,2)
9960       vv(2)=pizda(1,2)+pizda(2,1)
9961       if (l.eq.j+1) then
9962         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9963      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9964      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9965       else
9966         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9967      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9968      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9969       endif
9970 C Cartesian gradient
9971       do iii=1,2
9972         do kkk=1,5
9973           do lll=1,3
9974             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9975      &        pizda(1,1))
9976             vv(1)=pizda(1,1)-pizda(2,2)
9977             vv(2)=pizda(1,2)+pizda(2,1)
9978             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9979      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9980      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9981           enddo
9982         enddo
9983       enddo
9984 c      goto 1112
9985 c1111  continue
9986 C Contribution from graph II
9987       call transpose2(EE(1,1,k),auxmat(1,1))
9988       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9989       vv(1)=pizda(1,1)+pizda(2,2)
9990       vv(2)=pizda(2,1)-pizda(1,2)
9991       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9992      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9993 C Explicit gradient in virtual-dihedral angles.
9994       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9995      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9996       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9997       vv(1)=pizda(1,1)+pizda(2,2)
9998       vv(2)=pizda(2,1)-pizda(1,2)
9999       if (l.eq.j+1) then
10000         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10001      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10002      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10003       else
10004         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10005      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10006      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10007       endif
10008 C Cartesian gradient
10009       do iii=1,2
10010         do kkk=1,5
10011           do lll=1,3
10012             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10013      &        pizda(1,1))
10014             vv(1)=pizda(1,1)+pizda(2,2)
10015             vv(2)=pizda(2,1)-pizda(1,2)
10016             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10017      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10018      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10019           enddo
10020         enddo
10021       enddo
10022 cd      goto 1112
10023 cd1111  continue
10024       if (l.eq.j+1) then
10025 cd        goto 1110
10026 C Parallel orientation
10027 C Contribution from graph III
10028         call transpose2(EUg(1,1,l),auxmat(1,1))
10029         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10030         vv(1)=pizda(1,1)-pizda(2,2)
10031         vv(2)=pizda(1,2)+pizda(2,1)
10032         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10033      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10034 C Explicit gradient in virtual-dihedral angles.
10035         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10036      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10037      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10038         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10039         vv(1)=pizda(1,1)-pizda(2,2)
10040         vv(2)=pizda(1,2)+pizda(2,1)
10041         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10042      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10043      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10044         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10045         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10046         vv(1)=pizda(1,1)-pizda(2,2)
10047         vv(2)=pizda(1,2)+pizda(2,1)
10048         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10049      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10050      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10051 C Cartesian gradient
10052         do iii=1,2
10053           do kkk=1,5
10054             do lll=1,3
10055               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10056      &          pizda(1,1))
10057               vv(1)=pizda(1,1)-pizda(2,2)
10058               vv(2)=pizda(1,2)+pizda(2,1)
10059               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10060      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10061      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10062             enddo
10063           enddo
10064         enddo
10065 cd        goto 1112
10066 C Contribution from graph IV
10067 cd1110    continue
10068         call transpose2(EE(1,1,l),auxmat(1,1))
10069         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10070         vv(1)=pizda(1,1)+pizda(2,2)
10071         vv(2)=pizda(2,1)-pizda(1,2)
10072         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10073      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10074 C Explicit gradient in virtual-dihedral angles.
10075         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10076      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10077         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10078         vv(1)=pizda(1,1)+pizda(2,2)
10079         vv(2)=pizda(2,1)-pizda(1,2)
10080         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10081      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10082      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10083 C Cartesian gradient
10084         do iii=1,2
10085           do kkk=1,5
10086             do lll=1,3
10087               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10088      &          pizda(1,1))
10089               vv(1)=pizda(1,1)+pizda(2,2)
10090               vv(2)=pizda(2,1)-pizda(1,2)
10091               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10092      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10093      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10094             enddo
10095           enddo
10096         enddo
10097       else
10098 C Antiparallel orientation
10099 C Contribution from graph III
10100 c        goto 1110
10101         call transpose2(EUg(1,1,j),auxmat(1,1))
10102         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10103         vv(1)=pizda(1,1)-pizda(2,2)
10104         vv(2)=pizda(1,2)+pizda(2,1)
10105         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10106      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10107 C Explicit gradient in virtual-dihedral angles.
10108         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10109      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10110      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10111         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10112         vv(1)=pizda(1,1)-pizda(2,2)
10113         vv(2)=pizda(1,2)+pizda(2,1)
10114         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10115      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10116      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10117         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10118         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10119         vv(1)=pizda(1,1)-pizda(2,2)
10120         vv(2)=pizda(1,2)+pizda(2,1)
10121         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10122      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10123      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10124 C Cartesian gradient
10125         do iii=1,2
10126           do kkk=1,5
10127             do lll=1,3
10128               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10129      &          pizda(1,1))
10130               vv(1)=pizda(1,1)-pizda(2,2)
10131               vv(2)=pizda(1,2)+pizda(2,1)
10132               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10133      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10134      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10135             enddo
10136           enddo
10137         enddo
10138 cd        goto 1112
10139 C Contribution from graph IV
10140 1110    continue
10141         call transpose2(EE(1,1,j),auxmat(1,1))
10142         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10143         vv(1)=pizda(1,1)+pizda(2,2)
10144         vv(2)=pizda(2,1)-pizda(1,2)
10145         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10146      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10147 C Explicit gradient in virtual-dihedral angles.
10148         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10149      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10150         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10151         vv(1)=pizda(1,1)+pizda(2,2)
10152         vv(2)=pizda(2,1)-pizda(1,2)
10153         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10154      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10155      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10156 C Cartesian gradient
10157         do iii=1,2
10158           do kkk=1,5
10159             do lll=1,3
10160               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10161      &          pizda(1,1))
10162               vv(1)=pizda(1,1)+pizda(2,2)
10163               vv(2)=pizda(2,1)-pizda(1,2)
10164               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10165      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10166      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10167             enddo
10168           enddo
10169         enddo
10170       endif
10171 1112  continue
10172       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10173 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10174 cd        write (2,*) 'ijkl',i,j,k,l
10175 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10176 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10177 cd      endif
10178 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10179 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10180 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10181 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10182       if (j.lt.nres-1) then
10183         j1=j+1
10184         j2=j-1
10185       else
10186         j1=j-1
10187         j2=j-2
10188       endif
10189       if (l.lt.nres-1) then
10190         l1=l+1
10191         l2=l-1
10192       else
10193         l1=l-1
10194         l2=l-2
10195       endif
10196 cd      eij=1.0d0
10197 cd      ekl=1.0d0
10198 cd      ekont=1.0d0
10199 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10200 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10201 C        summed up outside the subrouine as for the other subroutines
10202 C        handling long-range interactions. The old code is commented out
10203 C        with "cgrad" to keep track of changes.
10204       do ll=1,3
10205 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10206 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10207         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10208         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10209 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10210 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10211 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10212 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10213 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10214 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10215 c     &   gradcorr5ij,
10216 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10217 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10218 cgrad        ghalf=0.5d0*ggg1(ll)
10219 cd        ghalf=0.0d0
10220         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10221         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10222         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10223         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10224         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10225         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10226 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10227 cgrad        ghalf=0.5d0*ggg2(ll)
10228 cd        ghalf=0.0d0
10229         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10230         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10231         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10232         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10233         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10234         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10235       enddo
10236 cd      goto 1112
10237 cgrad      do m=i+1,j-1
10238 cgrad        do ll=1,3
10239 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10240 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10241 cgrad        enddo
10242 cgrad      enddo
10243 cgrad      do m=k+1,l-1
10244 cgrad        do ll=1,3
10245 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10246 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10247 cgrad        enddo
10248 cgrad      enddo
10249 c1112  continue
10250 cgrad      do m=i+2,j2
10251 cgrad        do ll=1,3
10252 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10253 cgrad        enddo
10254 cgrad      enddo
10255 cgrad      do m=k+2,l2
10256 cgrad        do ll=1,3
10257 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10258 cgrad        enddo
10259 cgrad      enddo
10260 cd      do iii=1,nres-3
10261 cd        write (2,*) iii,g_corr5_loc(iii)
10262 cd      enddo
10263       eello5=ekont*eel5
10264 cd      write (2,*) 'ekont',ekont
10265 cd      write (iout,*) 'eello5',ekont*eel5
10266       return
10267       end
10268 c--------------------------------------------------------------------------
10269       double precision function eello6(i,j,k,l,jj,kk)
10270       implicit real*8 (a-h,o-z)
10271       include 'DIMENSIONS'
10272       include 'COMMON.IOUNITS'
10273       include 'COMMON.CHAIN'
10274       include 'COMMON.DERIV'
10275       include 'COMMON.INTERACT'
10276       include 'COMMON.CONTACTS'
10277       include 'COMMON.TORSION'
10278       include 'COMMON.VAR'
10279       include 'COMMON.GEO'
10280       include 'COMMON.FFIELD'
10281       double precision ggg1(3),ggg2(3)
10282 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10283 cd        eello6=0.0d0
10284 cd        return
10285 cd      endif
10286 cd      write (iout,*)
10287 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10288 cd     &   ' and',k,l
10289       eello6_1=0.0d0
10290       eello6_2=0.0d0
10291       eello6_3=0.0d0
10292       eello6_4=0.0d0
10293       eello6_5=0.0d0
10294       eello6_6=0.0d0
10295 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10296 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10297       do iii=1,2
10298         do kkk=1,5
10299           do lll=1,3
10300             derx(lll,kkk,iii)=0.0d0
10301           enddo
10302         enddo
10303       enddo
10304 cd      eij=facont_hb(jj,i)
10305 cd      ekl=facont_hb(kk,k)
10306 cd      ekont=eij*ekl
10307 cd      eij=1.0d0
10308 cd      ekl=1.0d0
10309 cd      ekont=1.0d0
10310       if (l.eq.j+1) then
10311         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10312         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10313         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10314         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10315         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10316         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10317       else
10318         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10319         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10320         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10321         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10322         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10323           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10324         else
10325           eello6_5=0.0d0
10326         endif
10327         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10328       endif
10329 C If turn contributions are considered, they will be handled separately.
10330       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10331 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10332 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10333 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10334 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10335 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10336 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10337 cd      goto 1112
10338       if (j.lt.nres-1) then
10339         j1=j+1
10340         j2=j-1
10341       else
10342         j1=j-1
10343         j2=j-2
10344       endif
10345       if (l.lt.nres-1) then
10346         l1=l+1
10347         l2=l-1
10348       else
10349         l1=l-1
10350         l2=l-2
10351       endif
10352       do ll=1,3
10353 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10354 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10355 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10356 cgrad        ghalf=0.5d0*ggg1(ll)
10357 cd        ghalf=0.0d0
10358         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10359         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10360         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10361         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10362         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10363         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10364         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10365         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10366 cgrad        ghalf=0.5d0*ggg2(ll)
10367 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10368 cd        ghalf=0.0d0
10369         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10370         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10371         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10372         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10373         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10374         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10375       enddo
10376 cd      goto 1112
10377 cgrad      do m=i+1,j-1
10378 cgrad        do ll=1,3
10379 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10380 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10381 cgrad        enddo
10382 cgrad      enddo
10383 cgrad      do m=k+1,l-1
10384 cgrad        do ll=1,3
10385 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10386 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10387 cgrad        enddo
10388 cgrad      enddo
10389 cgrad1112  continue
10390 cgrad      do m=i+2,j2
10391 cgrad        do ll=1,3
10392 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10393 cgrad        enddo
10394 cgrad      enddo
10395 cgrad      do m=k+2,l2
10396 cgrad        do ll=1,3
10397 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10398 cgrad        enddo
10399 cgrad      enddo
10400 cd      do iii=1,nres-3
10401 cd        write (2,*) iii,g_corr6_loc(iii)
10402 cd      enddo
10403       eello6=ekont*eel6
10404 cd      write (2,*) 'ekont',ekont
10405 cd      write (iout,*) 'eello6',ekont*eel6
10406       return
10407       end
10408 c--------------------------------------------------------------------------
10409       double precision function eello6_graph1(i,j,k,l,imat,swap)
10410       implicit real*8 (a-h,o-z)
10411       include 'DIMENSIONS'
10412       include 'COMMON.IOUNITS'
10413       include 'COMMON.CHAIN'
10414       include 'COMMON.DERIV'
10415       include 'COMMON.INTERACT'
10416       include 'COMMON.CONTACTS'
10417       include 'COMMON.TORSION'
10418       include 'COMMON.VAR'
10419       include 'COMMON.GEO'
10420       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10421       logical swap
10422       logical lprn
10423       common /kutas/ lprn
10424 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10425 C                                                                              C
10426 C      Parallel       Antiparallel                                             C
10427 C                                                                              C
10428 C          o             o                                                     C
10429 C         /l\           /j\                                                    C
10430 C        /   \         /   \                                                   C
10431 C       /| o |         | o |\                                                  C
10432 C     \ j|/k\|  /   \  |/k\|l /                                                C
10433 C      \ /   \ /     \ /   \ /                                                 C
10434 C       o     o       o     o                                                  C
10435 C       i             i                                                        C
10436 C                                                                              C
10437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10438       itk=itype2loc(itype(k))
10439       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10440       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10441       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10442       call transpose2(EUgC(1,1,k),auxmat(1,1))
10443       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10444       vv1(1)=pizda1(1,1)-pizda1(2,2)
10445       vv1(2)=pizda1(1,2)+pizda1(2,1)
10446       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10447       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10448       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10449       s5=scalar2(vv(1),Dtobr2(1,i))
10450 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10451       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10452       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10453      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10454      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10455      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10456      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10457      & +scalar2(vv(1),Dtobr2der(1,i)))
10458       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10459       vv1(1)=pizda1(1,1)-pizda1(2,2)
10460       vv1(2)=pizda1(1,2)+pizda1(2,1)
10461       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10462       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10463       if (l.eq.j+1) then
10464         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10465      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10466      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10467      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10468      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10469       else
10470         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10471      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10472      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10473      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10474      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10475       endif
10476       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10477       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10478       vv1(1)=pizda1(1,1)-pizda1(2,2)
10479       vv1(2)=pizda1(1,2)+pizda1(2,1)
10480       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10481      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10482      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10483      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10484       do iii=1,2
10485         if (swap) then
10486           ind=3-iii
10487         else
10488           ind=iii
10489         endif
10490         do kkk=1,5
10491           do lll=1,3
10492             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10493             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10494             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10495             call transpose2(EUgC(1,1,k),auxmat(1,1))
10496             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10497      &        pizda1(1,1))
10498             vv1(1)=pizda1(1,1)-pizda1(2,2)
10499             vv1(2)=pizda1(1,2)+pizda1(2,1)
10500             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10501             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10502      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10503             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10504      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10505             s5=scalar2(vv(1),Dtobr2(1,i))
10506             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10507           enddo
10508         enddo
10509       enddo
10510       return
10511       end
10512 c----------------------------------------------------------------------------
10513       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10514       implicit real*8 (a-h,o-z)
10515       include 'DIMENSIONS'
10516       include 'COMMON.IOUNITS'
10517       include 'COMMON.CHAIN'
10518       include 'COMMON.DERIV'
10519       include 'COMMON.INTERACT'
10520       include 'COMMON.CONTACTS'
10521       include 'COMMON.TORSION'
10522       include 'COMMON.VAR'
10523       include 'COMMON.GEO'
10524       logical swap
10525       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10526      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10527       logical lprn
10528       common /kutas/ lprn
10529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10530 C                                                                              C
10531 C      Parallel       Antiparallel                                             C
10532 C                                                                              C
10533 C          o             o                                                     C
10534 C     \   /l\           /j\   /                                                C
10535 C      \ /   \         /   \ /                                                 C
10536 C       o| o |         | o |o                                                  C
10537 C     \ j|/k\|      \  |/k\|l                                                  C
10538 C      \ /   \       \ /   \                                                   C
10539 C       o             o                                                        C
10540 C       i             i                                                        C
10541 C                                                                              C
10542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10543 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10544 C AL 7/4/01 s1 would occur in the sixth-order moment,
10545 C           but not in a cluster cumulant
10546 #ifdef MOMENT
10547       s1=dip(1,jj,i)*dip(1,kk,k)
10548 #endif
10549       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10550       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10551       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10552       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10553       call transpose2(EUg(1,1,k),auxmat(1,1))
10554       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10555       vv(1)=pizda(1,1)-pizda(2,2)
10556       vv(2)=pizda(1,2)+pizda(2,1)
10557       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10558 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10559 #ifdef MOMENT
10560       eello6_graph2=-(s1+s2+s3+s4)
10561 #else
10562       eello6_graph2=-(s2+s3+s4)
10563 #endif
10564 c      eello6_graph2=-s3
10565 C Derivatives in gamma(i-1)
10566       if (i.gt.1) then
10567 #ifdef MOMENT
10568         s1=dipderg(1,jj,i)*dip(1,kk,k)
10569 #endif
10570         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10571         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10572         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10573         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10574 #ifdef MOMENT
10575         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10576 #else
10577         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10578 #endif
10579 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10580       endif
10581 C Derivatives in gamma(k-1)
10582 #ifdef MOMENT
10583       s1=dip(1,jj,i)*dipderg(1,kk,k)
10584 #endif
10585       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10586       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10587       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10588       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10589       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10590       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10591       vv(1)=pizda(1,1)-pizda(2,2)
10592       vv(2)=pizda(1,2)+pizda(2,1)
10593       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10594 #ifdef MOMENT
10595       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10596 #else
10597       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10598 #endif
10599 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10600 C Derivatives in gamma(j-1) or gamma(l-1)
10601       if (j.gt.1) then
10602 #ifdef MOMENT
10603         s1=dipderg(3,jj,i)*dip(1,kk,k)
10604 #endif
10605         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10606         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10607         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10608         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10609         vv(1)=pizda(1,1)-pizda(2,2)
10610         vv(2)=pizda(1,2)+pizda(2,1)
10611         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10612 #ifdef MOMENT
10613         if (swap) then
10614           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10615         else
10616           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10617         endif
10618 #endif
10619         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10620 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10621       endif
10622 C Derivatives in gamma(l-1) or gamma(j-1)
10623       if (l.gt.1) then
10624 #ifdef MOMENT
10625         s1=dip(1,jj,i)*dipderg(3,kk,k)
10626 #endif
10627         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10628         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10629         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10630         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10631         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10632         vv(1)=pizda(1,1)-pizda(2,2)
10633         vv(2)=pizda(1,2)+pizda(2,1)
10634         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10635 #ifdef MOMENT
10636         if (swap) then
10637           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10638         else
10639           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10640         endif
10641 #endif
10642         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10643 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10644       endif
10645 C Cartesian derivatives.
10646       if (lprn) then
10647         write (2,*) 'In eello6_graph2'
10648         do iii=1,2
10649           write (2,*) 'iii=',iii
10650           do kkk=1,5
10651             write (2,*) 'kkk=',kkk
10652             do jjj=1,2
10653               write (2,'(3(2f10.5),5x)')
10654      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10655             enddo
10656           enddo
10657         enddo
10658       endif
10659       do iii=1,2
10660         do kkk=1,5
10661           do lll=1,3
10662 #ifdef MOMENT
10663             if (iii.eq.1) then
10664               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10665             else
10666               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10667             endif
10668 #endif
10669             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10670      &        auxvec(1))
10671             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10672             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10673      &        auxvec(1))
10674             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10675             call transpose2(EUg(1,1,k),auxmat(1,1))
10676             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10677      &        pizda(1,1))
10678             vv(1)=pizda(1,1)-pizda(2,2)
10679             vv(2)=pizda(1,2)+pizda(2,1)
10680             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10681 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10682 #ifdef MOMENT
10683             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10684 #else
10685             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10686 #endif
10687             if (swap) then
10688               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10689             else
10690               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10691             endif
10692           enddo
10693         enddo
10694       enddo
10695       return
10696       end
10697 c----------------------------------------------------------------------------
10698       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10699       implicit real*8 (a-h,o-z)
10700       include 'DIMENSIONS'
10701       include 'COMMON.IOUNITS'
10702       include 'COMMON.CHAIN'
10703       include 'COMMON.DERIV'
10704       include 'COMMON.INTERACT'
10705       include 'COMMON.CONTACTS'
10706       include 'COMMON.TORSION'
10707       include 'COMMON.VAR'
10708       include 'COMMON.GEO'
10709       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10710       logical swap
10711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10712 C                                                                              C
10713 C      Parallel       Antiparallel                                             C
10714 C                                                                              C
10715 C          o             o                                                     C
10716 C         /l\   /   \   /j\                                                    C
10717 C        /   \ /     \ /   \                                                   C
10718 C       /| o |o       o| o |\                                                  C
10719 C       j|/k\|  /      |/k\|l /                                                C
10720 C        /   \ /       /   \ /                                                 C
10721 C       /     o       /     o                                                  C
10722 C       i             i                                                        C
10723 C                                                                              C
10724 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10725 C
10726 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10727 C           energy moment and not to the cluster cumulant.
10728       iti=itortyp(itype(i))
10729       if (j.lt.nres-1) then
10730         itj1=itype2loc(itype(j+1))
10731       else
10732         itj1=nloctyp
10733       endif
10734       itk=itype2loc(itype(k))
10735       itk1=itype2loc(itype(k+1))
10736       if (l.lt.nres-1) then
10737         itl1=itype2loc(itype(l+1))
10738       else
10739         itl1=nloctyp
10740       endif
10741 #ifdef MOMENT
10742       s1=dip(4,jj,i)*dip(4,kk,k)
10743 #endif
10744       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10745       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10746       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10747       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10748       call transpose2(EE(1,1,k),auxmat(1,1))
10749       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10750       vv(1)=pizda(1,1)+pizda(2,2)
10751       vv(2)=pizda(2,1)-pizda(1,2)
10752       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10753 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10754 cd     & "sum",-(s2+s3+s4)
10755 #ifdef MOMENT
10756       eello6_graph3=-(s1+s2+s3+s4)
10757 #else
10758       eello6_graph3=-(s2+s3+s4)
10759 #endif
10760 c      eello6_graph3=-s4
10761 C Derivatives in gamma(k-1)
10762       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10763       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10764       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10765       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10766 C Derivatives in gamma(l-1)
10767       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10768       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10769       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10770       vv(1)=pizda(1,1)+pizda(2,2)
10771       vv(2)=pizda(2,1)-pizda(1,2)
10772       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10773       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10774 C Cartesian derivatives.
10775       do iii=1,2
10776         do kkk=1,5
10777           do lll=1,3
10778 #ifdef MOMENT
10779             if (iii.eq.1) then
10780               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10781             else
10782               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10783             endif
10784 #endif
10785             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10786      &        auxvec(1))
10787             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10788             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10789      &        auxvec(1))
10790             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10791             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10792      &        pizda(1,1))
10793             vv(1)=pizda(1,1)+pizda(2,2)
10794             vv(2)=pizda(2,1)-pizda(1,2)
10795             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10796 #ifdef MOMENT
10797             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10798 #else
10799             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10800 #endif
10801             if (swap) then
10802               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10803             else
10804               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10805             endif
10806 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10807           enddo
10808         enddo
10809       enddo
10810       return
10811       end
10812 c----------------------------------------------------------------------------
10813       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10814       implicit real*8 (a-h,o-z)
10815       include 'DIMENSIONS'
10816       include 'COMMON.IOUNITS'
10817       include 'COMMON.CHAIN'
10818       include 'COMMON.DERIV'
10819       include 'COMMON.INTERACT'
10820       include 'COMMON.CONTACTS'
10821       include 'COMMON.TORSION'
10822       include 'COMMON.VAR'
10823       include 'COMMON.GEO'
10824       include 'COMMON.FFIELD'
10825       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10826      & auxvec1(2),auxmat1(2,2)
10827       logical swap
10828 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10829 C                                                                              C
10830 C      Parallel       Antiparallel                                             C
10831 C                                                                              C
10832 C          o             o                                                     C
10833 C         /l\   /   \   /j\                                                    C
10834 C        /   \ /     \ /   \                                                   C
10835 C       /| o |o       o| o |\                                                  C
10836 C     \ j|/k\|      \  |/k\|l                                                  C
10837 C      \ /   \       \ /   \                                                   C
10838 C       o     \       o     \                                                  C
10839 C       i             i                                                        C
10840 C                                                                              C
10841 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10842 C
10843 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10844 C           energy moment and not to the cluster cumulant.
10845 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10846       iti=itype2loc(itype(i))
10847       itj=itype2loc(itype(j))
10848       if (j.lt.nres-1) then
10849         itj1=itype2loc(itype(j+1))
10850       else
10851         itj1=nloctyp
10852       endif
10853       itk=itype2loc(itype(k))
10854       if (k.lt.nres-1) then
10855         itk1=itype2loc(itype(k+1))
10856       else
10857         itk1=nloctyp
10858       endif
10859       itl=itype2loc(itype(l))
10860       if (l.lt.nres-1) then
10861         itl1=itype2loc(itype(l+1))
10862       else
10863         itl1=nloctyp
10864       endif
10865 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10866 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10867 cd     & ' itl',itl,' itl1',itl1
10868 #ifdef MOMENT
10869       if (imat.eq.1) then
10870         s1=dip(3,jj,i)*dip(3,kk,k)
10871       else
10872         s1=dip(2,jj,j)*dip(2,kk,l)
10873       endif
10874 #endif
10875       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10876       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10877       if (j.eq.l+1) then
10878         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10879         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10880       else
10881         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10882         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10883       endif
10884       call transpose2(EUg(1,1,k),auxmat(1,1))
10885       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10886       vv(1)=pizda(1,1)-pizda(2,2)
10887       vv(2)=pizda(2,1)+pizda(1,2)
10888       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10889 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10890 #ifdef MOMENT
10891       eello6_graph4=-(s1+s2+s3+s4)
10892 #else
10893       eello6_graph4=-(s2+s3+s4)
10894 #endif
10895 C Derivatives in gamma(i-1)
10896       if (i.gt.1) then
10897 #ifdef MOMENT
10898         if (imat.eq.1) then
10899           s1=dipderg(2,jj,i)*dip(3,kk,k)
10900         else
10901           s1=dipderg(4,jj,j)*dip(2,kk,l)
10902         endif
10903 #endif
10904         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10905         if (j.eq.l+1) then
10906           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10907           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10908         else
10909           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10910           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10911         endif
10912         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10913         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10914 cd          write (2,*) 'turn6 derivatives'
10915 #ifdef MOMENT
10916           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10917 #else
10918           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10919 #endif
10920         else
10921 #ifdef MOMENT
10922           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10923 #else
10924           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10925 #endif
10926         endif
10927       endif
10928 C Derivatives in gamma(k-1)
10929 #ifdef MOMENT
10930       if (imat.eq.1) then
10931         s1=dip(3,jj,i)*dipderg(2,kk,k)
10932       else
10933         s1=dip(2,jj,j)*dipderg(4,kk,l)
10934       endif
10935 #endif
10936       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10937       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10938       if (j.eq.l+1) then
10939         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10940         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10941       else
10942         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10943         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10944       endif
10945       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10946       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10947       vv(1)=pizda(1,1)-pizda(2,2)
10948       vv(2)=pizda(2,1)+pizda(1,2)
10949       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10950       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10951 #ifdef MOMENT
10952         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10953 #else
10954         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10955 #endif
10956       else
10957 #ifdef MOMENT
10958         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10959 #else
10960         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10961 #endif
10962       endif
10963 C Derivatives in gamma(j-1) or gamma(l-1)
10964       if (l.eq.j+1 .and. l.gt.1) then
10965         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10966         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10967         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10968         vv(1)=pizda(1,1)-pizda(2,2)
10969         vv(2)=pizda(2,1)+pizda(1,2)
10970         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10971         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10972       else if (j.gt.1) then
10973         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10974         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10975         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10976         vv(1)=pizda(1,1)-pizda(2,2)
10977         vv(2)=pizda(2,1)+pizda(1,2)
10978         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10979         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10980           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10981         else
10982           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10983         endif
10984       endif
10985 C Cartesian derivatives.
10986       do iii=1,2
10987         do kkk=1,5
10988           do lll=1,3
10989 #ifdef MOMENT
10990             if (iii.eq.1) then
10991               if (imat.eq.1) then
10992                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10993               else
10994                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10995               endif
10996             else
10997               if (imat.eq.1) then
10998                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10999               else
11000                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11001               endif
11002             endif
11003 #endif
11004             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11005      &        auxvec(1))
11006             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11007             if (j.eq.l+1) then
11008               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11009      &          b1(1,j+1),auxvec(1))
11010               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11011             else
11012               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11013      &          b1(1,l+1),auxvec(1))
11014               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11015             endif
11016             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11017      &        pizda(1,1))
11018             vv(1)=pizda(1,1)-pizda(2,2)
11019             vv(2)=pizda(2,1)+pizda(1,2)
11020             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11021             if (swap) then
11022               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11023 #ifdef MOMENT
11024                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11025      &             -(s1+s2+s4)
11026 #else
11027                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11028      &             -(s2+s4)
11029 #endif
11030                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11031               else
11032 #ifdef MOMENT
11033                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11034 #else
11035                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11036 #endif
11037                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11038               endif
11039             else
11040 #ifdef MOMENT
11041               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11042 #else
11043               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11044 #endif
11045               if (l.eq.j+1) then
11046                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11047               else
11048                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11049               endif
11050             endif
11051           enddo
11052         enddo
11053       enddo
11054       return
11055       end
11056 c----------------------------------------------------------------------------
11057       double precision function eello_turn6(i,jj,kk)
11058       implicit real*8 (a-h,o-z)
11059       include 'DIMENSIONS'
11060       include 'COMMON.IOUNITS'
11061       include 'COMMON.CHAIN'
11062       include 'COMMON.DERIV'
11063       include 'COMMON.INTERACT'
11064       include 'COMMON.CONTACTS'
11065       include 'COMMON.TORSION'
11066       include 'COMMON.VAR'
11067       include 'COMMON.GEO'
11068       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11069      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11070      &  ggg1(3),ggg2(3)
11071       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11072      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11073 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11074 C           the respective energy moment and not to the cluster cumulant.
11075       s1=0.0d0
11076       s8=0.0d0
11077       s13=0.0d0
11078 c
11079       eello_turn6=0.0d0
11080       j=i+4
11081       k=i+1
11082       l=i+3
11083       iti=itype2loc(itype(i))
11084       itk=itype2loc(itype(k))
11085       itk1=itype2loc(itype(k+1))
11086       itl=itype2loc(itype(l))
11087       itj=itype2loc(itype(j))
11088 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11089 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11090 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11091 cd        eello6=0.0d0
11092 cd        return
11093 cd      endif
11094 cd      write (iout,*)
11095 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11096 cd     &   ' and',k,l
11097 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11098       do iii=1,2
11099         do kkk=1,5
11100           do lll=1,3
11101             derx_turn(lll,kkk,iii)=0.0d0
11102           enddo
11103         enddo
11104       enddo
11105 cd      eij=1.0d0
11106 cd      ekl=1.0d0
11107 cd      ekont=1.0d0
11108       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11109 cd      eello6_5=0.0d0
11110 cd      write (2,*) 'eello6_5',eello6_5
11111 #ifdef MOMENT
11112       call transpose2(AEA(1,1,1),auxmat(1,1))
11113       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11114       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11115       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11116 #endif
11117       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11118       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11119       s2 = scalar2(b1(1,k),vtemp1(1))
11120 #ifdef MOMENT
11121       call transpose2(AEA(1,1,2),atemp(1,1))
11122       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11123       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11124       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11125 #endif
11126       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11127       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11128       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11129 #ifdef MOMENT
11130       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11131       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11132       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11133       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11134       ss13 = scalar2(b1(1,k),vtemp4(1))
11135       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11136 #endif
11137 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11138 c      s1=0.0d0
11139 c      s2=0.0d0
11140 c      s8=0.0d0
11141 c      s12=0.0d0
11142 c      s13=0.0d0
11143       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11144 C Derivatives in gamma(i+2)
11145       s1d =0.0d0
11146       s8d =0.0d0
11147 #ifdef MOMENT
11148       call transpose2(AEA(1,1,1),auxmatd(1,1))
11149       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11150       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11151       call transpose2(AEAderg(1,1,2),atempd(1,1))
11152       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11153       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11154 #endif
11155       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11156       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11157       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11158 c      s1d=0.0d0
11159 c      s2d=0.0d0
11160 c      s8d=0.0d0
11161 c      s12d=0.0d0
11162 c      s13d=0.0d0
11163       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11164 C Derivatives in gamma(i+3)
11165 #ifdef MOMENT
11166       call transpose2(AEA(1,1,1),auxmatd(1,1))
11167       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11168       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11169       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11170 #endif
11171       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11172       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11173       s2d = scalar2(b1(1,k),vtemp1d(1))
11174 #ifdef MOMENT
11175       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11176       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11177 #endif
11178       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11179 #ifdef MOMENT
11180       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11181       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11182       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11183 #endif
11184 c      s1d=0.0d0
11185 c      s2d=0.0d0
11186 c      s8d=0.0d0
11187 c      s12d=0.0d0
11188 c      s13d=0.0d0
11189 #ifdef MOMENT
11190       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11191      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11192 #else
11193       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11194      &               -0.5d0*ekont*(s2d+s12d)
11195 #endif
11196 C Derivatives in gamma(i+4)
11197       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11198       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11199       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11200 #ifdef MOMENT
11201       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11202       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11203       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11204 #endif
11205 c      s1d=0.0d0
11206 c      s2d=0.0d0
11207 c      s8d=0.0d0
11208 C      s12d=0.0d0
11209 c      s13d=0.0d0
11210 #ifdef MOMENT
11211       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11212 #else
11213       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11214 #endif
11215 C Derivatives in gamma(i+5)
11216 #ifdef MOMENT
11217       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11218       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11219       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11220 #endif
11221       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11222       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11223       s2d = scalar2(b1(1,k),vtemp1d(1))
11224 #ifdef MOMENT
11225       call transpose2(AEA(1,1,2),atempd(1,1))
11226       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11227       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11228 #endif
11229       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11230       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11231 #ifdef MOMENT
11232       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11233       ss13d = scalar2(b1(1,k),vtemp4d(1))
11234       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11235 #endif
11236 c      s1d=0.0d0
11237 c      s2d=0.0d0
11238 c      s8d=0.0d0
11239 c      s12d=0.0d0
11240 c      s13d=0.0d0
11241 #ifdef MOMENT
11242       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11243      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11244 #else
11245       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11246      &               -0.5d0*ekont*(s2d+s12d)
11247 #endif
11248 C Cartesian derivatives
11249       do iii=1,2
11250         do kkk=1,5
11251           do lll=1,3
11252 #ifdef MOMENT
11253             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11254             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11255             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11256 #endif
11257             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11258             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11259      &          vtemp1d(1))
11260             s2d = scalar2(b1(1,k),vtemp1d(1))
11261 #ifdef MOMENT
11262             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11263             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11264             s8d = -(atempd(1,1)+atempd(2,2))*
11265      &           scalar2(cc(1,1,itl),vtemp2(1))
11266 #endif
11267             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11268      &           auxmatd(1,1))
11269             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11270             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11271 c      s1d=0.0d0
11272 c      s2d=0.0d0
11273 c      s8d=0.0d0
11274 c      s12d=0.0d0
11275 c      s13d=0.0d0
11276 #ifdef MOMENT
11277             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11278      &        - 0.5d0*(s1d+s2d)
11279 #else
11280             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11281      &        - 0.5d0*s2d
11282 #endif
11283 #ifdef MOMENT
11284             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11285      &        - 0.5d0*(s8d+s12d)
11286 #else
11287             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11288      &        - 0.5d0*s12d
11289 #endif
11290           enddo
11291         enddo
11292       enddo
11293 #ifdef MOMENT
11294       do kkk=1,5
11295         do lll=1,3
11296           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11297      &      achuj_tempd(1,1))
11298           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11299           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11300           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11301           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11302           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11303      &      vtemp4d(1))
11304           ss13d = scalar2(b1(1,k),vtemp4d(1))
11305           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11306           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11307         enddo
11308       enddo
11309 #endif
11310 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11311 cd     &  16*eel_turn6_num
11312 cd      goto 1112
11313       if (j.lt.nres-1) then
11314         j1=j+1
11315         j2=j-1
11316       else
11317         j1=j-1
11318         j2=j-2
11319       endif
11320       if (l.lt.nres-1) then
11321         l1=l+1
11322         l2=l-1
11323       else
11324         l1=l-1
11325         l2=l-2
11326       endif
11327       do ll=1,3
11328 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11329 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11330 cgrad        ghalf=0.5d0*ggg1(ll)
11331 cd        ghalf=0.0d0
11332         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11333         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11334         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11335      &    +ekont*derx_turn(ll,2,1)
11336         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11337         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11338      &    +ekont*derx_turn(ll,4,1)
11339         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11340         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11341         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11342 cgrad        ghalf=0.5d0*ggg2(ll)
11343 cd        ghalf=0.0d0
11344         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11345      &    +ekont*derx_turn(ll,2,2)
11346         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11347         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11348      &    +ekont*derx_turn(ll,4,2)
11349         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11350         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11351         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11352       enddo
11353 cd      goto 1112
11354 cgrad      do m=i+1,j-1
11355 cgrad        do ll=1,3
11356 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11357 cgrad        enddo
11358 cgrad      enddo
11359 cgrad      do m=k+1,l-1
11360 cgrad        do ll=1,3
11361 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11362 cgrad        enddo
11363 cgrad      enddo
11364 cgrad1112  continue
11365 cgrad      do m=i+2,j2
11366 cgrad        do ll=1,3
11367 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11368 cgrad        enddo
11369 cgrad      enddo
11370 cgrad      do m=k+2,l2
11371 cgrad        do ll=1,3
11372 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11373 cgrad        enddo
11374 cgrad      enddo
11375 cd      do iii=1,nres-3
11376 cd        write (2,*) iii,g_corr6_loc(iii)
11377 cd      enddo
11378       eello_turn6=ekont*eel_turn6
11379 cd      write (2,*) 'ekont',ekont
11380 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11381       return
11382       end
11383
11384 C-----------------------------------------------------------------------------
11385       double precision function scalar(u,v)
11386 !DIR$ INLINEALWAYS scalar
11387 #ifndef OSF
11388 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11389 #endif
11390       implicit none
11391       double precision u(3),v(3)
11392 cd      double precision sc
11393 cd      integer i
11394 cd      sc=0.0d0
11395 cd      do i=1,3
11396 cd        sc=sc+u(i)*v(i)
11397 cd      enddo
11398 cd      scalar=sc
11399
11400       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11401       return
11402       end
11403 crc-------------------------------------------------
11404       SUBROUTINE MATVEC2(A1,V1,V2)
11405 !DIR$ INLINEALWAYS MATVEC2
11406 #ifndef OSF
11407 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11408 #endif
11409       implicit real*8 (a-h,o-z)
11410       include 'DIMENSIONS'
11411       DIMENSION A1(2,2),V1(2),V2(2)
11412 c      DO 1 I=1,2
11413 c        VI=0.0
11414 c        DO 3 K=1,2
11415 c    3     VI=VI+A1(I,K)*V1(K)
11416 c        Vaux(I)=VI
11417 c    1 CONTINUE
11418
11419       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11420       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11421
11422       v2(1)=vaux1
11423       v2(2)=vaux2
11424       END
11425 C---------------------------------------
11426       SUBROUTINE MATMAT2(A1,A2,A3)
11427 #ifndef OSF
11428 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11429 #endif
11430       implicit real*8 (a-h,o-z)
11431       include 'DIMENSIONS'
11432       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11433 c      DIMENSION AI3(2,2)
11434 c        DO  J=1,2
11435 c          A3IJ=0.0
11436 c          DO K=1,2
11437 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11438 c          enddo
11439 c          A3(I,J)=A3IJ
11440 c       enddo
11441 c      enddo
11442
11443       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11444       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11445       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11446       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11447
11448       A3(1,1)=AI3_11
11449       A3(2,1)=AI3_21
11450       A3(1,2)=AI3_12
11451       A3(2,2)=AI3_22
11452       END
11453
11454 c-------------------------------------------------------------------------
11455       double precision function scalar2(u,v)
11456 !DIR$ INLINEALWAYS scalar2
11457       implicit none
11458       double precision u(2),v(2)
11459       double precision sc
11460       integer i
11461       scalar2=u(1)*v(1)+u(2)*v(2)
11462       return
11463       end
11464
11465 C-----------------------------------------------------------------------------
11466
11467       subroutine transpose2(a,at)
11468 !DIR$ INLINEALWAYS transpose2
11469 #ifndef OSF
11470 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11471 #endif
11472       implicit none
11473       double precision a(2,2),at(2,2)
11474       at(1,1)=a(1,1)
11475       at(1,2)=a(2,1)
11476       at(2,1)=a(1,2)
11477       at(2,2)=a(2,2)
11478       return
11479       end
11480 c--------------------------------------------------------------------------
11481       subroutine transpose(n,a,at)
11482       implicit none
11483       integer n,i,j
11484       double precision a(n,n),at(n,n)
11485       do i=1,n
11486         do j=1,n
11487           at(j,i)=a(i,j)
11488         enddo
11489       enddo
11490       return
11491       end
11492 C---------------------------------------------------------------------------
11493       subroutine prodmat3(a1,a2,kk,transp,prod)
11494 !DIR$ INLINEALWAYS prodmat3
11495 #ifndef OSF
11496 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11497 #endif
11498       implicit none
11499       integer i,j
11500       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11501       logical transp
11502 crc      double precision auxmat(2,2),prod_(2,2)
11503
11504       if (transp) then
11505 crc        call transpose2(kk(1,1),auxmat(1,1))
11506 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11507 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11508
11509            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11510      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11511            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11512      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11513            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11514      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11515            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11516      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11517
11518       else
11519 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11520 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11521
11522            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11523      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11524            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11525      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11526            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11527      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11528            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11529      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11530
11531       endif
11532 c      call transpose2(a2(1,1),a2t(1,1))
11533
11534 crc      print *,transp
11535 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11536 crc      print *,((prod(i,j),i=1,2),j=1,2)
11537
11538       return
11539       end
11540 CCC----------------------------------------------
11541       subroutine Eliptransfer(eliptran)
11542       implicit real*8 (a-h,o-z)
11543       include 'DIMENSIONS'
11544       include 'COMMON.GEO'
11545       include 'COMMON.VAR'
11546       include 'COMMON.LOCAL'
11547       include 'COMMON.CHAIN'
11548       include 'COMMON.DERIV'
11549       include 'COMMON.NAMES'
11550       include 'COMMON.INTERACT'
11551       include 'COMMON.IOUNITS'
11552       include 'COMMON.CALC'
11553       include 'COMMON.CONTROL'
11554       include 'COMMON.SPLITELE'
11555       include 'COMMON.SBRIDGE'
11556 C this is done by Adasko
11557 C      print *,"wchodze"
11558 C structure of box:
11559 C      water
11560 C--bordliptop-- buffore starts
11561 C--bufliptop--- here true lipid starts
11562 C      lipid
11563 C--buflipbot--- lipid ends buffore starts
11564 C--bordlipbot--buffore ends
11565       eliptran=0.0
11566       do i=ilip_start,ilip_end
11567 C       do i=1,1
11568         if (itype(i).eq.ntyp1) cycle
11569
11570         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11571         if (positi.le.0.0) positi=positi+boxzsize
11572 C        print *,i
11573 C first for peptide groups
11574 c for each residue check if it is in lipid or lipid water border area
11575        if ((positi.gt.bordlipbot)
11576      &.and.(positi.lt.bordliptop)) then
11577 C the energy transfer exist
11578         if (positi.lt.buflipbot) then
11579 C what fraction I am in
11580          fracinbuf=1.0d0-
11581      &        ((positi-bordlipbot)/lipbufthick)
11582 C lipbufthick is thickenes of lipid buffore
11583          sslip=sscalelip(fracinbuf)
11584          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11585          eliptran=eliptran+sslip*pepliptran
11586          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11587          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11588 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11589
11590 C        print *,"doing sccale for lower part"
11591 C         print *,i,sslip,fracinbuf,ssgradlip
11592         elseif (positi.gt.bufliptop) then
11593          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11594          sslip=sscalelip(fracinbuf)
11595          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11596          eliptran=eliptran+sslip*pepliptran
11597          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11598          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11599 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11600 C          print *, "doing sscalefor top part"
11601 C         print *,i,sslip,fracinbuf,ssgradlip
11602         else
11603          eliptran=eliptran+pepliptran
11604 C         print *,"I am in true lipid"
11605         endif
11606 C       else
11607 C       eliptran=elpitran+0.0 ! I am in water
11608        endif
11609        enddo
11610 C       print *, "nic nie bylo w lipidzie?"
11611 C now multiply all by the peptide group transfer factor
11612 C       eliptran=eliptran*pepliptran
11613 C now the same for side chains
11614 CV       do i=1,1
11615        do i=ilip_start,ilip_end
11616         if (itype(i).eq.ntyp1) cycle
11617         positi=(mod(c(3,i+nres),boxzsize))
11618         if (positi.le.0) positi=positi+boxzsize
11619 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11620 c for each residue check if it is in lipid or lipid water border area
11621 C       respos=mod(c(3,i+nres),boxzsize)
11622 C       print *,positi,bordlipbot,buflipbot
11623        if ((positi.gt.bordlipbot)
11624      & .and.(positi.lt.bordliptop)) then
11625 C the energy transfer exist
11626         if (positi.lt.buflipbot) then
11627          fracinbuf=1.0d0-
11628      &     ((positi-bordlipbot)/lipbufthick)
11629 C lipbufthick is thickenes of lipid buffore
11630          sslip=sscalelip(fracinbuf)
11631          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11632          eliptran=eliptran+sslip*liptranene(itype(i))
11633          gliptranx(3,i)=gliptranx(3,i)
11634      &+ssgradlip*liptranene(itype(i))
11635          gliptranc(3,i-1)= gliptranc(3,i-1)
11636      &+ssgradlip*liptranene(itype(i))
11637 C         print *,"doing sccale for lower part"
11638         elseif (positi.gt.bufliptop) then
11639          fracinbuf=1.0d0-
11640      &((bordliptop-positi)/lipbufthick)
11641          sslip=sscalelip(fracinbuf)
11642          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11643          eliptran=eliptran+sslip*liptranene(itype(i))
11644          gliptranx(3,i)=gliptranx(3,i)
11645      &+ssgradlip*liptranene(itype(i))
11646          gliptranc(3,i-1)= gliptranc(3,i-1)
11647      &+ssgradlip*liptranene(itype(i))
11648 C          print *, "doing sscalefor top part",sslip,fracinbuf
11649         else
11650          eliptran=eliptran+liptranene(itype(i))
11651 C         print *,"I am in true lipid"
11652         endif
11653         endif ! if in lipid or buffor
11654 C       else
11655 C       eliptran=elpitran+0.0 ! I am in water
11656        enddo
11657        return
11658        end
11659 C---------------------------------------------------------
11660 C AFM soubroutine for constant force
11661        subroutine AFMforce(Eafmforce)
11662        implicit real*8 (a-h,o-z)
11663       include 'DIMENSIONS'
11664       include 'COMMON.GEO'
11665       include 'COMMON.VAR'
11666       include 'COMMON.LOCAL'
11667       include 'COMMON.CHAIN'
11668       include 'COMMON.DERIV'
11669       include 'COMMON.NAMES'
11670       include 'COMMON.INTERACT'
11671       include 'COMMON.IOUNITS'
11672       include 'COMMON.CALC'
11673       include 'COMMON.CONTROL'
11674       include 'COMMON.SPLITELE'
11675       include 'COMMON.SBRIDGE'
11676       real*8 diffafm(3)
11677       dist=0.0d0
11678       Eafmforce=0.0d0
11679       do i=1,3
11680       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11681       dist=dist+diffafm(i)**2
11682       enddo
11683       dist=dsqrt(dist)
11684       Eafmforce=-forceAFMconst*(dist-distafminit)
11685       do i=1,3
11686       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11687       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11688       enddo
11689 C      print *,'AFM',Eafmforce
11690       return
11691       end
11692 C---------------------------------------------------------
11693 C AFM subroutine with pseudoconstant velocity
11694        subroutine AFMvel(Eafmforce)
11695        implicit real*8 (a-h,o-z)
11696       include 'DIMENSIONS'
11697       include 'COMMON.GEO'
11698       include 'COMMON.VAR'
11699       include 'COMMON.LOCAL'
11700       include 'COMMON.CHAIN'
11701       include 'COMMON.DERIV'
11702       include 'COMMON.NAMES'
11703       include 'COMMON.INTERACT'
11704       include 'COMMON.IOUNITS'
11705       include 'COMMON.CALC'
11706       include 'COMMON.CONTROL'
11707       include 'COMMON.SPLITELE'
11708       include 'COMMON.SBRIDGE'
11709       real*8 diffafm(3)
11710 C Only for check grad COMMENT if not used for checkgrad
11711 C      totT=3.0d0
11712 C--------------------------------------------------------
11713 C      print *,"wchodze"
11714       dist=0.0d0
11715       Eafmforce=0.0d0
11716       do i=1,3
11717       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11718       dist=dist+diffafm(i)**2
11719       enddo
11720       dist=dsqrt(dist)
11721       Eafmforce=0.5d0*forceAFMconst
11722      & *(distafminit+totTafm*velAFMconst-dist)**2
11723 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11724       do i=1,3
11725       gradafm(i,afmend-1)=-forceAFMconst*
11726      &(distafminit+totTafm*velAFMconst-dist)
11727      &*diffafm(i)/dist
11728       gradafm(i,afmbeg-1)=forceAFMconst*
11729      &(distafminit+totTafm*velAFMconst-dist)
11730      &*diffafm(i)/dist
11731       enddo
11732 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11733       return
11734       end
11735 C-----------------------------------------------------------
11736 C first for shielding is setting of function of side-chains
11737        subroutine set_shield_fac
11738       implicit real*8 (a-h,o-z)
11739       include 'DIMENSIONS'
11740       include 'COMMON.CHAIN'
11741       include 'COMMON.DERIV'
11742       include 'COMMON.IOUNITS'
11743       include 'COMMON.SHIELD'
11744       include 'COMMON.INTERACT'
11745 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11746       double precision div77_81/0.974996043d0/,
11747      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11748
11749 C the vector between center of side_chain and peptide group
11750        double precision pep_side(3),long,side_calf(3),
11751      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11752      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11753 C the line belowe needs to be changed for FGPROC>1
11754       do i=1,nres-1
11755       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11756       ishield_list(i)=0
11757 Cif there two consequtive dummy atoms there is no peptide group between them
11758 C the line below has to be changed for FGPROC>1
11759       VolumeTotal=0.0
11760       do k=1,nres
11761        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11762        dist_pep_side=0.0
11763        dist_side_calf=0.0
11764        do j=1,3
11765 C first lets set vector conecting the ithe side-chain with kth side-chain
11766       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11767 C      pep_side(j)=2.0d0
11768 C and vector conecting the side-chain with its proper calfa
11769       side_calf(j)=c(j,k+nres)-c(j,k)
11770 C      side_calf(j)=2.0d0
11771       pept_group(j)=c(j,i)-c(j,i+1)
11772 C lets have their lenght
11773       dist_pep_side=pep_side(j)**2+dist_pep_side
11774       dist_side_calf=dist_side_calf+side_calf(j)**2
11775       dist_pept_group=dist_pept_group+pept_group(j)**2
11776       enddo
11777        dist_pep_side=dsqrt(dist_pep_side)
11778        dist_pept_group=dsqrt(dist_pept_group)
11779        dist_side_calf=dsqrt(dist_side_calf)
11780       do j=1,3
11781         pep_side_norm(j)=pep_side(j)/dist_pep_side
11782         side_calf_norm(j)=dist_side_calf
11783       enddo
11784 C now sscale fraction
11785        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11786 C       print *,buff_shield,"buff"
11787 C now sscale
11788         if (sh_frac_dist.le.0.0) cycle
11789 C If we reach here it means that this side chain reaches the shielding sphere
11790 C Lets add him to the list for gradient
11791         ishield_list(i)=ishield_list(i)+1
11792 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11793 C this list is essential otherwise problem would be O3
11794         shield_list(ishield_list(i),i)=k
11795 C Lets have the sscale value
11796         if (sh_frac_dist.gt.1.0) then
11797          scale_fac_dist=1.0d0
11798          do j=1,3
11799          sh_frac_dist_grad(j)=0.0d0
11800          enddo
11801         else
11802          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11803      &                   *(2.0*sh_frac_dist-3.0d0)
11804          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11805      &                  /dist_pep_side/buff_shield*0.5
11806 C remember for the final gradient multiply sh_frac_dist_grad(j)
11807 C for side_chain by factor -2 !
11808          do j=1,3
11809          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11810 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11811 C     &                    sh_frac_dist_grad(j)
11812          enddo
11813         endif
11814 C        if ((i.eq.3).and.(k.eq.2)) then
11815 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11816 C     & ,"TU"
11817 C        endif
11818
11819 C this is what is now we have the distance scaling now volume...
11820       short=short_r_sidechain(itype(k))
11821       long=long_r_sidechain(itype(k))
11822       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11823 C now costhet_grad
11824 C       costhet=0.0d0
11825        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11826 C       costhet_fac=0.0d0
11827        do j=1,3
11828          costhet_grad(j)=costhet_fac*pep_side(j)
11829        enddo
11830 C remember for the final gradient multiply costhet_grad(j)
11831 C for side_chain by factor -2 !
11832 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11833 C pep_side0pept_group is vector multiplication
11834       pep_side0pept_group=0.0
11835       do j=1,3
11836       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11837       enddo
11838       cosalfa=(pep_side0pept_group/
11839      & (dist_pep_side*dist_side_calf))
11840       fac_alfa_sin=1.0-cosalfa**2
11841       fac_alfa_sin=dsqrt(fac_alfa_sin)
11842       rkprim=fac_alfa_sin*(long-short)+short
11843 C now costhet_grad
11844        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11845        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11846
11847        do j=1,3
11848          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11849      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11850      &*(long-short)/fac_alfa_sin*cosalfa/
11851      &((dist_pep_side*dist_side_calf))*
11852      &((side_calf(j))-cosalfa*
11853      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11854
11855         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11856      &*(long-short)/fac_alfa_sin*cosalfa
11857      &/((dist_pep_side*dist_side_calf))*
11858      &(pep_side(j)-
11859      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11860        enddo
11861
11862       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11863      &                    /VSolvSphere_div
11864      &                    *wshield
11865 C now the gradient...
11866 C grad_shield is gradient of Calfa for peptide groups
11867 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11868 C     &               costhet,cosphi
11869 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11870 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11871       do j=1,3
11872       grad_shield(j,i)=grad_shield(j,i)
11873 C gradient po skalowaniu
11874      &                +(sh_frac_dist_grad(j)
11875 C  gradient po costhet
11876      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11877      &-scale_fac_dist*(cosphi_grad_long(j))
11878      &/(1.0-cosphi) )*div77_81
11879      &*VofOverlap
11880 C grad_shield_side is Cbeta sidechain gradient
11881       grad_shield_side(j,ishield_list(i),i)=
11882      &        (sh_frac_dist_grad(j)*-2.0d0
11883      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11884      &       +scale_fac_dist*(cosphi_grad_long(j))
11885      &        *2.0d0/(1.0-cosphi))
11886      &        *div77_81*VofOverlap
11887
11888        grad_shield_loc(j,ishield_list(i),i)=
11889      &   scale_fac_dist*cosphi_grad_loc(j)
11890      &        *2.0d0/(1.0-cosphi)
11891      &        *div77_81*VofOverlap
11892       enddo
11893       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11894       enddo
11895       fac_shield(i)=VolumeTotal*div77_81+div4_81
11896 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11897       enddo
11898       return
11899       end
11900 C--------------------------------------------------------------------------
11901       double precision function tschebyshev(m,n,x,y)
11902       implicit none
11903       include "DIMENSIONS"
11904       integer i,m,n
11905       double precision x(n),y,yy(0:maxvar),aux
11906 c Tschebyshev polynomial. Note that the first term is omitted
11907 c m=0: the constant term is included
11908 c m=1: the constant term is not included
11909       yy(0)=1.0d0
11910       yy(1)=y
11911       do i=2,n
11912         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11913       enddo
11914       aux=0.0d0
11915       do i=m,n
11916         aux=aux+x(i)*yy(i)
11917       enddo
11918       tschebyshev=aux
11919       return
11920       end
11921 C--------------------------------------------------------------------------
11922       double precision function gradtschebyshev(m,n,x,y)
11923       implicit none
11924       include "DIMENSIONS"
11925       integer i,m,n
11926       double precision x(n+1),y,yy(0:maxvar),aux
11927 c Tschebyshev polynomial. Note that the first term is omitted
11928 c m=0: the constant term is included
11929 c m=1: the constant term is not included
11930       yy(0)=1.0d0
11931       yy(1)=2.0d0*y
11932       do i=2,n
11933         yy(i)=2*y*yy(i-1)-yy(i-2)
11934       enddo
11935       aux=0.0d0
11936       do i=m,n
11937         aux=aux+x(i+1)*yy(i)*(i+1)
11938 C        print *, x(i+1),yy(i),i
11939       enddo
11940       gradtschebyshev=aux
11941       return
11942       end
11943 C------------------------------------------------------------------------
11944 C first for shielding is setting of function of side-chains
11945        subroutine set_shield_fac2
11946       implicit real*8 (a-h,o-z)
11947       include 'DIMENSIONS'
11948       include 'COMMON.CHAIN'
11949       include 'COMMON.DERIV'
11950       include 'COMMON.IOUNITS'
11951       include 'COMMON.SHIELD'
11952       include 'COMMON.INTERACT'
11953       include 'COMMON.LOCAL'
11954
11955 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11956       double precision div77_81/0.974996043d0/,
11957      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11958
11959 C the vector between center of side_chain and peptide group
11960        double precision pep_side(3),long,side_calf(3),
11961      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11962      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11963 C      write(2,*) "ivec",ivec_start,ivec_end
11964       do i=1,nres
11965         fac_shield(i)=0.0d0
11966         do j=1,3
11967         grad_shield(j,i)=0.0d0
11968         enddo
11969       enddo
11970 C the line belowe needs to be changed for FGPROC>1
11971       do i=ivec_start,ivec_end
11972 C      do i=1,nres-1
11973 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11974       ishield_list(i)=0
11975       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11976 Cif there two consequtive dummy atoms there is no peptide group between them
11977 C the line below has to be changed for FGPROC>1
11978       VolumeTotal=0.0
11979       do k=1,nres
11980        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11981        dist_pep_side=0.0
11982        dist_side_calf=0.0
11983        do j=1,3
11984 C first lets set vector conecting the ithe side-chain with kth side-chain
11985       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11986 C      pep_side(j)=2.0d0
11987 C and vector conecting the side-chain with its proper calfa
11988       side_calf(j)=c(j,k+nres)-c(j,k)
11989 C      side_calf(j)=2.0d0
11990       pept_group(j)=c(j,i)-c(j,i+1)
11991 C lets have their lenght
11992       dist_pep_side=pep_side(j)**2+dist_pep_side
11993       dist_side_calf=dist_side_calf+side_calf(j)**2
11994       dist_pept_group=dist_pept_group+pept_group(j)**2
11995       enddo
11996        dist_pep_side=dsqrt(dist_pep_side)
11997        dist_pept_group=dsqrt(dist_pept_group)
11998        dist_side_calf=dsqrt(dist_side_calf)
11999       do j=1,3
12000         pep_side_norm(j)=pep_side(j)/dist_pep_side
12001         side_calf_norm(j)=dist_side_calf
12002       enddo
12003 C now sscale fraction
12004        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12005 C       print *,buff_shield,"buff"
12006 C now sscale
12007         if (sh_frac_dist.le.0.0) cycle
12008 C        print *,ishield_list(i),i
12009 C If we reach here it means that this side chain reaches the shielding sphere
12010 C Lets add him to the list for gradient
12011         ishield_list(i)=ishield_list(i)+1
12012 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12013 C this list is essential otherwise problem would be O3
12014         shield_list(ishield_list(i),i)=k
12015 C Lets have the sscale value
12016         if (sh_frac_dist.gt.1.0) then
12017          scale_fac_dist=1.0d0
12018          do j=1,3
12019          sh_frac_dist_grad(j)=0.0d0
12020          enddo
12021         else
12022          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12023      &                   *(2.0d0*sh_frac_dist-3.0d0)
12024          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12025      &                  /dist_pep_side/buff_shield*0.5d0
12026 C remember for the final gradient multiply sh_frac_dist_grad(j)
12027 C for side_chain by factor -2 !
12028          do j=1,3
12029          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12030 C         sh_frac_dist_grad(j)=0.0d0
12031 C         scale_fac_dist=1.0d0
12032 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12033 C     &                    sh_frac_dist_grad(j)
12034          enddo
12035         endif
12036 C this is what is now we have the distance scaling now volume...
12037       short=short_r_sidechain(itype(k))
12038       long=long_r_sidechain(itype(k))
12039       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12040       sinthet=short/dist_pep_side*costhet
12041 C now costhet_grad
12042 C       costhet=0.6d0
12043 C       sinthet=0.8
12044        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12045 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12046 C     &             -short/dist_pep_side**2/costhet)
12047 C       costhet_fac=0.0d0
12048        do j=1,3
12049          costhet_grad(j)=costhet_fac*pep_side(j)
12050        enddo
12051 C remember for the final gradient multiply costhet_grad(j)
12052 C for side_chain by factor -2 !
12053 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12054 C pep_side0pept_group is vector multiplication
12055       pep_side0pept_group=0.0d0
12056       do j=1,3
12057       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12058       enddo
12059       cosalfa=(pep_side0pept_group/
12060      & (dist_pep_side*dist_side_calf))
12061       fac_alfa_sin=1.0d0-cosalfa**2
12062       fac_alfa_sin=dsqrt(fac_alfa_sin)
12063       rkprim=fac_alfa_sin*(long-short)+short
12064 C      rkprim=short
12065
12066 C now costhet_grad
12067        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12068 C       cosphi=0.6
12069        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12070        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12071      &      dist_pep_side**2)
12072 C       sinphi=0.8
12073        do j=1,3
12074          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12075      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12076      &*(long-short)/fac_alfa_sin*cosalfa/
12077      &((dist_pep_side*dist_side_calf))*
12078      &((side_calf(j))-cosalfa*
12079      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12080 C       cosphi_grad_long(j)=0.0d0
12081         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12082      &*(long-short)/fac_alfa_sin*cosalfa
12083      &/((dist_pep_side*dist_side_calf))*
12084      &(pep_side(j)-
12085      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12086 C       cosphi_grad_loc(j)=0.0d0
12087        enddo
12088 C      print *,sinphi,sinthet
12089       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12090      &                    /VSolvSphere_div
12091 C     &                    *wshield
12092 C now the gradient...
12093       do j=1,3
12094       grad_shield(j,i)=grad_shield(j,i)
12095 C gradient po skalowaniu
12096      &                +(sh_frac_dist_grad(j)*VofOverlap
12097 C  gradient po costhet
12098      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12099      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12100      &       sinphi/sinthet*costhet*costhet_grad(j)
12101      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12102      & )*wshield
12103 C grad_shield_side is Cbeta sidechain gradient
12104       grad_shield_side(j,ishield_list(i),i)=
12105      &        (sh_frac_dist_grad(j)*-2.0d0
12106      &        *VofOverlap
12107      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12108      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12109      &       sinphi/sinthet*costhet*costhet_grad(j)
12110      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12111      &       )*wshield
12112
12113        grad_shield_loc(j,ishield_list(i),i)=
12114      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12115      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12116      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12117      &        ))
12118      &        *wshield
12119       enddo
12120       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12121       enddo
12122       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12123 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12124       enddo
12125       return
12126       end
12127 C-----------------------------------------------------------------------
12128 C-----------------------------------------------------------
12129 C This subroutine is to mimic the histone like structure but as well can be
12130 C utilizet to nanostructures (infinit) small modification has to be used to
12131 C make it finite (z gradient at the ends has to be changes as well as the x,y
12132 C gradient has to be modified at the ends
12133 C The energy function is Kihara potential
12134 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12135 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12136 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12137 C simple Kihara potential
12138       subroutine calctube(Etube)
12139        implicit real*8 (a-h,o-z)
12140       include 'DIMENSIONS'
12141       include 'COMMON.GEO'
12142       include 'COMMON.VAR'
12143       include 'COMMON.LOCAL'
12144       include 'COMMON.CHAIN'
12145       include 'COMMON.DERIV'
12146       include 'COMMON.NAMES'
12147       include 'COMMON.INTERACT'
12148       include 'COMMON.IOUNITS'
12149       include 'COMMON.CALC'
12150       include 'COMMON.CONTROL'
12151       include 'COMMON.SPLITELE'
12152       include 'COMMON.SBRIDGE'
12153       double precision tub_r,vectube(3),enetube(maxres*2)
12154       Etube=0.0d0
12155       do i=itube_start,itube_end
12156         enetube(i)=0.0d0
12157         enetube(i+nres)=0.0d0
12158       enddo
12159 C first we calculate the distance from tube center
12160 C first sugare-phosphate group for NARES this would be peptide group
12161 C for UNRES
12162        do i=itube_start,itube_end
12163 C lets ommit dummy atoms for now
12164        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12165 C now calculate distance from center of tube and direction vectors
12166       xmin=boxxsize
12167       ymin=boxysize
12168         do j=-1,1
12169          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12170          vectube(1)=vectube(1)+boxxsize*j
12171          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12172          vectube(2)=vectube(2)+boxysize*j
12173
12174          xminact=abs(vectube(1)-tubecenter(1))
12175          yminact=abs(vectube(2)-tubecenter(2))
12176            if (xmin.gt.xminact) then
12177             xmin=xminact
12178             xtemp=vectube(1)
12179            endif
12180            if (ymin.gt.yminact) then
12181              ymin=yminact
12182              ytemp=vectube(2)
12183             endif
12184          enddo
12185       vectube(1)=xtemp
12186       vectube(2)=ytemp
12187       vectube(1)=vectube(1)-tubecenter(1)
12188       vectube(2)=vectube(2)-tubecenter(2)
12189
12190 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12191 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12192
12193 C as the tube is infinity we do not calculate the Z-vector use of Z
12194 C as chosen axis
12195       vectube(3)=0.0d0
12196 C now calculte the distance
12197        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12198 C now normalize vector
12199       vectube(1)=vectube(1)/tub_r
12200       vectube(2)=vectube(2)/tub_r
12201 C calculte rdiffrence between r and r0
12202       rdiff=tub_r-tubeR0
12203 C and its 6 power
12204       rdiff6=rdiff**6.0d0
12205 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12206        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12207 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12208 C       print *,rdiff,rdiff6,pep_aa_tube
12209 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12210 C now we calculate gradient
12211        fac=(-12.0d0*pep_aa_tube/rdiff6-
12212      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12213 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12214 C     &rdiff,fac
12215
12216 C now direction of gg_tube vector
12217         do j=1,3
12218         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12219         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12220         enddo
12221         enddo
12222 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12223 C        print *,gg_tube(1,0),"TU"
12224
12225
12226        do i=itube_start,itube_end
12227 C Lets not jump over memory as we use many times iti
12228          iti=itype(i)
12229 C lets ommit dummy atoms for now
12230          if ((iti.eq.ntyp1)
12231 C in UNRES uncomment the line below as GLY has no side-chain...
12232 C      .or.(iti.eq.10)
12233      &   ) cycle
12234       xmin=boxxsize
12235       ymin=boxysize
12236         do j=-1,1
12237          vectube(1)=mod((c(1,i+nres)),boxxsize)
12238          vectube(1)=vectube(1)+boxxsize*j
12239          vectube(2)=mod((c(2,i+nres)),boxysize)
12240          vectube(2)=vectube(2)+boxysize*j
12241
12242          xminact=abs(vectube(1)-tubecenter(1))
12243          yminact=abs(vectube(2)-tubecenter(2))
12244            if (xmin.gt.xminact) then
12245             xmin=xminact
12246             xtemp=vectube(1)
12247            endif
12248            if (ymin.gt.yminact) then
12249              ymin=yminact
12250              ytemp=vectube(2)
12251             endif
12252          enddo
12253       vectube(1)=xtemp
12254       vectube(2)=ytemp
12255 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12256 C     &     tubecenter(2)
12257       vectube(1)=vectube(1)-tubecenter(1)
12258       vectube(2)=vectube(2)-tubecenter(2)
12259
12260 C as the tube is infinity we do not calculate the Z-vector use of Z
12261 C as chosen axis
12262       vectube(3)=0.0d0
12263 C now calculte the distance
12264        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12265 C now normalize vector
12266       vectube(1)=vectube(1)/tub_r
12267       vectube(2)=vectube(2)/tub_r
12268
12269 C calculte rdiffrence between r and r0
12270       rdiff=tub_r-tubeR0
12271 C and its 6 power
12272       rdiff6=rdiff**6.0d0
12273 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12274        sc_aa_tube=sc_aa_tube_par(iti)
12275        sc_bb_tube=sc_bb_tube_par(iti)
12276        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12277 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12278 C now we calculate gradient
12279        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12280      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12281 C now direction of gg_tube vector
12282          do j=1,3
12283           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12284           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12285          enddo
12286         enddo
12287         do i=itube_start,itube_end
12288           Etube=Etube+enetube(i)+enetube(i+nres)
12289         enddo
12290 C        print *,"ETUBE", etube
12291         return
12292         end
12293 C TO DO 1) add to total energy
12294 C       2) add to gradient summation
12295 C       3) add reading parameters (AND of course oppening of PARAM file)
12296 C       4) add reading the center of tube
12297 C       5) add COMMONs
12298 C       6) add to zerograd
12299
12300 C-----------------------------------------------------------------------
12301 C-----------------------------------------------------------
12302 C This subroutine is to mimic the histone like structure but as well can be
12303 C utilizet to nanostructures (infinit) small modification has to be used to
12304 C make it finite (z gradient at the ends has to be changes as well as the x,y
12305 C gradient has to be modified at the ends
12306 C The energy function is Kihara potential
12307 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12308 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12309 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12310 C simple Kihara potential
12311       subroutine calctube2(Etube)
12312        implicit real*8 (a-h,o-z)
12313       include 'DIMENSIONS'
12314       include 'COMMON.GEO'
12315       include 'COMMON.VAR'
12316       include 'COMMON.LOCAL'
12317       include 'COMMON.CHAIN'
12318       include 'COMMON.DERIV'
12319       include 'COMMON.NAMES'
12320       include 'COMMON.INTERACT'
12321       include 'COMMON.IOUNITS'
12322       include 'COMMON.CALC'
12323       include 'COMMON.CONTROL'
12324       include 'COMMON.SPLITELE'
12325       include 'COMMON.SBRIDGE'
12326       double precision tub_r,vectube(3),enetube(maxres*2)
12327       Etube=0.0d0
12328       do i=itube_start,itube_end
12329         enetube(i)=0.0d0
12330         enetube(i+nres)=0.0d0
12331       enddo
12332 C first we calculate the distance from tube center
12333 C first sugare-phosphate group for NARES this would be peptide group
12334 C for UNRES
12335        do i=itube_start,itube_end
12336 C lets ommit dummy atoms for now
12337
12338        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12339 C now calculate distance from center of tube and direction vectors
12340       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12341           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12342       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12343           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12344       vectube(1)=vectube(1)-tubecenter(1)
12345       vectube(2)=vectube(2)-tubecenter(2)
12346
12347 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12348 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12349
12350 C as the tube is infinity we do not calculate the Z-vector use of Z
12351 C as chosen axis
12352       vectube(3)=0.0d0
12353 C now calculte the distance
12354        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12355 C now normalize vector
12356       vectube(1)=vectube(1)/tub_r
12357       vectube(2)=vectube(2)/tub_r
12358 C calculte rdiffrence between r and r0
12359       rdiff=tub_r-tubeR0
12360 C and its 6 power
12361       rdiff6=rdiff**6.0d0
12362 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12363        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12364 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12365 C       print *,rdiff,rdiff6,pep_aa_tube
12366 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12367 C now we calculate gradient
12368        fac=(-12.0d0*pep_aa_tube/rdiff6-
12369      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12370 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12371 C     &rdiff,fac
12372
12373 C now direction of gg_tube vector
12374         do j=1,3
12375         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12376         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12377         enddo
12378         enddo
12379 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12380 C        print *,gg_tube(1,0),"TU"
12381         do i=itube_start,itube_end
12382 C Lets not jump over memory as we use many times iti
12383          iti=itype(i)
12384 C lets ommit dummy atoms for now
12385          if ((iti.eq.ntyp1)
12386 C in UNRES uncomment the line below as GLY has no side-chain...
12387      &      .or.(iti.eq.10)
12388      &   ) cycle
12389           vectube(1)=c(1,i+nres)
12390           vectube(1)=mod(vectube(1),boxxsize)
12391           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12392           vectube(2)=c(2,i+nres)
12393           vectube(2)=mod(vectube(2),boxysize)
12394           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12395
12396       vectube(1)=vectube(1)-tubecenter(1)
12397       vectube(2)=vectube(2)-tubecenter(2)
12398 C THIS FRAGMENT MAKES TUBE FINITE
12399         positi=(mod(c(3,i+nres),boxzsize))
12400         if (positi.le.0) positi=positi+boxzsize
12401 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12402 c for each residue check if it is in lipid or lipid water border area
12403 C       respos=mod(c(3,i+nres),boxzsize)
12404        print *,positi,bordtubebot,buftubebot,bordtubetop
12405        if ((positi.gt.bordtubebot)
12406      & .and.(positi.lt.bordtubetop)) then
12407 C the energy transfer exist
12408         if (positi.lt.buftubebot) then
12409          fracinbuf=1.0d0-
12410      &     ((positi-bordtubebot)/tubebufthick)
12411 C lipbufthick is thickenes of lipid buffore
12412          sstube=sscalelip(fracinbuf)
12413          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12414          print *,ssgradtube, sstube,tubetranene(itype(i))
12415          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12416 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12417 C     &+ssgradtube*tubetranene(itype(i))
12418 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12419 C     &+ssgradtube*tubetranene(itype(i))
12420 C         print *,"doing sccale for lower part"
12421         elseif (positi.gt.buftubetop) then
12422          fracinbuf=1.0d0-
12423      &((bordtubetop-positi)/tubebufthick)
12424          sstube=sscalelip(fracinbuf)
12425          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12426          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12427 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12428 C     &+ssgradtube*tubetranene(itype(i))
12429 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12430 C     &+ssgradtube*tubetranene(itype(i))
12431 C          print *, "doing sscalefor top part",sslip,fracinbuf
12432         else
12433          sstube=1.0d0
12434          ssgradtube=0.0d0
12435          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12436 C         print *,"I am in true lipid"
12437         endif
12438         else
12439 C          sstube=0.0d0
12440 C          ssgradtube=0.0d0
12441         cycle
12442         endif ! if in lipid or buffor
12443 CEND OF FINITE FRAGMENT
12444 C as the tube is infinity we do not calculate the Z-vector use of Z
12445 C as chosen axis
12446       vectube(3)=0.0d0
12447 C now calculte the distance
12448        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12449 C now normalize vector
12450       vectube(1)=vectube(1)/tub_r
12451       vectube(2)=vectube(2)/tub_r
12452 C calculte rdiffrence between r and r0
12453       rdiff=tub_r-tubeR0
12454 C and its 6 power
12455       rdiff6=rdiff**6.0d0
12456 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12457        sc_aa_tube=sc_aa_tube_par(iti)
12458        sc_bb_tube=sc_bb_tube_par(iti)
12459        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12460      &                 *sstube+enetube(i+nres)
12461 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12462 C now we calculate gradient
12463        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12464      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12465 C now direction of gg_tube vector
12466          do j=1,3
12467           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12468           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12469          enddo
12470          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12471      &+ssgradtube*enetube(i+nres)/sstube
12472          gg_tube(3,i-1)= gg_tube(3,i-1)
12473      &+ssgradtube*enetube(i+nres)/sstube
12474
12475         enddo
12476         do i=itube_start,itube_end
12477           Etube=Etube+enetube(i)+enetube(i+nres)
12478         enddo
12479 C        print *,"ETUBE", etube
12480         return
12481         end
12482 C TO DO 1) add to total energy
12483 C       2) add to gradient summation
12484 C       3) add reading parameters (AND of course oppening of PARAM file)
12485 C       4) add reading the center of tube
12486 C       5) add COMMONs
12487 C       6) add to zerograd
12488
12489
12490 C#-------------------------------------------------------------------------------
12491 C This subroutine is to mimic the histone like structure but as well can be
12492 C utilizet to nanostructures (infinit) small modification has to be used to
12493 C make it finite (z gradient at the ends has to be changes as well as the x,y
12494 C gradient has to be modified at the ends
12495 C The energy function is Kihara potential
12496 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12497 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12498 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12499 C simple Kihara potential
12500       subroutine calcnano(Etube)
12501        implicit real*8 (a-h,o-z)
12502       include 'DIMENSIONS'
12503       include 'COMMON.GEO'
12504       include 'COMMON.VAR'
12505       include 'COMMON.LOCAL'
12506       include 'COMMON.CHAIN'
12507       include 'COMMON.DERIV'
12508       include 'COMMON.NAMES'
12509       include 'COMMON.INTERACT'
12510       include 'COMMON.IOUNITS'
12511       include 'COMMON.CALC'
12512       include 'COMMON.CONTROL'
12513       include 'COMMON.SPLITELE'
12514       include 'COMMON.SBRIDGE'
12515       double precision tub_r,vectube(3),enetube(maxres*2),
12516      & enecavtube(maxres*2)
12517       Etube=0.0d0
12518       do i=itube_start,itube_end
12519         enetube(i)=0.0d0
12520         enetube(i+nres)=0.0d0
12521       enddo
12522 C first we calculate the distance from tube center
12523 C first sugare-phosphate group for NARES this would be peptide group
12524 C for UNRES
12525        do i=itube_start,itube_end
12526 C lets ommit dummy atoms for now
12527        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12528 C now calculate distance from center of tube and direction vectors
12529       xmin=boxxsize
12530       ymin=boxysize
12531       zmin=boxzsize
12532
12533         do j=-1,1
12534          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12535          vectube(1)=vectube(1)+boxxsize*j
12536          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12537          vectube(2)=vectube(2)+boxysize*j
12538          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12539          vectube(3)=vectube(3)+boxzsize*j
12540
12541
12542          xminact=abs(vectube(1)-tubecenter(1))
12543          yminact=abs(vectube(2)-tubecenter(2))
12544          zminact=abs(vectube(3)-tubecenter(3))
12545
12546            if (xmin.gt.xminact) then
12547             xmin=xminact
12548             xtemp=vectube(1)
12549            endif
12550            if (ymin.gt.yminact) then
12551              ymin=yminact
12552              ytemp=vectube(2)
12553             endif
12554            if (zmin.gt.zminact) then
12555              zmin=zminact
12556              ztemp=vectube(3)
12557             endif
12558          enddo
12559       vectube(1)=xtemp
12560       vectube(2)=ytemp
12561       vectube(3)=ztemp
12562
12563       vectube(1)=vectube(1)-tubecenter(1)
12564       vectube(2)=vectube(2)-tubecenter(2)
12565       vectube(3)=vectube(3)-tubecenter(3)
12566
12567 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12568 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12569 C as the tube is infinity we do not calculate the Z-vector use of Z
12570 C as chosen axis
12571 C      vectube(3)=0.0d0
12572 C now calculte the distance
12573        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12574 C now normalize vector
12575       vectube(1)=vectube(1)/tub_r
12576       vectube(2)=vectube(2)/tub_r
12577       vectube(3)=vectube(3)/tub_r
12578 C calculte rdiffrence between r and r0
12579       rdiff=tub_r-tubeR0
12580 C and its 6 power
12581       rdiff6=rdiff**6.0d0
12582 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12583        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12584 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12585 C       print *,rdiff,rdiff6,pep_aa_tube
12586 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12587 C now we calculate gradient
12588        fac=(-12.0d0*pep_aa_tube/rdiff6-
12589      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12590 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12591 C     &rdiff,fac
12592
12593 C now direction of gg_tube vector
12594         do j=1,3
12595         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12596         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12597         enddo
12598         enddo
12599
12600        do i=itube_start,itube_end
12601         enecavtube(i)=0.0
12602 C Lets not jump over memory as we use many times iti
12603          iti=itype(i)
12604 C lets ommit dummy atoms for now
12605          if ((iti.eq.ntyp1)
12606 C in UNRES uncomment the line below as GLY has no side-chain...
12607 C      .or.(iti.eq.10)
12608      &   ) cycle
12609       xmin=boxxsize
12610       ymin=boxysize
12611       zmin=boxzsize
12612         do j=-1,1
12613          vectube(1)=mod((c(1,i+nres)),boxxsize)
12614          vectube(1)=vectube(1)+boxxsize*j
12615          vectube(2)=mod((c(2,i+nres)),boxysize)
12616          vectube(2)=vectube(2)+boxysize*j
12617          vectube(3)=mod((c(3,i+nres)),boxzsize)
12618          vectube(3)=vectube(3)+boxzsize*j
12619
12620
12621          xminact=abs(vectube(1)-tubecenter(1))
12622          yminact=abs(vectube(2)-tubecenter(2))
12623          zminact=abs(vectube(3)-tubecenter(3))
12624
12625            if (xmin.gt.xminact) then
12626             xmin=xminact
12627             xtemp=vectube(1)
12628            endif
12629            if (ymin.gt.yminact) then
12630              ymin=yminact
12631              ytemp=vectube(2)
12632             endif
12633            if (zmin.gt.zminact) then
12634              zmin=zminact
12635              ztemp=vectube(3)
12636             endif
12637          enddo
12638       vectube(1)=xtemp
12639       vectube(2)=ytemp
12640       vectube(3)=ztemp
12641
12642 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12643 C     &     tubecenter(2)
12644       vectube(1)=vectube(1)-tubecenter(1)
12645       vectube(2)=vectube(2)-tubecenter(2)
12646       vectube(3)=vectube(3)-tubecenter(3)
12647 C now calculte the distance
12648        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12649 C now normalize vector
12650       vectube(1)=vectube(1)/tub_r
12651       vectube(2)=vectube(2)/tub_r
12652       vectube(3)=vectube(3)/tub_r
12653
12654 C calculte rdiffrence between r and r0
12655       rdiff=tub_r-tubeR0
12656 C and its 6 power
12657       rdiff6=rdiff**6.0d0
12658 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12659        sc_aa_tube=sc_aa_tube_par(iti)
12660        sc_bb_tube=sc_bb_tube_par(iti)
12661        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12662 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12663 C now we calculate gradient
12664        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12665      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12666 C now direction of gg_tube vector
12667 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12668          if (acavtub(iti).eq.0.0d0) go to 667
12669          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
12670          enecavtube(i)=
12671      &   acavtub(iti)*(rdiff+bcavtub(iti)*sqrt(rdiff)+cavtub(iti))
12672      &   /denominator
12673          faccav=(acavtub(iti)*(1.0+bcavtub(iti)/2.0/sqrt(rdiff))
12674      &   *denominator-acavtub(iti)*(rdiff+bcavtub(iti)*sqrt(rdiff)
12675      &   +cavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti))
12676      &   /denominator**2.0d0
12677          fac=fac+faccav
12678  667     continue
12679          do j=1,3
12680           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12681           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12682          enddo
12683         enddo
12684 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12685 C        do i=itube_start,itube_end
12686 C        enecav(i)=0.0
12687 C        iti=itype(i)
12688 C        if (acavtub(iti).eq.0.0) cycle
12689
12690
12691
12692         do i=itube_start,itube_end
12693           Etube=Etube+enetube(i)+enetube(i+nres)
12694         enddo
12695 C        print *,"ETUBE", etube
12696         return
12697         end
12698 C TO DO 1) add to total energy
12699 C       2) add to gradient summation
12700 C       3) add reading parameters (AND of course oppening of PARAM file)
12701 C       4) add reading the center of tube
12702 C       5) add COMMONs
12703 C       6) add to zerograd
12704