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             if (energy_dec)  write (iout,*)
6333      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(j,iti),diff,
6334      &      AKSC(j,iti),AKSC(j,iti)*diff*diff
6335               ud(j)=aksc(j,iti)*diff
6336               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6337             enddo
6338             uprod=u(1)
6339             do j=2,nbi
6340               uprod=uprod*u(j)
6341             enddo
6342             usum=0.0d0
6343             usumsqder=0.0d0
6344             do j=1,nbi
6345               uprod1=1.0d0
6346               uprod2=1.0d0
6347               do k=1,nbi
6348                 if (k.ne.j) then
6349                   uprod1=uprod1*u(k)
6350                   uprod2=uprod2*u(k)*u(k)
6351                 endif
6352               enddo
6353               usum=usum+uprod1
6354               usumsqder=usumsqder+ud(j)*uprod2
6355             enddo
6356             estr=estr+uprod/usum
6357             do j=1,3
6358              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6359             enddo
6360           endif
6361         endif
6362       enddo
6363       return
6364       end
6365 #ifdef CRYST_THETA
6366 C--------------------------------------------------------------------------
6367       subroutine ebend(etheta,ethetacnstr)
6368 C
6369 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6370 C angles gamma and its derivatives in consecutive thetas and gammas.
6371 C
6372       implicit real*8 (a-h,o-z)
6373       include 'DIMENSIONS'
6374       include 'COMMON.LOCAL'
6375       include 'COMMON.GEO'
6376       include 'COMMON.INTERACT'
6377       include 'COMMON.DERIV'
6378       include 'COMMON.VAR'
6379       include 'COMMON.CHAIN'
6380       include 'COMMON.IOUNITS'
6381       include 'COMMON.NAMES'
6382       include 'COMMON.FFIELD'
6383       include 'COMMON.CONTROL'
6384       include 'COMMON.TORCNSTR'
6385       common /calcthet/ term1,term2,termm,diffak,ratak,
6386      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6387      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6388       double precision y(2),z(2)
6389       delta=0.02d0*pi
6390 c      time11=dexp(-2*time)
6391 c      time12=1.0d0
6392       etheta=0.0D0
6393 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6394       do i=ithet_start,ithet_end
6395         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6396      &  .or.itype(i).eq.ntyp1) cycle
6397 C Zero the energy function and its derivative at 0 or pi.
6398         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6399         it=itype(i-1)
6400         ichir1=isign(1,itype(i-2))
6401         ichir2=isign(1,itype(i))
6402          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6403          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6404          if (itype(i-1).eq.10) then
6405           itype1=isign(10,itype(i-2))
6406           ichir11=isign(1,itype(i-2))
6407           ichir12=isign(1,itype(i-2))
6408           itype2=isign(10,itype(i))
6409           ichir21=isign(1,itype(i))
6410           ichir22=isign(1,itype(i))
6411          endif
6412
6413         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6414 #ifdef OSF
6415           phii=phi(i)
6416           if (phii.ne.phii) phii=150.0
6417 #else
6418           phii=phi(i)
6419 #endif
6420           y(1)=dcos(phii)
6421           y(2)=dsin(phii)
6422         else
6423           y(1)=0.0D0
6424           y(2)=0.0D0
6425         endif
6426         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6427 #ifdef OSF
6428           phii1=phi(i+1)
6429           if (phii1.ne.phii1) phii1=150.0
6430           phii1=pinorm(phii1)
6431           z(1)=cos(phii1)
6432 #else
6433           phii1=phi(i+1)
6434 #endif
6435           z(1)=dcos(phii1)
6436           z(2)=dsin(phii1)
6437         else
6438           z(1)=0.0D0
6439           z(2)=0.0D0
6440         endif
6441 C Calculate the "mean" value of theta from the part of the distribution
6442 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6443 C In following comments this theta will be referred to as t_c.
6444         thet_pred_mean=0.0d0
6445         do k=1,2
6446             athetk=athet(k,it,ichir1,ichir2)
6447             bthetk=bthet(k,it,ichir1,ichir2)
6448           if (it.eq.10) then
6449              athetk=athet(k,itype1,ichir11,ichir12)
6450              bthetk=bthet(k,itype2,ichir21,ichir22)
6451           endif
6452          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6453 c         write(iout,*) 'chuj tu', y(k),z(k)
6454         enddo
6455         dthett=thet_pred_mean*ssd
6456         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6457 C Derivatives of the "mean" values in gamma1 and gamma2.
6458         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6459      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6460          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6461      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6462          if (it.eq.10) then
6463       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6464      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6465         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6466      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6467          endif
6468         if (theta(i).gt.pi-delta) then
6469           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6470      &         E_tc0)
6471           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6472           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6473           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6474      &        E_theta)
6475           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6476      &        E_tc)
6477         else if (theta(i).lt.delta) then
6478           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6479           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6480           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6481      &        E_theta)
6482           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6483           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6484      &        E_tc)
6485         else
6486           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6487      &        E_theta,E_tc)
6488         endif
6489         etheta=etheta+ethetai
6490         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6491      &      'ebend',i,ethetai,theta(i),itype(i)
6492         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6493         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6494         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6495       enddo
6496       ethetacnstr=0.0d0
6497 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6498       do i=ithetaconstr_start,ithetaconstr_end
6499         itheta=itheta_constr(i)
6500         thetiii=theta(itheta)
6501         difi=pinorm(thetiii-theta_constr0(i))
6502         if (difi.gt.theta_drange(i)) then
6503           difi=difi-theta_drange(i)
6504           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6505           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6506      &    +for_thet_constr(i)*difi**3
6507         else if (difi.lt.-drange(i)) then
6508           difi=difi+drange(i)
6509           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6510           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6511      &    +for_thet_constr(i)*difi**3
6512         else
6513           difi=0.0
6514         endif
6515        if (energy_dec) then
6516         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6517      &    i,itheta,rad2deg*thetiii,
6518      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6519      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6520      &    gloc(itheta+nphi-2,icg)
6521         endif
6522       enddo
6523
6524 C Ufff.... We've done all this!!!
6525       return
6526       end
6527 C---------------------------------------------------------------------------
6528       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6529      &     E_tc)
6530       implicit real*8 (a-h,o-z)
6531       include 'DIMENSIONS'
6532       include 'COMMON.LOCAL'
6533       include 'COMMON.IOUNITS'
6534       common /calcthet/ term1,term2,termm,diffak,ratak,
6535      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6536      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6537 C Calculate the contributions to both Gaussian lobes.
6538 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6539 C The "polynomial part" of the "standard deviation" of this part of
6540 C the distributioni.
6541 ccc        write (iout,*) thetai,thet_pred_mean
6542         sig=polthet(3,it)
6543         do j=2,0,-1
6544           sig=sig*thet_pred_mean+polthet(j,it)
6545         enddo
6546 C Derivative of the "interior part" of the "standard deviation of the"
6547 C gamma-dependent Gaussian lobe in t_c.
6548         sigtc=3*polthet(3,it)
6549         do j=2,1,-1
6550           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6551         enddo
6552         sigtc=sig*sigtc
6553 C Set the parameters of both Gaussian lobes of the distribution.
6554 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6555         fac=sig*sig+sigc0(it)
6556         sigcsq=fac+fac
6557         sigc=1.0D0/sigcsq
6558 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6559         sigsqtc=-4.0D0*sigcsq*sigtc
6560 c       print *,i,sig,sigtc,sigsqtc
6561 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6562         sigtc=-sigtc/(fac*fac)
6563 C Following variable is sigma(t_c)**(-2)
6564         sigcsq=sigcsq*sigcsq
6565         sig0i=sig0(it)
6566         sig0inv=1.0D0/sig0i**2
6567         delthec=thetai-thet_pred_mean
6568         delthe0=thetai-theta0i
6569         term1=-0.5D0*sigcsq*delthec*delthec
6570         term2=-0.5D0*sig0inv*delthe0*delthe0
6571 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6572 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6573 C NaNs in taking the logarithm. We extract the largest exponent which is added
6574 C to the energy (this being the log of the distribution) at the end of energy
6575 C term evaluation for this virtual-bond angle.
6576         if (term1.gt.term2) then
6577           termm=term1
6578           term2=dexp(term2-termm)
6579           term1=1.0d0
6580         else
6581           termm=term2
6582           term1=dexp(term1-termm)
6583           term2=1.0d0
6584         endif
6585 C The ratio between the gamma-independent and gamma-dependent lobes of
6586 C the distribution is a Gaussian function of thet_pred_mean too.
6587         diffak=gthet(2,it)-thet_pred_mean
6588         ratak=diffak/gthet(3,it)**2
6589         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6590 C Let's differentiate it in thet_pred_mean NOW.
6591         aktc=ak*ratak
6592 C Now put together the distribution terms to make complete distribution.
6593         termexp=term1+ak*term2
6594         termpre=sigc+ak*sig0i
6595 C Contribution of the bending energy from this theta is just the -log of
6596 C the sum of the contributions from the two lobes and the pre-exponential
6597 C factor. Simple enough, isn't it?
6598         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6599 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6600 C NOW the derivatives!!!
6601 C 6/6/97 Take into account the deformation.
6602         E_theta=(delthec*sigcsq*term1
6603      &       +ak*delthe0*sig0inv*term2)/termexp
6604         E_tc=((sigtc+aktc*sig0i)/termpre
6605      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6606      &       aktc*term2)/termexp)
6607       return
6608       end
6609 c-----------------------------------------------------------------------------
6610       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6611       implicit real*8 (a-h,o-z)
6612       include 'DIMENSIONS'
6613       include 'COMMON.LOCAL'
6614       include 'COMMON.IOUNITS'
6615       common /calcthet/ term1,term2,termm,diffak,ratak,
6616      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6617      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6618       delthec=thetai-thet_pred_mean
6619       delthe0=thetai-theta0i
6620 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6621       t3 = thetai-thet_pred_mean
6622       t6 = t3**2
6623       t9 = term1
6624       t12 = t3*sigcsq
6625       t14 = t12+t6*sigsqtc
6626       t16 = 1.0d0
6627       t21 = thetai-theta0i
6628       t23 = t21**2
6629       t26 = term2
6630       t27 = t21*t26
6631       t32 = termexp
6632       t40 = t32**2
6633       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6634      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6635      & *(-t12*t9-ak*sig0inv*t27)
6636       return
6637       end
6638 #else
6639 C--------------------------------------------------------------------------
6640       subroutine ebend(etheta,ethetacnstr)
6641 C
6642 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6643 C angles gamma and its derivatives in consecutive thetas and gammas.
6644 C ab initio-derived potentials from
6645 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6646 C
6647       implicit real*8 (a-h,o-z)
6648       include 'DIMENSIONS'
6649       include 'COMMON.LOCAL'
6650       include 'COMMON.GEO'
6651       include 'COMMON.INTERACT'
6652       include 'COMMON.DERIV'
6653       include 'COMMON.VAR'
6654       include 'COMMON.CHAIN'
6655       include 'COMMON.IOUNITS'
6656       include 'COMMON.NAMES'
6657       include 'COMMON.FFIELD'
6658       include 'COMMON.CONTROL'
6659       include 'COMMON.TORCNSTR'
6660       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6661      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6662      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6663      & sinph1ph2(maxdouble,maxdouble)
6664       logical lprn /.false./, lprn1 /.false./
6665       etheta=0.0D0
6666       do i=ithet_start,ithet_end
6667 c        print *,i,itype(i-1),itype(i),itype(i-2)
6668 C        if (itype(i-1).eq.ntyp1) cycle
6669         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6670      &  .or.itype(i).eq.ntyp1) cycle
6671 C        print *,i,theta(i)
6672         if (iabs(itype(i+1)).eq.20) iblock=2
6673         if (iabs(itype(i+1)).ne.20) iblock=1
6674         dethetai=0.0d0
6675         dephii=0.0d0
6676         dephii1=0.0d0
6677         theti2=0.5d0*theta(i)
6678         ityp2=ithetyp((itype(i-1)))
6679         do k=1,nntheterm
6680           coskt(k)=dcos(k*theti2)
6681           sinkt(k)=dsin(k*theti2)
6682         enddo
6683 C        print *,ethetai
6684         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6685 #ifdef OSF
6686           phii=phi(i)
6687           if (phii.ne.phii) phii=150.0
6688 #else
6689           phii=phi(i)
6690 #endif
6691           ityp1=ithetyp((itype(i-2)))
6692 C propagation of chirality for glycine type
6693           do k=1,nsingle
6694             cosph1(k)=dcos(k*phii)
6695             sinph1(k)=dsin(k*phii)
6696           enddo
6697         else
6698           phii=0.0d0
6699           do k=1,nsingle
6700           ityp1=ithetyp((itype(i-2)))
6701             cosph1(k)=0.0d0
6702             sinph1(k)=0.0d0
6703           enddo
6704         endif
6705         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6706 #ifdef OSF
6707           phii1=phi(i+1)
6708           if (phii1.ne.phii1) phii1=150.0
6709           phii1=pinorm(phii1)
6710 #else
6711           phii1=phi(i+1)
6712 #endif
6713           ityp3=ithetyp((itype(i)))
6714           do k=1,nsingle
6715             cosph2(k)=dcos(k*phii1)
6716             sinph2(k)=dsin(k*phii1)
6717           enddo
6718         else
6719           phii1=0.0d0
6720           ityp3=ithetyp((itype(i)))
6721           do k=1,nsingle
6722             cosph2(k)=0.0d0
6723             sinph2(k)=0.0d0
6724           enddo
6725         endif
6726         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6727         do k=1,ndouble
6728           do l=1,k-1
6729             ccl=cosph1(l)*cosph2(k-l)
6730             ssl=sinph1(l)*sinph2(k-l)
6731             scl=sinph1(l)*cosph2(k-l)
6732             csl=cosph1(l)*sinph2(k-l)
6733             cosph1ph2(l,k)=ccl-ssl
6734             cosph1ph2(k,l)=ccl+ssl
6735             sinph1ph2(l,k)=scl+csl
6736             sinph1ph2(k,l)=scl-csl
6737           enddo
6738         enddo
6739         if (lprn) then
6740         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6741      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6742         write (iout,*) "coskt and sinkt"
6743         do k=1,nntheterm
6744           write (iout,*) k,coskt(k),sinkt(k)
6745         enddo
6746         endif
6747         do k=1,ntheterm
6748           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6749           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6750      &      *coskt(k)
6751           if (lprn)
6752      &    write (iout,*) "k",k,"
6753      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6754      &     " ethetai",ethetai
6755         enddo
6756         if (lprn) then
6757         write (iout,*) "cosph and sinph"
6758         do k=1,nsingle
6759           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6760         enddo
6761         write (iout,*) "cosph1ph2 and sinph2ph2"
6762         do k=2,ndouble
6763           do l=1,k-1
6764             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6765      &         sinph1ph2(l,k),sinph1ph2(k,l)
6766           enddo
6767         enddo
6768         write(iout,*) "ethetai",ethetai
6769         endif
6770 C       print *,ethetai
6771         do m=1,ntheterm2
6772           do k=1,nsingle
6773             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6774      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6775      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6776      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6777             ethetai=ethetai+sinkt(m)*aux
6778             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6779             dephii=dephii+k*sinkt(m)*(
6780      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6781      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6782             dephii1=dephii1+k*sinkt(m)*(
6783      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6784      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6785             if (lprn)
6786      &      write (iout,*) "m",m," k",k," bbthet",
6787      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6788      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6789      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6790      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6791 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6792           enddo
6793         enddo
6794 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6795 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6796 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6797 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6798         if (lprn)
6799      &  write(iout,*) "ethetai",ethetai
6800 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6801         do m=1,ntheterm3
6802           do k=2,ndouble
6803             do l=1,k-1
6804               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6805      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6806      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6807      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6808               ethetai=ethetai+sinkt(m)*aux
6809               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6810               dephii=dephii+l*sinkt(m)*(
6811      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6812      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6813      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6814      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6815               dephii1=dephii1+(k-l)*sinkt(m)*(
6816      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6820               if (lprn) then
6821               write (iout,*) "m",m," k",k," l",l," ffthet",
6822      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6823      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6824      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6825      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6826      &            " ethetai",ethetai
6827               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6828      &            cosph1ph2(k,l)*sinkt(m),
6829      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6830               endif
6831             enddo
6832           enddo
6833         enddo
6834 10      continue
6835 c        lprn1=.true.
6836 C        print *,ethetai
6837         if (lprn1)
6838      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6839      &   i,theta(i)*rad2deg,phii*rad2deg,
6840      &   phii1*rad2deg,ethetai
6841 c        lprn1=.false.
6842         etheta=etheta+ethetai
6843         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6844         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6845         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6846       enddo
6847 C now constrains
6848       ethetacnstr=0.0d0
6849 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6850       do i=ithetaconstr_start,ithetaconstr_end
6851         itheta=itheta_constr(i)
6852         thetiii=theta(itheta)
6853         difi=pinorm(thetiii-theta_constr0(i))
6854         if (difi.gt.theta_drange(i)) then
6855           difi=difi-theta_drange(i)
6856           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6857           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6858      &    +for_thet_constr(i)*difi**3
6859         else if (difi.lt.-drange(i)) then
6860           difi=difi+drange(i)
6861           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6862           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6863      &    +for_thet_constr(i)*difi**3
6864         else
6865           difi=0.0
6866         endif
6867        if (energy_dec) then
6868         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6869      &    i,itheta,rad2deg*thetiii,
6870      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6871      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6872      &    gloc(itheta+nphi-2,icg)
6873         endif
6874       enddo
6875
6876       return
6877       end
6878 #endif
6879 #ifdef CRYST_SC
6880 c-----------------------------------------------------------------------------
6881       subroutine esc(escloc)
6882 C Calculate the local energy of a side chain and its derivatives in the
6883 C corresponding virtual-bond valence angles THETA and the spherical angles
6884 C ALPHA and OMEGA.
6885       implicit real*8 (a-h,o-z)
6886       include 'DIMENSIONS'
6887       include 'COMMON.GEO'
6888       include 'COMMON.LOCAL'
6889       include 'COMMON.VAR'
6890       include 'COMMON.INTERACT'
6891       include 'COMMON.DERIV'
6892       include 'COMMON.CHAIN'
6893       include 'COMMON.IOUNITS'
6894       include 'COMMON.NAMES'
6895       include 'COMMON.FFIELD'
6896       include 'COMMON.CONTROL'
6897       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6898      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6899       common /sccalc/ time11,time12,time112,theti,it,nlobit
6900       delta=0.02d0*pi
6901       escloc=0.0D0
6902 c     write (iout,'(a)') 'ESC'
6903       do i=loc_start,loc_end
6904         it=itype(i)
6905         if (it.eq.ntyp1) cycle
6906         if (it.eq.10) goto 1
6907         nlobit=nlob(iabs(it))
6908 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6909 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6910         theti=theta(i+1)-pipol
6911         x(1)=dtan(theti)
6912         x(2)=alph(i)
6913         x(3)=omeg(i)
6914
6915         if (x(2).gt.pi-delta) then
6916           xtemp(1)=x(1)
6917           xtemp(2)=pi-delta
6918           xtemp(3)=x(3)
6919           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6920           xtemp(2)=pi
6921           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6922           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6923      &        escloci,dersc(2))
6924           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6925      &        ddersc0(1),dersc(1))
6926           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6927      &        ddersc0(3),dersc(3))
6928           xtemp(2)=pi-delta
6929           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6930           xtemp(2)=pi
6931           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6932           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6933      &            dersc0(2),esclocbi,dersc02)
6934           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6935      &            dersc12,dersc01)
6936           call splinthet(x(2),0.5d0*delta,ss,ssd)
6937           dersc0(1)=dersc01
6938           dersc0(2)=dersc02
6939           dersc0(3)=0.0d0
6940           do k=1,3
6941             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6942           enddo
6943           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6944 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6945 c    &             esclocbi,ss,ssd
6946           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6947 c         escloci=esclocbi
6948 c         write (iout,*) escloci
6949         else if (x(2).lt.delta) then
6950           xtemp(1)=x(1)
6951           xtemp(2)=delta
6952           xtemp(3)=x(3)
6953           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6954           xtemp(2)=0.0d0
6955           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6956           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6957      &        escloci,dersc(2))
6958           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6959      &        ddersc0(1),dersc(1))
6960           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6961      &        ddersc0(3),dersc(3))
6962           xtemp(2)=delta
6963           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6964           xtemp(2)=0.0d0
6965           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6966           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6967      &            dersc0(2),esclocbi,dersc02)
6968           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6969      &            dersc12,dersc01)
6970           dersc0(1)=dersc01
6971           dersc0(2)=dersc02
6972           dersc0(3)=0.0d0
6973           call splinthet(x(2),0.5d0*delta,ss,ssd)
6974           do k=1,3
6975             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6976           enddo
6977           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6978 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6979 c    &             esclocbi,ss,ssd
6980           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6981 c         write (iout,*) escloci
6982         else
6983           call enesc(x,escloci,dersc,ddummy,.false.)
6984         endif
6985
6986         escloc=escloc+escloci
6987         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6988      &     'escloc',i,escloci
6989 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6990
6991         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6992      &   wscloc*dersc(1)
6993         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6994         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6995     1   continue
6996       enddo
6997       return
6998       end
6999 C---------------------------------------------------------------------------
7000       subroutine enesc(x,escloci,dersc,ddersc,mixed)
7001       implicit real*8 (a-h,o-z)
7002       include 'DIMENSIONS'
7003       include 'COMMON.GEO'
7004       include 'COMMON.LOCAL'
7005       include 'COMMON.IOUNITS'
7006       common /sccalc/ time11,time12,time112,theti,it,nlobit
7007       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7008       double precision contr(maxlob,-1:1)
7009       logical mixed
7010 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7011         escloc_i=0.0D0
7012         do j=1,3
7013           dersc(j)=0.0D0
7014           if (mixed) ddersc(j)=0.0d0
7015         enddo
7016         x3=x(3)
7017
7018 C Because of periodicity of the dependence of the SC energy in omega we have
7019 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7020 C To avoid underflows, first compute & store the exponents.
7021
7022         do iii=-1,1
7023
7024           x(3)=x3+iii*dwapi
7025
7026           do j=1,nlobit
7027             do k=1,3
7028               z(k)=x(k)-censc(k,j,it)
7029             enddo
7030             do k=1,3
7031               Axk=0.0D0
7032               do l=1,3
7033                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7034               enddo
7035               Ax(k,j,iii)=Axk
7036             enddo
7037             expfac=0.0D0
7038             do k=1,3
7039               expfac=expfac+Ax(k,j,iii)*z(k)
7040             enddo
7041             contr(j,iii)=expfac
7042           enddo ! j
7043
7044         enddo ! iii
7045
7046         x(3)=x3
7047 C As in the case of ebend, we want to avoid underflows in exponentiation and
7048 C subsequent NaNs and INFs in energy calculation.
7049 C Find the largest exponent
7050         emin=contr(1,-1)
7051         do iii=-1,1
7052           do j=1,nlobit
7053             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7054           enddo
7055         enddo
7056         emin=0.5D0*emin
7057 cd      print *,'it=',it,' emin=',emin
7058
7059 C Compute the contribution to SC energy and derivatives
7060         do iii=-1,1
7061
7062           do j=1,nlobit
7063 #ifdef OSF
7064             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7065             if(adexp.ne.adexp) adexp=1.0
7066             expfac=dexp(adexp)
7067 #else
7068             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7069 #endif
7070 cd          print *,'j=',j,' expfac=',expfac
7071             escloc_i=escloc_i+expfac
7072             do k=1,3
7073               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7074             enddo
7075             if (mixed) then
7076               do k=1,3,2
7077                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7078      &            +gaussc(k,2,j,it))*expfac
7079               enddo
7080             endif
7081           enddo
7082
7083         enddo ! iii
7084
7085         dersc(1)=dersc(1)/cos(theti)**2
7086         ddersc(1)=ddersc(1)/cos(theti)**2
7087         ddersc(3)=ddersc(3)
7088
7089         escloci=-(dlog(escloc_i)-emin)
7090         do j=1,3
7091           dersc(j)=dersc(j)/escloc_i
7092         enddo
7093         if (mixed) then
7094           do j=1,3,2
7095             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7096           enddo
7097         endif
7098       return
7099       end
7100 C------------------------------------------------------------------------------
7101       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7102       implicit real*8 (a-h,o-z)
7103       include 'DIMENSIONS'
7104       include 'COMMON.GEO'
7105       include 'COMMON.LOCAL'
7106       include 'COMMON.IOUNITS'
7107       common /sccalc/ time11,time12,time112,theti,it,nlobit
7108       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7109       double precision contr(maxlob)
7110       logical mixed
7111
7112       escloc_i=0.0D0
7113
7114       do j=1,3
7115         dersc(j)=0.0D0
7116       enddo
7117
7118       do j=1,nlobit
7119         do k=1,2
7120           z(k)=x(k)-censc(k,j,it)
7121         enddo
7122         z(3)=dwapi
7123         do k=1,3
7124           Axk=0.0D0
7125           do l=1,3
7126             Axk=Axk+gaussc(l,k,j,it)*z(l)
7127           enddo
7128           Ax(k,j)=Axk
7129         enddo
7130         expfac=0.0D0
7131         do k=1,3
7132           expfac=expfac+Ax(k,j)*z(k)
7133         enddo
7134         contr(j)=expfac
7135       enddo ! j
7136
7137 C As in the case of ebend, we want to avoid underflows in exponentiation and
7138 C subsequent NaNs and INFs in energy calculation.
7139 C Find the largest exponent
7140       emin=contr(1)
7141       do j=1,nlobit
7142         if (emin.gt.contr(j)) emin=contr(j)
7143       enddo
7144       emin=0.5D0*emin
7145
7146 C Compute the contribution to SC energy and derivatives
7147
7148       dersc12=0.0d0
7149       do j=1,nlobit
7150         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7151         escloc_i=escloc_i+expfac
7152         do k=1,2
7153           dersc(k)=dersc(k)+Ax(k,j)*expfac
7154         enddo
7155         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7156      &            +gaussc(1,2,j,it))*expfac
7157         dersc(3)=0.0d0
7158       enddo
7159
7160       dersc(1)=dersc(1)/cos(theti)**2
7161       dersc12=dersc12/cos(theti)**2
7162       escloci=-(dlog(escloc_i)-emin)
7163       do j=1,2
7164         dersc(j)=dersc(j)/escloc_i
7165       enddo
7166       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7167       return
7168       end
7169 #else
7170 c----------------------------------------------------------------------------------
7171       subroutine esc(escloc)
7172 C Calculate the local energy of a side chain and its derivatives in the
7173 C corresponding virtual-bond valence angles THETA and the spherical angles
7174 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7175 C added by Urszula Kozlowska. 07/11/2007
7176 C
7177       implicit real*8 (a-h,o-z)
7178       include 'DIMENSIONS'
7179       include 'COMMON.GEO'
7180       include 'COMMON.LOCAL'
7181       include 'COMMON.VAR'
7182       include 'COMMON.SCROT'
7183       include 'COMMON.INTERACT'
7184       include 'COMMON.DERIV'
7185       include 'COMMON.CHAIN'
7186       include 'COMMON.IOUNITS'
7187       include 'COMMON.NAMES'
7188       include 'COMMON.FFIELD'
7189       include 'COMMON.CONTROL'
7190       include 'COMMON.VECTORS'
7191       double precision x_prime(3),y_prime(3),z_prime(3)
7192      &    , sumene,dsc_i,dp2_i,x(65),
7193      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7194      &    de_dxx,de_dyy,de_dzz,de_dt
7195       double precision s1_t,s1_6_t,s2_t,s2_6_t
7196       double precision
7197      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7198      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7199      & dt_dCi(3),dt_dCi1(3)
7200       common /sccalc/ time11,time12,time112,theti,it,nlobit
7201       delta=0.02d0*pi
7202       escloc=0.0D0
7203       do i=loc_start,loc_end
7204         if (itype(i).eq.ntyp1) cycle
7205         costtab(i+1) =dcos(theta(i+1))
7206         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7207         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7208         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7209         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7210         cosfac=dsqrt(cosfac2)
7211         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7212         sinfac=dsqrt(sinfac2)
7213         it=iabs(itype(i))
7214         if (it.eq.10) goto 1
7215 c
7216 C  Compute the axes of tghe local cartesian coordinates system; store in
7217 c   x_prime, y_prime and z_prime
7218 c
7219         do j=1,3
7220           x_prime(j) = 0.00
7221           y_prime(j) = 0.00
7222           z_prime(j) = 0.00
7223         enddo
7224 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7225 C     &   dc_norm(3,i+nres)
7226         do j = 1,3
7227           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7228           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7229         enddo
7230         do j = 1,3
7231           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7232         enddo
7233 c       write (2,*) "i",i
7234 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7235 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7236 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7237 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7238 c      & " xy",scalar(x_prime(1),y_prime(1)),
7239 c      & " xz",scalar(x_prime(1),z_prime(1)),
7240 c      & " yy",scalar(y_prime(1),y_prime(1)),
7241 c      & " yz",scalar(y_prime(1),z_prime(1)),
7242 c      & " zz",scalar(z_prime(1),z_prime(1))
7243 c
7244 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7245 C to local coordinate system. Store in xx, yy, zz.
7246 c
7247         xx=0.0d0
7248         yy=0.0d0
7249         zz=0.0d0
7250         do j = 1,3
7251           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7252           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7253           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7254         enddo
7255
7256         xxtab(i)=xx
7257         yytab(i)=yy
7258         zztab(i)=zz
7259 C
7260 C Compute the energy of the ith side cbain
7261 C
7262 c        write (2,*) "xx",xx," yy",yy," zz",zz
7263         it=iabs(itype(i))
7264         do j = 1,65
7265           x(j) = sc_parmin(j,it)
7266         enddo
7267 #ifdef CHECK_COORD
7268 Cc diagnostics - remove later
7269         xx1 = dcos(alph(2))
7270         yy1 = dsin(alph(2))*dcos(omeg(2))
7271         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7272         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7273      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7274      &    xx1,yy1,zz1
7275 C,"  --- ", xx_w,yy_w,zz_w
7276 c end diagnostics
7277 #endif
7278         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7279      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7280      &   + x(10)*yy*zz
7281         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7282      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7283      & + x(20)*yy*zz
7284         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7285      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7286      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7287      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7288      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7289      &  +x(40)*xx*yy*zz
7290         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7291      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7292      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7293      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7294      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7295      &  +x(60)*xx*yy*zz
7296         dsc_i   = 0.743d0+x(61)
7297         dp2_i   = 1.9d0+x(62)
7298         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7299      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7300         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7301      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7302         s1=(1+x(63))/(0.1d0 + dscp1)
7303         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7304         s2=(1+x(65))/(0.1d0 + dscp2)
7305         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7306         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7307      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7308 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7309 c     &   sumene4,
7310 c     &   dscp1,dscp2,sumene
7311 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7312         escloc = escloc + sumene
7313 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7314 c     & ,zz,xx,yy
7315 c#define DEBUG
7316 #ifdef DEBUG
7317 C
7318 C This section to check the numerical derivatives of the energy of ith side
7319 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7320 C #define DEBUG in the code to turn it on.
7321 C
7322         write (2,*) "sumene               =",sumene
7323         aincr=1.0d-7
7324         xxsave=xx
7325         xx=xx+aincr
7326         write (2,*) xx,yy,zz
7327         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7328         de_dxx_num=(sumenep-sumene)/aincr
7329         xx=xxsave
7330         write (2,*) "xx+ sumene from enesc=",sumenep
7331         yysave=yy
7332         yy=yy+aincr
7333         write (2,*) xx,yy,zz
7334         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7335         de_dyy_num=(sumenep-sumene)/aincr
7336         yy=yysave
7337         write (2,*) "yy+ sumene from enesc=",sumenep
7338         zzsave=zz
7339         zz=zz+aincr
7340         write (2,*) xx,yy,zz
7341         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7342         de_dzz_num=(sumenep-sumene)/aincr
7343         zz=zzsave
7344         write (2,*) "zz+ sumene from enesc=",sumenep
7345         costsave=cost2tab(i+1)
7346         sintsave=sint2tab(i+1)
7347         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7348         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7349         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7350         de_dt_num=(sumenep-sumene)/aincr
7351         write (2,*) " t+ sumene from enesc=",sumenep
7352         cost2tab(i+1)=costsave
7353         sint2tab(i+1)=sintsave
7354 C End of diagnostics section.
7355 #endif
7356 C
7357 C Compute the gradient of esc
7358 C
7359 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7360         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7361         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7362         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7363         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7364         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7365         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7366         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7367         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7368         pom1=(sumene3*sint2tab(i+1)+sumene1)
7369      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7370         pom2=(sumene4*cost2tab(i+1)+sumene2)
7371      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7372         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7373         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7374      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7375      &  +x(40)*yy*zz
7376         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7377         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7378      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7379      &  +x(60)*yy*zz
7380         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7381      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7382      &        +(pom1+pom2)*pom_dx
7383 #ifdef DEBUG
7384         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7385 #endif
7386 C
7387         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7388         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7389      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7390      &  +x(40)*xx*zz
7391         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7392         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7393      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7394      &  +x(59)*zz**2 +x(60)*xx*zz
7395         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7396      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7397      &        +(pom1-pom2)*pom_dy
7398 #ifdef DEBUG
7399         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7400 #endif
7401 C
7402         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7403      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7404      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7405      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7406      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7407      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7408      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7409      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7410 #ifdef DEBUG
7411         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7412 #endif
7413 C
7414         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7415      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7416      &  +pom1*pom_dt1+pom2*pom_dt2
7417 #ifdef DEBUG
7418         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7419 #endif
7420 c#undef DEBUG
7421 c
7422 C
7423        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7424        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7425        cosfac2xx=cosfac2*xx
7426        sinfac2yy=sinfac2*yy
7427        do k = 1,3
7428          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7429      &      vbld_inv(i+1)
7430          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7431      &      vbld_inv(i)
7432          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7433          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7434 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7435 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7436 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7437 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7438          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7439          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7440          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7441          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7442          dZZ_Ci1(k)=0.0d0
7443          dZZ_Ci(k)=0.0d0
7444          do j=1,3
7445            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7446      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7447            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7448      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7449          enddo
7450
7451          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7452          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7453          dZZ_XYZ(k)=vbld_inv(i+nres)*
7454      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7455 c
7456          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7457          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7458        enddo
7459
7460        do k=1,3
7461          dXX_Ctab(k,i)=dXX_Ci(k)
7462          dXX_C1tab(k,i)=dXX_Ci1(k)
7463          dYY_Ctab(k,i)=dYY_Ci(k)
7464          dYY_C1tab(k,i)=dYY_Ci1(k)
7465          dZZ_Ctab(k,i)=dZZ_Ci(k)
7466          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7467          dXX_XYZtab(k,i)=dXX_XYZ(k)
7468          dYY_XYZtab(k,i)=dYY_XYZ(k)
7469          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7470        enddo
7471
7472        do k = 1,3
7473 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7474 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7475 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7476 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7477 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7478 c     &    dt_dci(k)
7479 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7480 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7481          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7482      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7483          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7484      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7485          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7486      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7487        enddo
7488 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7489 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7490
7491 C to check gradient call subroutine check_grad
7492
7493     1 continue
7494       enddo
7495       return
7496       end
7497 c------------------------------------------------------------------------------
7498       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7499       implicit none
7500       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7501      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7502       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7503      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7504      &   + x(10)*yy*zz
7505       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7506      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7507      & + x(20)*yy*zz
7508       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7509      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7510      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7511      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7512      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7513      &  +x(40)*xx*yy*zz
7514       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7515      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7516      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7517      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7518      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7519      &  +x(60)*xx*yy*zz
7520       dsc_i   = 0.743d0+x(61)
7521       dp2_i   = 1.9d0+x(62)
7522       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7523      &          *(xx*cost2+yy*sint2))
7524       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7525      &          *(xx*cost2-yy*sint2))
7526       s1=(1+x(63))/(0.1d0 + dscp1)
7527       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7528       s2=(1+x(65))/(0.1d0 + dscp2)
7529       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7530       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7531      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7532       enesc=sumene
7533       return
7534       end
7535 #endif
7536 c------------------------------------------------------------------------------
7537       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7538 C
7539 C This procedure calculates two-body contact function g(rij) and its derivative:
7540 C
7541 C           eps0ij                                     !       x < -1
7542 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7543 C            0                                         !       x > 1
7544 C
7545 C where x=(rij-r0ij)/delta
7546 C
7547 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7548 C
7549       implicit none
7550       double precision rij,r0ij,eps0ij,fcont,fprimcont
7551       double precision x,x2,x4,delta
7552 c     delta=0.02D0*r0ij
7553 c      delta=0.2D0*r0ij
7554       x=(rij-r0ij)/delta
7555       if (x.lt.-1.0D0) then
7556         fcont=eps0ij
7557         fprimcont=0.0D0
7558       else if (x.le.1.0D0) then
7559         x2=x*x
7560         x4=x2*x2
7561         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7562         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7563       else
7564         fcont=0.0D0
7565         fprimcont=0.0D0
7566       endif
7567       return
7568       end
7569 c------------------------------------------------------------------------------
7570       subroutine splinthet(theti,delta,ss,ssder)
7571       implicit real*8 (a-h,o-z)
7572       include 'DIMENSIONS'
7573       include 'COMMON.VAR'
7574       include 'COMMON.GEO'
7575       thetup=pi-delta
7576       thetlow=delta
7577       if (theti.gt.pipol) then
7578         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7579       else
7580         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7581         ssder=-ssder
7582       endif
7583       return
7584       end
7585 c------------------------------------------------------------------------------
7586       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7587       implicit none
7588       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7589       double precision ksi,ksi2,ksi3,a1,a2,a3
7590       a1=fprim0*delta/(f1-f0)
7591       a2=3.0d0-2.0d0*a1
7592       a3=a1-2.0d0
7593       ksi=(x-x0)/delta
7594       ksi2=ksi*ksi
7595       ksi3=ksi2*ksi
7596       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7597       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7598       return
7599       end
7600 c------------------------------------------------------------------------------
7601       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7602       implicit none
7603       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7604       double precision ksi,ksi2,ksi3,a1,a2,a3
7605       ksi=(x-x0)/delta
7606       ksi2=ksi*ksi
7607       ksi3=ksi2*ksi
7608       a1=fprim0x*delta
7609       a2=3*(f1x-f0x)-2*fprim0x*delta
7610       a3=fprim0x*delta-2*(f1x-f0x)
7611       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7612       return
7613       end
7614 C-----------------------------------------------------------------------------
7615 #ifdef CRYST_TOR
7616 C-----------------------------------------------------------------------------
7617       subroutine etor(etors,edihcnstr)
7618       implicit real*8 (a-h,o-z)
7619       include 'DIMENSIONS'
7620       include 'COMMON.VAR'
7621       include 'COMMON.GEO'
7622       include 'COMMON.LOCAL'
7623       include 'COMMON.TORSION'
7624       include 'COMMON.INTERACT'
7625       include 'COMMON.DERIV'
7626       include 'COMMON.CHAIN'
7627       include 'COMMON.NAMES'
7628       include 'COMMON.IOUNITS'
7629       include 'COMMON.FFIELD'
7630       include 'COMMON.TORCNSTR'
7631       include 'COMMON.CONTROL'
7632       logical lprn
7633 C Set lprn=.true. for debugging
7634       lprn=.false.
7635 c      lprn=.true.
7636       etors=0.0D0
7637       do i=iphi_start,iphi_end
7638       etors_ii=0.0D0
7639         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7640      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7641         itori=itortyp(itype(i-2))
7642         itori1=itortyp(itype(i-1))
7643         phii=phi(i)
7644         gloci=0.0D0
7645 C Proline-Proline pair is a special case...
7646         if (itori.eq.3 .and. itori1.eq.3) then
7647           if (phii.gt.-dwapi3) then
7648             cosphi=dcos(3*phii)
7649             fac=1.0D0/(1.0D0-cosphi)
7650             etorsi=v1(1,3,3)*fac
7651             etorsi=etorsi+etorsi
7652             etors=etors+etorsi-v1(1,3,3)
7653             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7654             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7655           endif
7656           do j=1,3
7657             v1ij=v1(j+1,itori,itori1)
7658             v2ij=v2(j+1,itori,itori1)
7659             cosphi=dcos(j*phii)
7660             sinphi=dsin(j*phii)
7661             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7662             if (energy_dec) etors_ii=etors_ii+
7663      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7664             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7665           enddo
7666         else
7667           do j=1,nterm_old
7668             v1ij=v1(j,itori,itori1)
7669             v2ij=v2(j,itori,itori1)
7670             cosphi=dcos(j*phii)
7671             sinphi=dsin(j*phii)
7672             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7673             if (energy_dec) etors_ii=etors_ii+
7674      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7675             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7676           enddo
7677         endif
7678         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7679              'etor',i,etors_ii
7680         if (lprn)
7681      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7682      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7683      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7684         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7685 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7686       enddo
7687 ! 6/20/98 - dihedral angle constraints
7688       edihcnstr=0.0d0
7689       do i=1,ndih_constr
7690         itori=idih_constr(i)
7691         phii=phi(itori)
7692         difi=phii-phi0(i)
7693         if (difi.gt.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         else if (difi.lt.-drange(i)) then
7698           difi=difi+drange(i)
7699           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7700           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7701         endif
7702 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7703 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7704       enddo
7705 !      write (iout,*) 'edihcnstr',edihcnstr
7706       return
7707       end
7708 c------------------------------------------------------------------------------
7709       subroutine etor_d(etors_d)
7710       etors_d=0.0d0
7711       return
7712       end
7713 c----------------------------------------------------------------------------
7714 #else
7715       subroutine etor(etors,edihcnstr)
7716       implicit real*8 (a-h,o-z)
7717       include 'DIMENSIONS'
7718       include 'COMMON.VAR'
7719       include 'COMMON.GEO'
7720       include 'COMMON.LOCAL'
7721       include 'COMMON.TORSION'
7722       include 'COMMON.INTERACT'
7723       include 'COMMON.DERIV'
7724       include 'COMMON.CHAIN'
7725       include 'COMMON.NAMES'
7726       include 'COMMON.IOUNITS'
7727       include 'COMMON.FFIELD'
7728       include 'COMMON.TORCNSTR'
7729       include 'COMMON.CONTROL'
7730       logical lprn
7731 C Set lprn=.true. for debugging
7732       lprn=.false.
7733 c     lprn=.true.
7734       etors=0.0D0
7735       do i=iphi_start,iphi_end
7736 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7737 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7738 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7739 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7740         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7741      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7742 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7743 C For introducing the NH3+ and COO- group please check the etor_d for reference
7744 C and guidance
7745         etors_ii=0.0D0
7746          if (iabs(itype(i)).eq.20) then
7747          iblock=2
7748          else
7749          iblock=1
7750          endif
7751         itori=itortyp(itype(i-2))
7752         itori1=itortyp(itype(i-1))
7753         phii=phi(i)
7754         gloci=0.0D0
7755 C Regular cosine and sine terms
7756         do j=1,nterm(itori,itori1,iblock)
7757           v1ij=v1(j,itori,itori1,iblock)
7758           v2ij=v2(j,itori,itori1,iblock)
7759           cosphi=dcos(j*phii)
7760           sinphi=dsin(j*phii)
7761           etors=etors+v1ij*cosphi+v2ij*sinphi
7762           if (energy_dec) etors_ii=etors_ii+
7763      &                v1ij*cosphi+v2ij*sinphi
7764           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7765         enddo
7766 C Lorentz terms
7767 C                         v1
7768 C  E = SUM ----------------------------------- - v1
7769 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7770 C
7771         cosphi=dcos(0.5d0*phii)
7772         sinphi=dsin(0.5d0*phii)
7773         do j=1,nlor(itori,itori1,iblock)
7774           vl1ij=vlor1(j,itori,itori1)
7775           vl2ij=vlor2(j,itori,itori1)
7776           vl3ij=vlor3(j,itori,itori1)
7777           pom=vl2ij*cosphi+vl3ij*sinphi
7778           pom1=1.0d0/(pom*pom+1.0d0)
7779           etors=etors+vl1ij*pom1
7780           if (energy_dec) etors_ii=etors_ii+
7781      &                vl1ij*pom1
7782           pom=-pom*pom1*pom1
7783           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7784         enddo
7785 C Subtract the constant term
7786         etors=etors-v0(itori,itori1,iblock)
7787           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7788      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7789         if (lprn)
7790      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7791      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7792      &  (v1(j,itori,itori1,iblock),j=1,6),
7793      &  (v2(j,itori,itori1,iblock),j=1,6)
7794         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7795 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7796       enddo
7797 ! 6/20/98 - dihedral angle constraints
7798       edihcnstr=0.0d0
7799 c      do i=1,ndih_constr
7800       do i=idihconstr_start,idihconstr_end
7801         itori=idih_constr(i)
7802         phii=phi(itori)
7803         difi=pinorm(phii-phi0(i))
7804         if (difi.gt.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 if (difi.lt.-drange(i)) then
7809           difi=difi+drange(i)
7810           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7811           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7812         else
7813           difi=0.0
7814         endif
7815        if (energy_dec) then
7816         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7817      &    i,itori,rad2deg*phii,
7818      &    rad2deg*phi0(i),  rad2deg*drange(i),
7819      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7820         endif
7821       enddo
7822 cd       write (iout,*) 'edihcnstr',edihcnstr
7823       return
7824       end
7825 c----------------------------------------------------------------------------
7826       subroutine etor_d(etors_d)
7827 C 6/23/01 Compute double torsional energy
7828       implicit real*8 (a-h,o-z)
7829       include 'DIMENSIONS'
7830       include 'COMMON.VAR'
7831       include 'COMMON.GEO'
7832       include 'COMMON.LOCAL'
7833       include 'COMMON.TORSION'
7834       include 'COMMON.INTERACT'
7835       include 'COMMON.DERIV'
7836       include 'COMMON.CHAIN'
7837       include 'COMMON.NAMES'
7838       include 'COMMON.IOUNITS'
7839       include 'COMMON.FFIELD'
7840       include 'COMMON.TORCNSTR'
7841       logical lprn
7842 C Set lprn=.true. for debugging
7843       lprn=.false.
7844 c     lprn=.true.
7845       etors_d=0.0D0
7846 c      write(iout,*) "a tu??"
7847       do i=iphid_start,iphid_end
7848 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7849 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7850 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7851 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7852 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7853          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7854      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7855      &  (itype(i+1).eq.ntyp1)) cycle
7856 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7857         itori=itortyp(itype(i-2))
7858         itori1=itortyp(itype(i-1))
7859         itori2=itortyp(itype(i))
7860         phii=phi(i)
7861         phii1=phi(i+1)
7862         gloci1=0.0D0
7863         gloci2=0.0D0
7864         iblock=1
7865         if (iabs(itype(i+1)).eq.20) iblock=2
7866 C Iblock=2 Proline type
7867 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7868 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7869 C        if (itype(i+1).eq.ntyp1) iblock=3
7870 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7871 C IS or IS NOT need for this
7872 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7873 C        is (itype(i-3).eq.ntyp1) ntblock=2
7874 C        ntblock is N-terminal blocking group
7875
7876 C Regular cosine and sine terms
7877         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7878 C Example of changes for NH3+ blocking group
7879 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7880 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7881           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7882           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7883           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7884           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7885           cosphi1=dcos(j*phii)
7886           sinphi1=dsin(j*phii)
7887           cosphi2=dcos(j*phii1)
7888           sinphi2=dsin(j*phii1)
7889           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7890      &     v2cij*cosphi2+v2sij*sinphi2
7891           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7892           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7893         enddo
7894         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7895           do l=1,k-1
7896             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7897             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7898             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7899             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7900             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7901             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7902             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7903             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7904             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7905      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7906             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7907      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7908             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7909      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7910           enddo
7911         enddo
7912         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7913         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7914       enddo
7915       return
7916       end
7917 #endif
7918 C----------------------------------------------------------------------------------
7919 C The rigorous attempt to derive energy function
7920       subroutine etor_kcc(etors,edihcnstr)
7921       implicit real*8 (a-h,o-z)
7922       include 'DIMENSIONS'
7923       include 'COMMON.VAR'
7924       include 'COMMON.GEO'
7925       include 'COMMON.LOCAL'
7926       include 'COMMON.TORSION'
7927       include 'COMMON.INTERACT'
7928       include 'COMMON.DERIV'
7929       include 'COMMON.CHAIN'
7930       include 'COMMON.NAMES'
7931       include 'COMMON.IOUNITS'
7932       include 'COMMON.FFIELD'
7933       include 'COMMON.TORCNSTR'
7934       include 'COMMON.CONTROL'
7935       logical lprn
7936 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7937 C Set lprn=.true. for debugging
7938       lprn=.false.
7939 c     lprn=.true.
7940 C      print *,"wchodze kcc"
7941       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7942       if (tor_mode.ne.2) then
7943       etors=0.0D0
7944       endif
7945       do i=iphi_start,iphi_end
7946 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7947 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7948 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7949 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7950         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7951      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7952         itori=itortyp_kcc(itype(i-2))
7953         itori1=itortyp_kcc(itype(i-1))
7954         phii=phi(i)
7955         glocig=0.0D0
7956         glocit1=0.0d0
7957         glocit2=0.0d0
7958         sumnonchebyshev=0.0d0
7959         sumchebyshev=0.0d0
7960 C to avoid multiple devision by 2
7961 c        theti22=0.5d0*theta(i)
7962 C theta 12 is the theta_1 /2
7963 C theta 22 is theta_2 /2
7964 c        theti12=0.5d0*theta(i-1)
7965 C and appropriate sinus function
7966         sinthet1=dsin(theta(i-1))
7967         sinthet2=dsin(theta(i))
7968         costhet1=dcos(theta(i-1))
7969         costhet2=dcos(theta(i))
7970 c Cosines of halves thetas
7971         costheti12=0.5d0*(1.0d0+costhet1)
7972         costheti22=0.5d0*(1.0d0+costhet2)
7973 C to speed up lets store its mutliplication
7974         sint1t2=sinthet2*sinthet1
7975         sint1t2n=1.0d0
7976 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7977 C +d_n*sin(n*gamma)) *
7978 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7979 C we have two sum 1) Non-Chebyshev which is with n and gamma
7980         etori=0.0d0
7981         do j=1,nterm_kcc(itori,itori1)
7982
7983           nval=nterm_kcc_Tb(itori,itori1)
7984           v1ij=v1_kcc(j,itori,itori1)
7985           v2ij=v2_kcc(j,itori,itori1)
7986 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7987 C v1ij is c_n and d_n in euation above
7988           cosphi=dcos(j*phii)
7989           sinphi=dsin(j*phii)
7990           sint1t2n1=sint1t2n
7991           sint1t2n=sint1t2n*sint1t2
7992           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7993      &        costheti12)
7994           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7995      &        v11_chyb(1,j,itori,itori1),costheti12)
7996 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7997 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7998           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7999      &        costheti22)
8000           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8001      &        v21_chyb(1,j,itori,itori1),costheti22)
8002 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
8003 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
8004           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
8005      &        costheti12)
8006           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8007      &        v12_chyb(1,j,itori,itori1),costheti12)
8008 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8009 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8010           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8011      &        costheti22)
8012           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8013      &        v22_chyb(1,j,itori,itori1),costheti22)
8014 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8015 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8016 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8017 C          if (energy_dec) etors_ii=etors_ii+
8018 C     &                v1ij*cosphi+v2ij*sinphi
8019 C glocig is the gradient local i site in gamma
8020           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8021           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8022           etori=etori+sint1t2n*(actval1+actval2)
8023           glocig=glocig+
8024      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8025      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8026 C now gradient over theta_1
8027           glocit1=glocit1+
8028      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8029      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8030           glocit2=glocit2+
8031      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8032      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8033
8034 C now the Czebyshev polinominal sum
8035 c        do k=1,nterm_kcc_Tb(itori,itori1)
8036 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
8037 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
8038 C         thybt1(k)=0.0
8039 C         thybt2(k)=0.0
8040 c        enddo
8041 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8042 C     &         gradtschebyshev
8043 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8044 C     &         dcos(theti22)**2),
8045 C     &         dsin(theti22)
8046
8047 C now overal sumation
8048 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8049         enddo ! j
8050         etors=etors+etori
8051 C derivative over gamma
8052         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8053 C derivative over theta1
8054         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8055 C now derivative over theta2
8056         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8057         if (lprn)
8058      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8059      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8060       enddo
8061 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8062 ! 6/20/98 - dihedral angle constraints
8063       if (tor_mode.ne.2) then
8064       edihcnstr=0.0d0
8065 c      do i=1,ndih_constr
8066       do i=idihconstr_start,idihconstr_end
8067         itori=idih_constr(i)
8068         phii=phi(itori)
8069         difi=pinorm(phii-phi0(i))
8070         if (difi.gt.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 if (difi.lt.-drange(i)) then
8075           difi=difi+drange(i)
8076           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8077           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8078         else
8079           difi=0.0
8080         endif
8081        enddo
8082        endif
8083       return
8084       end
8085
8086 C The rigorous attempt to derive energy function
8087       subroutine ebend_kcc(etheta,ethetacnstr)
8088
8089       implicit real*8 (a-h,o-z)
8090       include 'DIMENSIONS'
8091       include 'COMMON.VAR'
8092       include 'COMMON.GEO'
8093       include 'COMMON.LOCAL'
8094       include 'COMMON.TORSION'
8095       include 'COMMON.INTERACT'
8096       include 'COMMON.DERIV'
8097       include 'COMMON.CHAIN'
8098       include 'COMMON.NAMES'
8099       include 'COMMON.IOUNITS'
8100       include 'COMMON.FFIELD'
8101       include 'COMMON.TORCNSTR'
8102       include 'COMMON.CONTROL'
8103       logical lprn
8104       double precision thybt1(maxtermkcc)
8105 C Set lprn=.true. for debugging
8106       lprn=.false.
8107 c     lprn=.true.
8108 C      print *,"wchodze kcc"
8109       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8110       if (tor_mode.ne.2) etheta=0.0D0
8111       do i=ithet_start,ithet_end
8112 c        print *,i,itype(i-1),itype(i),itype(i-2)
8113         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8114      &  .or.itype(i).eq.ntyp1) cycle
8115          iti=itortyp_kcc(itype(i-1))
8116         sinthet=dsin(theta(i)/2.0d0)
8117         costhet=dcos(theta(i)/2.0d0)
8118          do j=1,nbend_kcc_Tb(iti)
8119           thybt1(j)=v1bend_chyb(j,iti)
8120          enddo
8121          sumth1thyb=tschebyshev
8122      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8123         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8124      &    sumth1thyb
8125         ihelp=nbend_kcc_Tb(iti)-1
8126         gradthybt1=gradtschebyshev
8127      &         (0,ihelp,thybt1(1),costhet)
8128         etheta=etheta+sumth1thyb
8129 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8130         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8131      &   gradthybt1*sinthet*(-0.5d0)
8132       enddo
8133       if (tor_mode.ne.2) then
8134       ethetacnstr=0.0d0
8135 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8136       do i=ithetaconstr_start,ithetaconstr_end
8137         itheta=itheta_constr(i)
8138         thetiii=theta(itheta)
8139         difi=pinorm(thetiii-theta_constr0(i))
8140         if (difi.gt.theta_drange(i)) then
8141           difi=difi-theta_drange(i)
8142           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8143           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8144      &    +for_thet_constr(i)*difi**3
8145         else if (difi.lt.-drange(i)) then
8146           difi=difi+drange(i)
8147           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8148           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8149      &    +for_thet_constr(i)*difi**3
8150         else
8151           difi=0.0
8152         endif
8153        if (energy_dec) then
8154         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8155      &    i,itheta,rad2deg*thetiii,
8156      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8157      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8158      &    gloc(itheta+nphi-2,icg)
8159         endif
8160       enddo
8161       endif
8162       return
8163       end
8164 c------------------------------------------------------------------------------
8165       subroutine eback_sc_corr(esccor)
8166 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8167 c        conformational states; temporarily implemented as differences
8168 c        between UNRES torsional potentials (dependent on three types of
8169 c        residues) and the torsional potentials dependent on all 20 types
8170 c        of residues computed from AM1  energy surfaces of terminally-blocked
8171 c        amino-acid residues.
8172       implicit real*8 (a-h,o-z)
8173       include 'DIMENSIONS'
8174       include 'COMMON.VAR'
8175       include 'COMMON.GEO'
8176       include 'COMMON.LOCAL'
8177       include 'COMMON.TORSION'
8178       include 'COMMON.SCCOR'
8179       include 'COMMON.INTERACT'
8180       include 'COMMON.DERIV'
8181       include 'COMMON.CHAIN'
8182       include 'COMMON.NAMES'
8183       include 'COMMON.IOUNITS'
8184       include 'COMMON.FFIELD'
8185       include 'COMMON.CONTROL'
8186       logical lprn
8187 C Set lprn=.true. for debugging
8188       lprn=.false.
8189 c      lprn=.true.
8190 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8191       esccor=0.0D0
8192       do i=itau_start,itau_end
8193         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8194         esccor_ii=0.0D0
8195         isccori=isccortyp(itype(i-2))
8196         isccori1=isccortyp(itype(i-1))
8197 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8198         phii=phi(i)
8199         do intertyp=1,3 !intertyp
8200 cc Added 09 May 2012 (Adasko)
8201 cc  Intertyp means interaction type of backbone mainchain correlation:
8202 c   1 = SC...Ca...Ca...Ca
8203 c   2 = Ca...Ca...Ca...SC
8204 c   3 = SC...Ca...Ca...SCi
8205         gloci=0.0D0
8206         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8207      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8208      &      (itype(i-1).eq.ntyp1)))
8209      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8210      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8211      &     .or.(itype(i).eq.ntyp1)))
8212      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8213      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8214      &      (itype(i-3).eq.ntyp1)))) cycle
8215         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8216         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8217      & cycle
8218        do j=1,nterm_sccor(isccori,isccori1)
8219           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8220           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8221           cosphi=dcos(j*tauangle(intertyp,i))
8222           sinphi=dsin(j*tauangle(intertyp,i))
8223           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8224           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8225         enddo
8226 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8227         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8228         if (lprn)
8229      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8230      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8231      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8232      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8233         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8234        enddo !intertyp
8235       enddo
8236
8237       return
8238       end
8239 c----------------------------------------------------------------------------
8240       subroutine multibody(ecorr)
8241 C This subroutine calculates multi-body contributions to energy following
8242 C the idea of Skolnick et al. If side chains I and J make a contact and
8243 C at the same time side chains I+1 and J+1 make a contact, an extra
8244 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8245       implicit real*8 (a-h,o-z)
8246       include 'DIMENSIONS'
8247       include 'COMMON.IOUNITS'
8248       include 'COMMON.DERIV'
8249       include 'COMMON.INTERACT'
8250       include 'COMMON.CONTACTS'
8251       double precision gx(3),gx1(3)
8252       logical lprn
8253
8254 C Set lprn=.true. for debugging
8255       lprn=.false.
8256
8257       if (lprn) then
8258         write (iout,'(a)') 'Contact function values:'
8259         do i=nnt,nct-2
8260           write (iout,'(i2,20(1x,i2,f10.5))')
8261      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8262         enddo
8263       endif
8264       ecorr=0.0D0
8265       do i=nnt,nct
8266         do j=1,3
8267           gradcorr(j,i)=0.0D0
8268           gradxorr(j,i)=0.0D0
8269         enddo
8270       enddo
8271       do i=nnt,nct-2
8272
8273         DO ISHIFT = 3,4
8274
8275         i1=i+ishift
8276         num_conti=num_cont(i)
8277         num_conti1=num_cont(i1)
8278         do jj=1,num_conti
8279           j=jcont(jj,i)
8280           do kk=1,num_conti1
8281             j1=jcont(kk,i1)
8282             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8283 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8284 cd   &                   ' ishift=',ishift
8285 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8286 C The system gains extra energy.
8287               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8288             endif   ! j1==j+-ishift
8289           enddo     ! kk
8290         enddo       ! jj
8291
8292         ENDDO ! ISHIFT
8293
8294       enddo         ! i
8295       return
8296       end
8297 c------------------------------------------------------------------------------
8298       double precision function esccorr(i,j,k,l,jj,kk)
8299       implicit real*8 (a-h,o-z)
8300       include 'DIMENSIONS'
8301       include 'COMMON.IOUNITS'
8302       include 'COMMON.DERIV'
8303       include 'COMMON.INTERACT'
8304       include 'COMMON.CONTACTS'
8305       include 'COMMON.SHIELD'
8306       double precision gx(3),gx1(3)
8307       logical lprn
8308       lprn=.false.
8309       eij=facont(jj,i)
8310       ekl=facont(kk,k)
8311 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8312 C Calculate the multi-body contribution to energy.
8313 C Calculate multi-body contributions to the gradient.
8314 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8315 cd   & k,l,(gacont(m,kk,k),m=1,3)
8316       do m=1,3
8317         gx(m) =ekl*gacont(m,jj,i)
8318         gx1(m)=eij*gacont(m,kk,k)
8319         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8320         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8321         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8322         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8323       enddo
8324       do m=i,j-1
8325         do ll=1,3
8326           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8327         enddo
8328       enddo
8329       do m=k,l-1
8330         do ll=1,3
8331           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8332         enddo
8333       enddo
8334       esccorr=-eij*ekl
8335       return
8336       end
8337 c------------------------------------------------------------------------------
8338       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8339 C This subroutine calculates multi-body contributions to hydrogen-bonding
8340       implicit real*8 (a-h,o-z)
8341       include 'DIMENSIONS'
8342       include 'COMMON.IOUNITS'
8343 #ifdef MPI
8344       include "mpif.h"
8345       parameter (max_cont=maxconts)
8346       parameter (max_dim=26)
8347       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8348       double precision zapas(max_dim,maxconts,max_fg_procs),
8349      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8350       common /przechowalnia/ zapas
8351       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8352      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8353 #endif
8354       include 'COMMON.SETUP'
8355       include 'COMMON.FFIELD'
8356       include 'COMMON.DERIV'
8357       include 'COMMON.INTERACT'
8358       include 'COMMON.CONTACTS'
8359       include 'COMMON.CONTROL'
8360       include 'COMMON.LOCAL'
8361       double precision gx(3),gx1(3),time00
8362       logical lprn,ldone
8363
8364 C Set lprn=.true. for debugging
8365       lprn=.false.
8366 #ifdef MPI
8367       n_corr=0
8368       n_corr1=0
8369       if (nfgtasks.le.1) goto 30
8370       if (lprn) then
8371         write (iout,'(a)') 'Contact function values before RECEIVE:'
8372         do i=nnt,nct-2
8373           write (iout,'(2i3,50(1x,i2,f5.2))')
8374      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8375      &    j=1,num_cont_hb(i))
8376         enddo
8377       endif
8378       call flush(iout)
8379       do i=1,ntask_cont_from
8380         ncont_recv(i)=0
8381       enddo
8382       do i=1,ntask_cont_to
8383         ncont_sent(i)=0
8384       enddo
8385 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8386 c     & ntask_cont_to
8387 C Make the list of contacts to send to send to other procesors
8388 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8389 c      call flush(iout)
8390       do i=iturn3_start,iturn3_end
8391 c        write (iout,*) "make contact list turn3",i," num_cont",
8392 c     &    num_cont_hb(i)
8393         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8394       enddo
8395       do i=iturn4_start,iturn4_end
8396 c        write (iout,*) "make contact list turn4",i," num_cont",
8397 c     &   num_cont_hb(i)
8398         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8399       enddo
8400       do ii=1,nat_sent
8401         i=iat_sent(ii)
8402 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8403 c     &    num_cont_hb(i)
8404         do j=1,num_cont_hb(i)
8405         do k=1,4
8406           jjc=jcont_hb(j,i)
8407           iproc=iint_sent_local(k,jjc,ii)
8408 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8409           if (iproc.gt.0) then
8410             ncont_sent(iproc)=ncont_sent(iproc)+1
8411             nn=ncont_sent(iproc)
8412             zapas(1,nn,iproc)=i
8413             zapas(2,nn,iproc)=jjc
8414             zapas(3,nn,iproc)=facont_hb(j,i)
8415             zapas(4,nn,iproc)=ees0p(j,i)
8416             zapas(5,nn,iproc)=ees0m(j,i)
8417             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8418             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8419             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8420             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8421             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8422             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8423             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8424             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8425             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8426             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8427             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8428             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8429             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8430             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8431             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8432             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8433             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8434             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8435             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8436             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8437             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8438           endif
8439         enddo
8440         enddo
8441       enddo
8442       if (lprn) then
8443       write (iout,*)
8444      &  "Numbers of contacts to be sent to other processors",
8445      &  (ncont_sent(i),i=1,ntask_cont_to)
8446       write (iout,*) "Contacts sent"
8447       do ii=1,ntask_cont_to
8448         nn=ncont_sent(ii)
8449         iproc=itask_cont_to(ii)
8450         write (iout,*) nn," contacts to processor",iproc,
8451      &   " of CONT_TO_COMM group"
8452         do i=1,nn
8453           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8454         enddo
8455       enddo
8456       call flush(iout)
8457       endif
8458       CorrelType=477
8459       CorrelID=fg_rank+1
8460       CorrelType1=478
8461       CorrelID1=nfgtasks+fg_rank+1
8462       ireq=0
8463 C Receive the numbers of needed contacts from other processors
8464       do ii=1,ntask_cont_from
8465         iproc=itask_cont_from(ii)
8466         ireq=ireq+1
8467         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8468      &    FG_COMM,req(ireq),IERR)
8469       enddo
8470 c      write (iout,*) "IRECV ended"
8471 c      call flush(iout)
8472 C Send the number of contacts needed by other processors
8473       do ii=1,ntask_cont_to
8474         iproc=itask_cont_to(ii)
8475         ireq=ireq+1
8476         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8477      &    FG_COMM,req(ireq),IERR)
8478       enddo
8479 c      write (iout,*) "ISEND ended"
8480 c      write (iout,*) "number of requests (nn)",ireq
8481       call flush(iout)
8482       if (ireq.gt.0)
8483      &  call MPI_Waitall(ireq,req,status_array,ierr)
8484 c      write (iout,*)
8485 c     &  "Numbers of contacts to be received from other processors",
8486 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8487 c      call flush(iout)
8488 C Receive contacts
8489       ireq=0
8490       do ii=1,ntask_cont_from
8491         iproc=itask_cont_from(ii)
8492         nn=ncont_recv(ii)
8493 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8494 c     &   " of CONT_TO_COMM group"
8495         call flush(iout)
8496         if (nn.gt.0) then
8497           ireq=ireq+1
8498           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8499      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8500 c          write (iout,*) "ireq,req",ireq,req(ireq)
8501         endif
8502       enddo
8503 C Send the contacts to processors that need them
8504       do ii=1,ntask_cont_to
8505         iproc=itask_cont_to(ii)
8506         nn=ncont_sent(ii)
8507 c        write (iout,*) nn," contacts to processor",iproc,
8508 c     &   " of CONT_TO_COMM group"
8509         if (nn.gt.0) then
8510           ireq=ireq+1
8511           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8512      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8513 c          write (iout,*) "ireq,req",ireq,req(ireq)
8514 c          do i=1,nn
8515 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8516 c          enddo
8517         endif
8518       enddo
8519 c      write (iout,*) "number of requests (contacts)",ireq
8520 c      write (iout,*) "req",(req(i),i=1,4)
8521 c      call flush(iout)
8522       if (ireq.gt.0)
8523      & call MPI_Waitall(ireq,req,status_array,ierr)
8524       do iii=1,ntask_cont_from
8525         iproc=itask_cont_from(iii)
8526         nn=ncont_recv(iii)
8527         if (lprn) then
8528         write (iout,*) "Received",nn," contacts from processor",iproc,
8529      &   " of CONT_FROM_COMM group"
8530         call flush(iout)
8531         do i=1,nn
8532           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8533         enddo
8534         call flush(iout)
8535         endif
8536         do i=1,nn
8537           ii=zapas_recv(1,i,iii)
8538 c Flag the received contacts to prevent double-counting
8539           jj=-zapas_recv(2,i,iii)
8540 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8541 c          call flush(iout)
8542           nnn=num_cont_hb(ii)+1
8543           num_cont_hb(ii)=nnn
8544           jcont_hb(nnn,ii)=jj
8545           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8546           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8547           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8548           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8549           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8550           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8551           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8552           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8553           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8554           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8555           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8556           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8557           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8558           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8559           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8560           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8561           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8562           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8563           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8564           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8565           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8566           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8567           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8568           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8569         enddo
8570       enddo
8571       call flush(iout)
8572       if (lprn) then
8573         write (iout,'(a)') 'Contact function values after receive:'
8574         do i=nnt,nct-2
8575           write (iout,'(2i3,50(1x,i3,f5.2))')
8576      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8577      &    j=1,num_cont_hb(i))
8578         enddo
8579         call flush(iout)
8580       endif
8581    30 continue
8582 #endif
8583       if (lprn) then
8584         write (iout,'(a)') 'Contact function values:'
8585         do i=nnt,nct-2
8586           write (iout,'(2i3,50(1x,i3,f5.2))')
8587      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8588      &    j=1,num_cont_hb(i))
8589         enddo
8590       endif
8591       ecorr=0.0D0
8592 C Remove the loop below after debugging !!!
8593       do i=nnt,nct
8594         do j=1,3
8595           gradcorr(j,i)=0.0D0
8596           gradxorr(j,i)=0.0D0
8597         enddo
8598       enddo
8599 C Calculate the local-electrostatic correlation terms
8600       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8601         i1=i+1
8602         num_conti=num_cont_hb(i)
8603         num_conti1=num_cont_hb(i+1)
8604         do jj=1,num_conti
8605           j=jcont_hb(jj,i)
8606           jp=iabs(j)
8607           do kk=1,num_conti1
8608             j1=jcont_hb(kk,i1)
8609             jp1=iabs(j1)
8610 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8611 c     &         ' jj=',jj,' kk=',kk
8612             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8613      &          .or. j.lt.0 .and. j1.gt.0) .and.
8614      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8615 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8616 C The system gains extra energy.
8617               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8618               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8619      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8620               n_corr=n_corr+1
8621             else if (j1.eq.j) then
8622 C Contacts I-J and I-(J+1) occur simultaneously.
8623 C The system loses extra energy.
8624 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8625             endif
8626           enddo ! kk
8627           do kk=1,num_conti
8628             j1=jcont_hb(kk,i)
8629 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8630 c    &         ' jj=',jj,' kk=',kk
8631             if (j1.eq.j+1) then
8632 C Contacts I-J and (I+1)-J occur simultaneously.
8633 C The system loses extra energy.
8634 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8635             endif ! j1==j+1
8636           enddo ! kk
8637         enddo ! jj
8638       enddo ! i
8639       return
8640       end
8641 c------------------------------------------------------------------------------
8642       subroutine add_hb_contact(ii,jj,itask)
8643       implicit real*8 (a-h,o-z)
8644       include "DIMENSIONS"
8645       include "COMMON.IOUNITS"
8646       integer max_cont
8647       integer max_dim
8648       parameter (max_cont=maxconts)
8649       parameter (max_dim=26)
8650       include "COMMON.CONTACTS"
8651       double precision zapas(max_dim,maxconts,max_fg_procs),
8652      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8653       common /przechowalnia/ zapas
8654       integer i,j,ii,jj,iproc,itask(4),nn
8655 c      write (iout,*) "itask",itask
8656       do i=1,2
8657         iproc=itask(i)
8658         if (iproc.gt.0) then
8659           do j=1,num_cont_hb(ii)
8660             jjc=jcont_hb(j,ii)
8661 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8662             if (jjc.eq.jj) then
8663               ncont_sent(iproc)=ncont_sent(iproc)+1
8664               nn=ncont_sent(iproc)
8665               zapas(1,nn,iproc)=ii
8666               zapas(2,nn,iproc)=jjc
8667               zapas(3,nn,iproc)=facont_hb(j,ii)
8668               zapas(4,nn,iproc)=ees0p(j,ii)
8669               zapas(5,nn,iproc)=ees0m(j,ii)
8670               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8671               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8672               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8673               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8674               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8675               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8676               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8677               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8678               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8679               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8680               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8681               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8682               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8683               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8684               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8685               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8686               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8687               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8688               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8689               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8690               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8691               exit
8692             endif
8693           enddo
8694         endif
8695       enddo
8696       return
8697       end
8698 c------------------------------------------------------------------------------
8699       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8700      &  n_corr1)
8701 C This subroutine calculates multi-body contributions to hydrogen-bonding
8702       implicit real*8 (a-h,o-z)
8703       include 'DIMENSIONS'
8704       include 'COMMON.IOUNITS'
8705 #ifdef MPI
8706       include "mpif.h"
8707       parameter (max_cont=maxconts)
8708       parameter (max_dim=70)
8709       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8710       double precision zapas(max_dim,maxconts,max_fg_procs),
8711      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8712       common /przechowalnia/ zapas
8713       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8714      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8715 #endif
8716       include 'COMMON.SETUP'
8717       include 'COMMON.FFIELD'
8718       include 'COMMON.DERIV'
8719       include 'COMMON.LOCAL'
8720       include 'COMMON.INTERACT'
8721       include 'COMMON.CONTACTS'
8722       include 'COMMON.CHAIN'
8723       include 'COMMON.CONTROL'
8724       include 'COMMON.SHIELD'
8725       double precision gx(3),gx1(3)
8726       integer num_cont_hb_old(maxres)
8727       logical lprn,ldone
8728       double precision eello4,eello5,eelo6,eello_turn6
8729       external eello4,eello5,eello6,eello_turn6
8730 C Set lprn=.true. for debugging
8731       lprn=.false.
8732       eturn6=0.0d0
8733 #ifdef MPI
8734       do i=1,nres
8735         num_cont_hb_old(i)=num_cont_hb(i)
8736       enddo
8737       n_corr=0
8738       n_corr1=0
8739       if (nfgtasks.le.1) goto 30
8740       if (lprn) then
8741         write (iout,'(a)') 'Contact function values before RECEIVE:'
8742         do i=nnt,nct-2
8743           write (iout,'(2i3,50(1x,i2,f5.2))')
8744      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8745      &    j=1,num_cont_hb(i))
8746         enddo
8747       endif
8748       call flush(iout)
8749       do i=1,ntask_cont_from
8750         ncont_recv(i)=0
8751       enddo
8752       do i=1,ntask_cont_to
8753         ncont_sent(i)=0
8754       enddo
8755 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8756 c     & ntask_cont_to
8757 C Make the list of contacts to send to send to other procesors
8758       do i=iturn3_start,iturn3_end
8759 c        write (iout,*) "make contact list turn3",i," num_cont",
8760 c     &    num_cont_hb(i)
8761         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8762       enddo
8763       do i=iturn4_start,iturn4_end
8764 c        write (iout,*) "make contact list turn4",i," num_cont",
8765 c     &   num_cont_hb(i)
8766         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8767       enddo
8768       do ii=1,nat_sent
8769         i=iat_sent(ii)
8770 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8771 c     &    num_cont_hb(i)
8772         do j=1,num_cont_hb(i)
8773         do k=1,4
8774           jjc=jcont_hb(j,i)
8775           iproc=iint_sent_local(k,jjc,ii)
8776 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8777           if (iproc.ne.0) then
8778             ncont_sent(iproc)=ncont_sent(iproc)+1
8779             nn=ncont_sent(iproc)
8780             zapas(1,nn,iproc)=i
8781             zapas(2,nn,iproc)=jjc
8782             zapas(3,nn,iproc)=d_cont(j,i)
8783             ind=3
8784             do kk=1,3
8785               ind=ind+1
8786               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8787             enddo
8788             do kk=1,2
8789               do ll=1,2
8790                 ind=ind+1
8791                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8792               enddo
8793             enddo
8794             do jj=1,5
8795               do kk=1,3
8796                 do ll=1,2
8797                   do mm=1,2
8798                     ind=ind+1
8799                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8800                   enddo
8801                 enddo
8802               enddo
8803             enddo
8804           endif
8805         enddo
8806         enddo
8807       enddo
8808       if (lprn) then
8809       write (iout,*)
8810      &  "Numbers of contacts to be sent to other processors",
8811      &  (ncont_sent(i),i=1,ntask_cont_to)
8812       write (iout,*) "Contacts sent"
8813       do ii=1,ntask_cont_to
8814         nn=ncont_sent(ii)
8815         iproc=itask_cont_to(ii)
8816         write (iout,*) nn," contacts to processor",iproc,
8817      &   " of CONT_TO_COMM group"
8818         do i=1,nn
8819           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8820         enddo
8821       enddo
8822       call flush(iout)
8823       endif
8824       CorrelType=477
8825       CorrelID=fg_rank+1
8826       CorrelType1=478
8827       CorrelID1=nfgtasks+fg_rank+1
8828       ireq=0
8829 C Receive the numbers of needed contacts from other processors
8830       do ii=1,ntask_cont_from
8831         iproc=itask_cont_from(ii)
8832         ireq=ireq+1
8833         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8834      &    FG_COMM,req(ireq),IERR)
8835       enddo
8836 c      write (iout,*) "IRECV ended"
8837 c      call flush(iout)
8838 C Send the number of contacts needed by other processors
8839       do ii=1,ntask_cont_to
8840         iproc=itask_cont_to(ii)
8841         ireq=ireq+1
8842         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8843      &    FG_COMM,req(ireq),IERR)
8844       enddo
8845 c      write (iout,*) "ISEND ended"
8846 c      write (iout,*) "number of requests (nn)",ireq
8847       call flush(iout)
8848       if (ireq.gt.0)
8849      &  call MPI_Waitall(ireq,req,status_array,ierr)
8850 c      write (iout,*)
8851 c     &  "Numbers of contacts to be received from other processors",
8852 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8853 c      call flush(iout)
8854 C Receive contacts
8855       ireq=0
8856       do ii=1,ntask_cont_from
8857         iproc=itask_cont_from(ii)
8858         nn=ncont_recv(ii)
8859 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8860 c     &   " of CONT_TO_COMM group"
8861         call flush(iout)
8862         if (nn.gt.0) then
8863           ireq=ireq+1
8864           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8865      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8866 c          write (iout,*) "ireq,req",ireq,req(ireq)
8867         endif
8868       enddo
8869 C Send the contacts to processors that need them
8870       do ii=1,ntask_cont_to
8871         iproc=itask_cont_to(ii)
8872         nn=ncont_sent(ii)
8873 c        write (iout,*) nn," contacts to processor",iproc,
8874 c     &   " of CONT_TO_COMM group"
8875         if (nn.gt.0) then
8876           ireq=ireq+1
8877           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8878      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8879 c          write (iout,*) "ireq,req",ireq,req(ireq)
8880 c          do i=1,nn
8881 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8882 c          enddo
8883         endif
8884       enddo
8885 c      write (iout,*) "number of requests (contacts)",ireq
8886 c      write (iout,*) "req",(req(i),i=1,4)
8887 c      call flush(iout)
8888       if (ireq.gt.0)
8889      & call MPI_Waitall(ireq,req,status_array,ierr)
8890       do iii=1,ntask_cont_from
8891         iproc=itask_cont_from(iii)
8892         nn=ncont_recv(iii)
8893         if (lprn) then
8894         write (iout,*) "Received",nn," contacts from processor",iproc,
8895      &   " of CONT_FROM_COMM group"
8896         call flush(iout)
8897         do i=1,nn
8898           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8899         enddo
8900         call flush(iout)
8901         endif
8902         do i=1,nn
8903           ii=zapas_recv(1,i,iii)
8904 c Flag the received contacts to prevent double-counting
8905           jj=-zapas_recv(2,i,iii)
8906 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8907 c          call flush(iout)
8908           nnn=num_cont_hb(ii)+1
8909           num_cont_hb(ii)=nnn
8910           jcont_hb(nnn,ii)=jj
8911           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8912           ind=3
8913           do kk=1,3
8914             ind=ind+1
8915             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8916           enddo
8917           do kk=1,2
8918             do ll=1,2
8919               ind=ind+1
8920               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8921             enddo
8922           enddo
8923           do jj=1,5
8924             do kk=1,3
8925               do ll=1,2
8926                 do mm=1,2
8927                   ind=ind+1
8928                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8929                 enddo
8930               enddo
8931             enddo
8932           enddo
8933         enddo
8934       enddo
8935       call flush(iout)
8936       if (lprn) then
8937         write (iout,'(a)') 'Contact function values after receive:'
8938         do i=nnt,nct-2
8939           write (iout,'(2i3,50(1x,i3,5f6.3))')
8940      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8941      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8942         enddo
8943         call flush(iout)
8944       endif
8945    30 continue
8946 #endif
8947       if (lprn) then
8948         write (iout,'(a)') 'Contact function values:'
8949         do i=nnt,nct-2
8950           write (iout,'(2i3,50(1x,i2,5f6.3))')
8951      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8952      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8953         enddo
8954       endif
8955       ecorr=0.0D0
8956       ecorr5=0.0d0
8957       ecorr6=0.0d0
8958 C Remove the loop below after debugging !!!
8959       do i=nnt,nct
8960         do j=1,3
8961           gradcorr(j,i)=0.0D0
8962           gradxorr(j,i)=0.0D0
8963         enddo
8964       enddo
8965 C Calculate the dipole-dipole interaction energies
8966       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8967       do i=iatel_s,iatel_e+1
8968         num_conti=num_cont_hb(i)
8969         do jj=1,num_conti
8970           j=jcont_hb(jj,i)
8971 #ifdef MOMENT
8972           call dipole(i,j,jj)
8973 #endif
8974         enddo
8975       enddo
8976       endif
8977 C Calculate the local-electrostatic correlation terms
8978 c                write (iout,*) "gradcorr5 in eello5 before loop"
8979 c                do iii=1,nres
8980 c                  write (iout,'(i5,3f10.5)')
8981 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8982 c                enddo
8983       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8984 c        write (iout,*) "corr loop i",i
8985         i1=i+1
8986         num_conti=num_cont_hb(i)
8987         num_conti1=num_cont_hb(i+1)
8988         do jj=1,num_conti
8989           j=jcont_hb(jj,i)
8990           jp=iabs(j)
8991           do kk=1,num_conti1
8992             j1=jcont_hb(kk,i1)
8993             jp1=iabs(j1)
8994 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8995 c     &         ' jj=',jj,' kk=',kk
8996 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8997             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8998      &          .or. j.lt.0 .and. j1.gt.0) .and.
8999      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9000 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9001 C The system gains extra energy.
9002               n_corr=n_corr+1
9003               sqd1=dsqrt(d_cont(jj,i))
9004               sqd2=dsqrt(d_cont(kk,i1))
9005               sred_geom = sqd1*sqd2
9006               IF (sred_geom.lt.cutoff_corr) THEN
9007                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9008      &            ekont,fprimcont)
9009 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9010 cd     &         ' jj=',jj,' kk=',kk
9011                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9012                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9013                 do l=1,3
9014                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9015                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9016                 enddo
9017                 n_corr1=n_corr1+1
9018 cd               write (iout,*) 'sred_geom=',sred_geom,
9019 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9020 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9021 cd               write (iout,*) "g_contij",g_contij
9022 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9023 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9024                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9025                 if (wcorr4.gt.0.0d0)
9026      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9027 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9028                   if (energy_dec.and.wcorr4.gt.0.0d0)
9029      1                 write (iout,'(a6,4i5,0pf7.3)')
9030      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9031 c                write (iout,*) "gradcorr5 before eello5"
9032 c                do iii=1,nres
9033 c                  write (iout,'(i5,3f10.5)')
9034 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9035 c                enddo
9036                 if (wcorr5.gt.0.0d0)
9037      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9038 c                write (iout,*) "gradcorr5 after eello5"
9039 c                do iii=1,nres
9040 c                  write (iout,'(i5,3f10.5)')
9041 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9042 c                enddo
9043                   if (energy_dec.and.wcorr5.gt.0.0d0)
9044      1                 write (iout,'(a6,4i5,0pf7.3)')
9045      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9046 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9047 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9048                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9049      &               .or. wturn6.eq.0.0d0))then
9050 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9051                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9052                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9053      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9054 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9055 cd     &            'ecorr6=',ecorr6
9056 cd                write (iout,'(4e15.5)') sred_geom,
9057 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9058 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9059 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9060                 else if (wturn6.gt.0.0d0
9061      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9062 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9063                   eturn6=eturn6+eello_turn6(i,jj,kk)
9064                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9065      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9066 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9067                 endif
9068               ENDIF
9069 1111          continue
9070             endif
9071           enddo ! kk
9072         enddo ! jj
9073       enddo ! i
9074       do i=1,nres
9075         num_cont_hb(i)=num_cont_hb_old(i)
9076       enddo
9077 c                write (iout,*) "gradcorr5 in eello5"
9078 c                do iii=1,nres
9079 c                  write (iout,'(i5,3f10.5)')
9080 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9081 c                enddo
9082       return
9083       end
9084 c------------------------------------------------------------------------------
9085       subroutine add_hb_contact_eello(ii,jj,itask)
9086       implicit real*8 (a-h,o-z)
9087       include "DIMENSIONS"
9088       include "COMMON.IOUNITS"
9089       integer max_cont
9090       integer max_dim
9091       parameter (max_cont=maxconts)
9092       parameter (max_dim=70)
9093       include "COMMON.CONTACTS"
9094       double precision zapas(max_dim,maxconts,max_fg_procs),
9095      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9096       common /przechowalnia/ zapas
9097       integer i,j,ii,jj,iproc,itask(4),nn
9098 c      write (iout,*) "itask",itask
9099       do i=1,2
9100         iproc=itask(i)
9101         if (iproc.gt.0) then
9102           do j=1,num_cont_hb(ii)
9103             jjc=jcont_hb(j,ii)
9104 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9105             if (jjc.eq.jj) then
9106               ncont_sent(iproc)=ncont_sent(iproc)+1
9107               nn=ncont_sent(iproc)
9108               zapas(1,nn,iproc)=ii
9109               zapas(2,nn,iproc)=jjc
9110               zapas(3,nn,iproc)=d_cont(j,ii)
9111               ind=3
9112               do kk=1,3
9113                 ind=ind+1
9114                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9115               enddo
9116               do kk=1,2
9117                 do ll=1,2
9118                   ind=ind+1
9119                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9120                 enddo
9121               enddo
9122               do jj=1,5
9123                 do kk=1,3
9124                   do ll=1,2
9125                     do mm=1,2
9126                       ind=ind+1
9127                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9128                     enddo
9129                   enddo
9130                 enddo
9131               enddo
9132               exit
9133             endif
9134           enddo
9135         endif
9136       enddo
9137       return
9138       end
9139 c------------------------------------------------------------------------------
9140       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9141       implicit real*8 (a-h,o-z)
9142       include 'DIMENSIONS'
9143       include 'COMMON.IOUNITS'
9144       include 'COMMON.DERIV'
9145       include 'COMMON.INTERACT'
9146       include 'COMMON.CONTACTS'
9147       include 'COMMON.SHIELD'
9148       include 'COMMON.CONTROL'
9149       double precision gx(3),gx1(3)
9150       logical lprn
9151       lprn=.false.
9152 C      print *,"wchodze",fac_shield(i),shield_mode
9153       eij=facont_hb(jj,i)
9154       ekl=facont_hb(kk,k)
9155       ees0pij=ees0p(jj,i)
9156       ees0pkl=ees0p(kk,k)
9157       ees0mij=ees0m(jj,i)
9158       ees0mkl=ees0m(kk,k)
9159       ekont=eij*ekl
9160       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9161 C*
9162 C     & fac_shield(i)**2*fac_shield(j)**2
9163 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9164 C Following 4 lines for diagnostics.
9165 cd    ees0pkl=0.0D0
9166 cd    ees0pij=1.0D0
9167 cd    ees0mkl=0.0D0
9168 cd    ees0mij=1.0D0
9169 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9170 c     & 'Contacts ',i,j,
9171 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9172 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9173 c     & 'gradcorr_long'
9174 C Calculate the multi-body contribution to energy.
9175 C      ecorr=ecorr+ekont*ees
9176 C Calculate multi-body contributions to the gradient.
9177       coeffpees0pij=coeffp*ees0pij
9178       coeffmees0mij=coeffm*ees0mij
9179       coeffpees0pkl=coeffp*ees0pkl
9180       coeffmees0mkl=coeffm*ees0mkl
9181       do ll=1,3
9182 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9183         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9184      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9185      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9186         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9187      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9188      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9189 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9190         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9191      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9192      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9193         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9194      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9195      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9196         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9197      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9198      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9199         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9200         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9201         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9202      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9203      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9204         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9205         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9206 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9207       enddo
9208 c      write (iout,*)
9209 cgrad      do m=i+1,j-1
9210 cgrad        do ll=1,3
9211 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9212 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9213 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9214 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9215 cgrad        enddo
9216 cgrad      enddo
9217 cgrad      do m=k+1,l-1
9218 cgrad        do ll=1,3
9219 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9220 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9221 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9222 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9223 cgrad        enddo
9224 cgrad      enddo
9225 c      write (iout,*) "ehbcorr",ekont*ees
9226 C      print *,ekont,ees,i,k
9227       ehbcorr=ekont*ees
9228 C now gradient over shielding
9229 C      return
9230       if (shield_mode.gt.0) then
9231        j=ees0plist(jj,i)
9232        l=ees0plist(kk,k)
9233 C        print *,i,j,fac_shield(i),fac_shield(j),
9234 C     &fac_shield(k),fac_shield(l)
9235         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9236      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9237           do ilist=1,ishield_list(i)
9238            iresshield=shield_list(ilist,i)
9239            do m=1,3
9240            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9241 C     &      *2.0
9242            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9243      &              rlocshield
9244      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9245             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9246      &+rlocshield
9247            enddo
9248           enddo
9249           do ilist=1,ishield_list(j)
9250            iresshield=shield_list(ilist,j)
9251            do m=1,3
9252            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9253 C     &     *2.0
9254            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9255      &              rlocshield
9256      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9257            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9258      &     +rlocshield
9259            enddo
9260           enddo
9261
9262           do ilist=1,ishield_list(k)
9263            iresshield=shield_list(ilist,k)
9264            do m=1,3
9265            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9266 C     &     *2.0
9267            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9268      &              rlocshield
9269      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9270            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9271      &     +rlocshield
9272            enddo
9273           enddo
9274           do ilist=1,ishield_list(l)
9275            iresshield=shield_list(ilist,l)
9276            do m=1,3
9277            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9278 C     &     *2.0
9279            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9280      &              rlocshield
9281      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9282            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9283      &     +rlocshield
9284            enddo
9285           enddo
9286 C          print *,gshieldx(m,iresshield)
9287           do m=1,3
9288             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9289      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9290             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9291      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9292             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9293      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9294             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9295      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9296
9297             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9298      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9299             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9300      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9301             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9302      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9303             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9304      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9305
9306            enddo
9307       endif
9308       endif
9309       return
9310       end
9311 #ifdef MOMENT
9312 C---------------------------------------------------------------------------
9313       subroutine dipole(i,j,jj)
9314       implicit real*8 (a-h,o-z)
9315       include 'DIMENSIONS'
9316       include 'COMMON.IOUNITS'
9317       include 'COMMON.CHAIN'
9318       include 'COMMON.FFIELD'
9319       include 'COMMON.DERIV'
9320       include 'COMMON.INTERACT'
9321       include 'COMMON.CONTACTS'
9322       include 'COMMON.TORSION'
9323       include 'COMMON.VAR'
9324       include 'COMMON.GEO'
9325       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9326      &  auxmat(2,2)
9327       iti1 = itortyp(itype(i+1))
9328       if (j.lt.nres-1) then
9329         itj1 = itype2loc(itype(j+1))
9330       else
9331         itj1=nloctyp
9332       endif
9333       do iii=1,2
9334         dipi(iii,1)=Ub2(iii,i)
9335         dipderi(iii)=Ub2der(iii,i)
9336         dipi(iii,2)=b1(iii,i+1)
9337         dipj(iii,1)=Ub2(iii,j)
9338         dipderj(iii)=Ub2der(iii,j)
9339         dipj(iii,2)=b1(iii,j+1)
9340       enddo
9341       kkk=0
9342       do iii=1,2
9343         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9344         do jjj=1,2
9345           kkk=kkk+1
9346           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9347         enddo
9348       enddo
9349       do kkk=1,5
9350         do lll=1,3
9351           mmm=0
9352           do iii=1,2
9353             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9354      &        auxvec(1))
9355             do jjj=1,2
9356               mmm=mmm+1
9357               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9358             enddo
9359           enddo
9360         enddo
9361       enddo
9362       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9363       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9364       do iii=1,2
9365         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9366       enddo
9367       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9368       do iii=1,2
9369         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9370       enddo
9371       return
9372       end
9373 #endif
9374 C---------------------------------------------------------------------------
9375       subroutine calc_eello(i,j,k,l,jj,kk)
9376 C
9377 C This subroutine computes matrices and vectors needed to calculate
9378 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9379 C
9380       implicit real*8 (a-h,o-z)
9381       include 'DIMENSIONS'
9382       include 'COMMON.IOUNITS'
9383       include 'COMMON.CHAIN'
9384       include 'COMMON.DERIV'
9385       include 'COMMON.INTERACT'
9386       include 'COMMON.CONTACTS'
9387       include 'COMMON.TORSION'
9388       include 'COMMON.VAR'
9389       include 'COMMON.GEO'
9390       include 'COMMON.FFIELD'
9391       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9392      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9393       logical lprn
9394       common /kutas/ lprn
9395 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9396 cd     & ' jj=',jj,' kk=',kk
9397 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9398 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9399 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9400       do iii=1,2
9401         do jjj=1,2
9402           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9403           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9404         enddo
9405       enddo
9406       call transpose2(aa1(1,1),aa1t(1,1))
9407       call transpose2(aa2(1,1),aa2t(1,1))
9408       do kkk=1,5
9409         do lll=1,3
9410           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9411      &      aa1tder(1,1,lll,kkk))
9412           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9413      &      aa2tder(1,1,lll,kkk))
9414         enddo
9415       enddo
9416       if (l.eq.j+1) then
9417 C parallel orientation of the two CA-CA-CA frames.
9418         if (i.gt.1) then
9419           iti=itype2loc(itype(i))
9420         else
9421           iti=nloctyp
9422         endif
9423         itk1=itype2loc(itype(k+1))
9424         itj=itype2loc(itype(j))
9425         if (l.lt.nres-1) then
9426           itl1=itype2loc(itype(l+1))
9427         else
9428           itl1=nloctyp
9429         endif
9430 C A1 kernel(j+1) A2T
9431 cd        do iii=1,2
9432 cd          write (iout,'(3f10.5,5x,3f10.5)')
9433 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9434 cd        enddo
9435         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9436      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9437      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9438 C Following matrices are needed only for 6-th order cumulants
9439         IF (wcorr6.gt.0.0d0) THEN
9440         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9441      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9442      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9443         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9444      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9445      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9446      &   ADtEAderx(1,1,1,1,1,1))
9447         lprn=.false.
9448         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9449      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9450      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9451      &   ADtEA1derx(1,1,1,1,1,1))
9452         ENDIF
9453 C End 6-th order cumulants
9454 cd        lprn=.false.
9455 cd        if (lprn) then
9456 cd        write (2,*) 'In calc_eello6'
9457 cd        do iii=1,2
9458 cd          write (2,*) 'iii=',iii
9459 cd          do kkk=1,5
9460 cd            write (2,*) 'kkk=',kkk
9461 cd            do jjj=1,2
9462 cd              write (2,'(3(2f10.5),5x)')
9463 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9464 cd            enddo
9465 cd          enddo
9466 cd        enddo
9467 cd        endif
9468         call transpose2(EUgder(1,1,k),auxmat(1,1))
9469         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9470         call transpose2(EUg(1,1,k),auxmat(1,1))
9471         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9472         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9473         do iii=1,2
9474           do kkk=1,5
9475             do lll=1,3
9476               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9477      &          EAEAderx(1,1,lll,kkk,iii,1))
9478             enddo
9479           enddo
9480         enddo
9481 C A1T kernel(i+1) A2
9482         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9483      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9484      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9485 C Following matrices are needed only for 6-th order cumulants
9486         IF (wcorr6.gt.0.0d0) THEN
9487         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9488      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9489      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
9492      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9493      &   ADtEAderx(1,1,1,1,1,2))
9494         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9495      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9496      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9497      &   ADtEA1derx(1,1,1,1,1,2))
9498         ENDIF
9499 C End 6-th order cumulants
9500         call transpose2(EUgder(1,1,l),auxmat(1,1))
9501         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9502         call transpose2(EUg(1,1,l),auxmat(1,1))
9503         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9504         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9505         do iii=1,2
9506           do kkk=1,5
9507             do lll=1,3
9508               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9509      &          EAEAderx(1,1,lll,kkk,iii,2))
9510             enddo
9511           enddo
9512         enddo
9513 C AEAb1 and AEAb2
9514 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9515 C They are needed only when the fifth- or the sixth-order cumulants are
9516 C indluded.
9517         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9518         call transpose2(AEA(1,1,1),auxmat(1,1))
9519         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9520         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9521         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9522         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9523         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9524         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9525         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9526         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9527         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9528         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9529         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9530         call transpose2(AEA(1,1,2),auxmat(1,1))
9531         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9532         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9533         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9534         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9535         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9536         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9537         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9538         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9539         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9540         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9541         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9542 C Calculate the Cartesian derivatives of the vectors.
9543         do iii=1,2
9544           do kkk=1,5
9545             do lll=1,3
9546               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9547               call matvec2(auxmat(1,1),b1(1,i),
9548      &          AEAb1derx(1,lll,kkk,iii,1,1))
9549               call matvec2(auxmat(1,1),Ub2(1,i),
9550      &          AEAb2derx(1,lll,kkk,iii,1,1))
9551               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9552      &          AEAb1derx(1,lll,kkk,iii,2,1))
9553               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9554      &          AEAb2derx(1,lll,kkk,iii,2,1))
9555               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9556               call matvec2(auxmat(1,1),b1(1,j),
9557      &          AEAb1derx(1,lll,kkk,iii,1,2))
9558               call matvec2(auxmat(1,1),Ub2(1,j),
9559      &          AEAb2derx(1,lll,kkk,iii,1,2))
9560               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9561      &          AEAb1derx(1,lll,kkk,iii,2,2))
9562               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9563      &          AEAb2derx(1,lll,kkk,iii,2,2))
9564             enddo
9565           enddo
9566         enddo
9567         ENDIF
9568 C End vectors
9569       else
9570 C Antiparallel orientation of the two CA-CA-CA frames.
9571         if (i.gt.1) then
9572           iti=itype2loc(itype(i))
9573         else
9574           iti=nloctyp
9575         endif
9576         itk1=itype2loc(itype(k+1))
9577         itl=itype2loc(itype(l))
9578         itj=itype2loc(itype(j))
9579         if (j.lt.nres-1) then
9580           itj1=itype2loc(itype(j+1))
9581         else
9582           itj1=nloctyp
9583         endif
9584 C A2 kernel(j-1)T A1T
9585         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9586      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9587      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9588 C Following matrices are needed only for 6-th order cumulants
9589         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9590      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9591         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9592      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9593      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9594         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9595      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9596      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9597      &   ADtEAderx(1,1,1,1,1,1))
9598         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9599      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9600      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9601      &   ADtEA1derx(1,1,1,1,1,1))
9602         ENDIF
9603 C End 6-th order cumulants
9604         call transpose2(EUgder(1,1,k),auxmat(1,1))
9605         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9606         call transpose2(EUg(1,1,k),auxmat(1,1))
9607         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9608         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9609         do iii=1,2
9610           do kkk=1,5
9611             do lll=1,3
9612               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9613      &          EAEAderx(1,1,lll,kkk,iii,1))
9614             enddo
9615           enddo
9616         enddo
9617 C A2T kernel(i+1)T A1
9618         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9619      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9620      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9621 C Following matrices are needed only for 6-th order cumulants
9622         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9623      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9624         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9625      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9626      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
9629      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9630      &   ADtEAderx(1,1,1,1,1,2))
9631         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9632      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9633      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9634      &   ADtEA1derx(1,1,1,1,1,2))
9635         ENDIF
9636 C End 6-th order cumulants
9637         call transpose2(EUgder(1,1,j),auxmat(1,1))
9638         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9639         call transpose2(EUg(1,1,j),auxmat(1,1))
9640         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9641         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9642         do iii=1,2
9643           do kkk=1,5
9644             do lll=1,3
9645               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9646      &          EAEAderx(1,1,lll,kkk,iii,2))
9647             enddo
9648           enddo
9649         enddo
9650 C AEAb1 and AEAb2
9651 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9652 C They are needed only when the fifth- or the sixth-order cumulants are
9653 C indluded.
9654         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9655      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9656         call transpose2(AEA(1,1,1),auxmat(1,1))
9657         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9658         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9659         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9660         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9661         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9662         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9663         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9664         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9665         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9666         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9667         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9668         call transpose2(AEA(1,1,2),auxmat(1,1))
9669         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9670         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9671         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9672         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9673         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9674         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9675         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9676         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9677         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9678         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9679         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9680 C Calculate the Cartesian derivatives of the vectors.
9681         do iii=1,2
9682           do kkk=1,5
9683             do lll=1,3
9684               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9685               call matvec2(auxmat(1,1),b1(1,i),
9686      &          AEAb1derx(1,lll,kkk,iii,1,1))
9687               call matvec2(auxmat(1,1),Ub2(1,i),
9688      &          AEAb2derx(1,lll,kkk,iii,1,1))
9689               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9690      &          AEAb1derx(1,lll,kkk,iii,2,1))
9691               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9692      &          AEAb2derx(1,lll,kkk,iii,2,1))
9693               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9694               call matvec2(auxmat(1,1),b1(1,l),
9695      &          AEAb1derx(1,lll,kkk,iii,1,2))
9696               call matvec2(auxmat(1,1),Ub2(1,l),
9697      &          AEAb2derx(1,lll,kkk,iii,1,2))
9698               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9699      &          AEAb1derx(1,lll,kkk,iii,2,2))
9700               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9701      &          AEAb2derx(1,lll,kkk,iii,2,2))
9702             enddo
9703           enddo
9704         enddo
9705         ENDIF
9706 C End vectors
9707       endif
9708       return
9709       end
9710 C---------------------------------------------------------------------------
9711       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9712      &  KK,KKderg,AKA,AKAderg,AKAderx)
9713       implicit none
9714       integer nderg
9715       logical transp
9716       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9717      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9718      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9719       integer iii,kkk,lll
9720       integer jjj,mmm
9721       logical lprn
9722       common /kutas/ lprn
9723       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9724       do iii=1,nderg
9725         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9726      &    AKAderg(1,1,iii))
9727       enddo
9728 cd      if (lprn) write (2,*) 'In kernel'
9729       do kkk=1,5
9730 cd        if (lprn) write (2,*) 'kkk=',kkk
9731         do lll=1,3
9732           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9733      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9734 cd          if (lprn) then
9735 cd            write (2,*) 'lll=',lll
9736 cd            write (2,*) 'iii=1'
9737 cd            do jjj=1,2
9738 cd              write (2,'(3(2f10.5),5x)')
9739 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9740 cd            enddo
9741 cd          endif
9742           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9743      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9744 cd          if (lprn) then
9745 cd            write (2,*) 'lll=',lll
9746 cd            write (2,*) 'iii=2'
9747 cd            do jjj=1,2
9748 cd              write (2,'(3(2f10.5),5x)')
9749 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9750 cd            enddo
9751 cd          endif
9752         enddo
9753       enddo
9754       return
9755       end
9756 C---------------------------------------------------------------------------
9757       double precision function eello4(i,j,k,l,jj,kk)
9758       implicit real*8 (a-h,o-z)
9759       include 'DIMENSIONS'
9760       include 'COMMON.IOUNITS'
9761       include 'COMMON.CHAIN'
9762       include 'COMMON.DERIV'
9763       include 'COMMON.INTERACT'
9764       include 'COMMON.CONTACTS'
9765       include 'COMMON.TORSION'
9766       include 'COMMON.VAR'
9767       include 'COMMON.GEO'
9768       double precision pizda(2,2),ggg1(3),ggg2(3)
9769 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9770 cd        eello4=0.0d0
9771 cd        return
9772 cd      endif
9773 cd      print *,'eello4:',i,j,k,l,jj,kk
9774 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9775 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9776 cold      eij=facont_hb(jj,i)
9777 cold      ekl=facont_hb(kk,k)
9778 cold      ekont=eij*ekl
9779       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9780 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9781       gcorr_loc(k-1)=gcorr_loc(k-1)
9782      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9783       if (l.eq.j+1) then
9784         gcorr_loc(l-1)=gcorr_loc(l-1)
9785      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9786       else
9787         gcorr_loc(j-1)=gcorr_loc(j-1)
9788      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9789       endif
9790       do iii=1,2
9791         do kkk=1,5
9792           do lll=1,3
9793             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9794      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9795 cd            derx(lll,kkk,iii)=0.0d0
9796           enddo
9797         enddo
9798       enddo
9799 cd      gcorr_loc(l-1)=0.0d0
9800 cd      gcorr_loc(j-1)=0.0d0
9801 cd      gcorr_loc(k-1)=0.0d0
9802 cd      eel4=1.0d0
9803 cd      write (iout,*)'Contacts have occurred for peptide groups',
9804 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9805 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9806       if (j.lt.nres-1) then
9807         j1=j+1
9808         j2=j-1
9809       else
9810         j1=j-1
9811         j2=j-2
9812       endif
9813       if (l.lt.nres-1) then
9814         l1=l+1
9815         l2=l-1
9816       else
9817         l1=l-1
9818         l2=l-2
9819       endif
9820       do ll=1,3
9821 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9822 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9823         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9824         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9825 cgrad        ghalf=0.5d0*ggg1(ll)
9826         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9827         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9828         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9829         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9830         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9831         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9832 cgrad        ghalf=0.5d0*ggg2(ll)
9833         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9834         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9835         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9836         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9837         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9838         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9839       enddo
9840 cgrad      do m=i+1,j-1
9841 cgrad        do ll=1,3
9842 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9843 cgrad        enddo
9844 cgrad      enddo
9845 cgrad      do m=k+1,l-1
9846 cgrad        do ll=1,3
9847 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9848 cgrad        enddo
9849 cgrad      enddo
9850 cgrad      do m=i+2,j2
9851 cgrad        do ll=1,3
9852 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9853 cgrad        enddo
9854 cgrad      enddo
9855 cgrad      do m=k+2,l2
9856 cgrad        do ll=1,3
9857 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9858 cgrad        enddo
9859 cgrad      enddo
9860 cd      do iii=1,nres-3
9861 cd        write (2,*) iii,gcorr_loc(iii)
9862 cd      enddo
9863       eello4=ekont*eel4
9864 cd      write (2,*) 'ekont',ekont
9865 cd      write (iout,*) 'eello4',ekont*eel4
9866       return
9867       end
9868 C---------------------------------------------------------------------------
9869       double precision function eello5(i,j,k,l,jj,kk)
9870       implicit real*8 (a-h,o-z)
9871       include 'DIMENSIONS'
9872       include 'COMMON.IOUNITS'
9873       include 'COMMON.CHAIN'
9874       include 'COMMON.DERIV'
9875       include 'COMMON.INTERACT'
9876       include 'COMMON.CONTACTS'
9877       include 'COMMON.TORSION'
9878       include 'COMMON.VAR'
9879       include 'COMMON.GEO'
9880       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9881       double precision ggg1(3),ggg2(3)
9882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9883 C                                                                              C
9884 C                            Parallel chains                                   C
9885 C                                                                              C
9886 C          o             o                   o             o                   C
9887 C         /l\           / \             \   / \           / \   /              C
9888 C        /   \         /   \             \ /   \         /   \ /               C
9889 C       j| o |l1       | o |              o| o |         | o |o                C
9890 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9891 C      \i/   \         /   \ /             /   \         /   \                 C
9892 C       o    k1             o                                                  C
9893 C         (I)          (II)                (III)          (IV)                 C
9894 C                                                                              C
9895 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9896 C                                                                              C
9897 C                            Antiparallel chains                               C
9898 C                                                                              C
9899 C          o             o                   o             o                   C
9900 C         /j\           / \             \   / \           / \   /              C
9901 C        /   \         /   \             \ /   \         /   \ /               C
9902 C      j1| o |l        | o |              o| o |         | o |o                C
9903 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9904 C      \i/   \         /   \ /             /   \         /   \                 C
9905 C       o     k1            o                                                  C
9906 C         (I)          (II)                (III)          (IV)                 C
9907 C                                                                              C
9908 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9909 C                                                                              C
9910 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9911 C                                                                              C
9912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9913 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9914 cd        eello5=0.0d0
9915 cd        return
9916 cd      endif
9917 cd      write (iout,*)
9918 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9919 cd     &   ' and',k,l
9920       itk=itype2loc(itype(k))
9921       itl=itype2loc(itype(l))
9922       itj=itype2loc(itype(j))
9923       eello5_1=0.0d0
9924       eello5_2=0.0d0
9925       eello5_3=0.0d0
9926       eello5_4=0.0d0
9927 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9928 cd     &   eel5_3_num,eel5_4_num)
9929       do iii=1,2
9930         do kkk=1,5
9931           do lll=1,3
9932             derx(lll,kkk,iii)=0.0d0
9933           enddo
9934         enddo
9935       enddo
9936 cd      eij=facont_hb(jj,i)
9937 cd      ekl=facont_hb(kk,k)
9938 cd      ekont=eij*ekl
9939 cd      write (iout,*)'Contacts have occurred for peptide groups',
9940 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9941 cd      goto 1111
9942 C Contribution from the graph I.
9943 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9944 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9945       call transpose2(EUg(1,1,k),auxmat(1,1))
9946       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9947       vv(1)=pizda(1,1)-pizda(2,2)
9948       vv(2)=pizda(1,2)+pizda(2,1)
9949       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9950      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9951 C Explicit gradient in virtual-dihedral angles.
9952       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9953      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9954      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9955       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9956       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9957       vv(1)=pizda(1,1)-pizda(2,2)
9958       vv(2)=pizda(1,2)+pizda(2,1)
9959       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9960      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9961      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9962       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9963       vv(1)=pizda(1,1)-pizda(2,2)
9964       vv(2)=pizda(1,2)+pizda(2,1)
9965       if (l.eq.j+1) then
9966         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9967      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9968      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9969       else
9970         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9971      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9972      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9973       endif
9974 C Cartesian gradient
9975       do iii=1,2
9976         do kkk=1,5
9977           do lll=1,3
9978             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9979      &        pizda(1,1))
9980             vv(1)=pizda(1,1)-pizda(2,2)
9981             vv(2)=pizda(1,2)+pizda(2,1)
9982             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9983      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9984      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9985           enddo
9986         enddo
9987       enddo
9988 c      goto 1112
9989 c1111  continue
9990 C Contribution from graph II
9991       call transpose2(EE(1,1,k),auxmat(1,1))
9992       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9993       vv(1)=pizda(1,1)+pizda(2,2)
9994       vv(2)=pizda(2,1)-pizda(1,2)
9995       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9996      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9997 C Explicit gradient in virtual-dihedral angles.
9998       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9999      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10000       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10001       vv(1)=pizda(1,1)+pizda(2,2)
10002       vv(2)=pizda(2,1)-pizda(1,2)
10003       if (l.eq.j+1) then
10004         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10005      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10006      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10007       else
10008         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10009      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10010      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10011       endif
10012 C Cartesian gradient
10013       do iii=1,2
10014         do kkk=1,5
10015           do lll=1,3
10016             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10017      &        pizda(1,1))
10018             vv(1)=pizda(1,1)+pizda(2,2)
10019             vv(2)=pizda(2,1)-pizda(1,2)
10020             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10021      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10022      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10023           enddo
10024         enddo
10025       enddo
10026 cd      goto 1112
10027 cd1111  continue
10028       if (l.eq.j+1) then
10029 cd        goto 1110
10030 C Parallel orientation
10031 C Contribution from graph III
10032         call transpose2(EUg(1,1,l),auxmat(1,1))
10033         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10034         vv(1)=pizda(1,1)-pizda(2,2)
10035         vv(2)=pizda(1,2)+pizda(2,1)
10036         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10037      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10038 C Explicit gradient in virtual-dihedral angles.
10039         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10040      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10041      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10042         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10043         vv(1)=pizda(1,1)-pizda(2,2)
10044         vv(2)=pizda(1,2)+pizda(2,1)
10045         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10046      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10047      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10048         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10049         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10050         vv(1)=pizda(1,1)-pizda(2,2)
10051         vv(2)=pizda(1,2)+pizda(2,1)
10052         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10053      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10054      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10055 C Cartesian gradient
10056         do iii=1,2
10057           do kkk=1,5
10058             do lll=1,3
10059               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10060      &          pizda(1,1))
10061               vv(1)=pizda(1,1)-pizda(2,2)
10062               vv(2)=pizda(1,2)+pizda(2,1)
10063               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10064      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10065      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10066             enddo
10067           enddo
10068         enddo
10069 cd        goto 1112
10070 C Contribution from graph IV
10071 cd1110    continue
10072         call transpose2(EE(1,1,l),auxmat(1,1))
10073         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10074         vv(1)=pizda(1,1)+pizda(2,2)
10075         vv(2)=pizda(2,1)-pizda(1,2)
10076         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10077      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10078 C Explicit gradient in virtual-dihedral angles.
10079         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10080      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10081         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10082         vv(1)=pizda(1,1)+pizda(2,2)
10083         vv(2)=pizda(2,1)-pizda(1,2)
10084         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10085      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10086      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10087 C Cartesian gradient
10088         do iii=1,2
10089           do kkk=1,5
10090             do lll=1,3
10091               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10092      &          pizda(1,1))
10093               vv(1)=pizda(1,1)+pizda(2,2)
10094               vv(2)=pizda(2,1)-pizda(1,2)
10095               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10096      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10097      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10098             enddo
10099           enddo
10100         enddo
10101       else
10102 C Antiparallel orientation
10103 C Contribution from graph III
10104 c        goto 1110
10105         call transpose2(EUg(1,1,j),auxmat(1,1))
10106         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10107         vv(1)=pizda(1,1)-pizda(2,2)
10108         vv(2)=pizda(1,2)+pizda(2,1)
10109         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10110      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10111 C Explicit gradient in virtual-dihedral angles.
10112         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10113      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10114      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10115         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10116         vv(1)=pizda(1,1)-pizda(2,2)
10117         vv(2)=pizda(1,2)+pizda(2,1)
10118         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10119      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10120      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10121         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10122         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10123         vv(1)=pizda(1,1)-pizda(2,2)
10124         vv(2)=pizda(1,2)+pizda(2,1)
10125         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10126      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10127      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10128 C Cartesian gradient
10129         do iii=1,2
10130           do kkk=1,5
10131             do lll=1,3
10132               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10133      &          pizda(1,1))
10134               vv(1)=pizda(1,1)-pizda(2,2)
10135               vv(2)=pizda(1,2)+pizda(2,1)
10136               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10137      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10138      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10139             enddo
10140           enddo
10141         enddo
10142 cd        goto 1112
10143 C Contribution from graph IV
10144 1110    continue
10145         call transpose2(EE(1,1,j),auxmat(1,1))
10146         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10147         vv(1)=pizda(1,1)+pizda(2,2)
10148         vv(2)=pizda(2,1)-pizda(1,2)
10149         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10150      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10151 C Explicit gradient in virtual-dihedral angles.
10152         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10153      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10154         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10155         vv(1)=pizda(1,1)+pizda(2,2)
10156         vv(2)=pizda(2,1)-pizda(1,2)
10157         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10158      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10159      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10160 C Cartesian gradient
10161         do iii=1,2
10162           do kkk=1,5
10163             do lll=1,3
10164               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10165      &          pizda(1,1))
10166               vv(1)=pizda(1,1)+pizda(2,2)
10167               vv(2)=pizda(2,1)-pizda(1,2)
10168               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10169      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10170      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10171             enddo
10172           enddo
10173         enddo
10174       endif
10175 1112  continue
10176       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10177 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10178 cd        write (2,*) 'ijkl',i,j,k,l
10179 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10180 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10181 cd      endif
10182 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10183 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10184 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10185 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10186       if (j.lt.nres-1) then
10187         j1=j+1
10188         j2=j-1
10189       else
10190         j1=j-1
10191         j2=j-2
10192       endif
10193       if (l.lt.nres-1) then
10194         l1=l+1
10195         l2=l-1
10196       else
10197         l1=l-1
10198         l2=l-2
10199       endif
10200 cd      eij=1.0d0
10201 cd      ekl=1.0d0
10202 cd      ekont=1.0d0
10203 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10204 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10205 C        summed up outside the subrouine as for the other subroutines
10206 C        handling long-range interactions. The old code is commented out
10207 C        with "cgrad" to keep track of changes.
10208       do ll=1,3
10209 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10210 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10211         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10212         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10213 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10214 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10215 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10216 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10217 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10218 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10219 c     &   gradcorr5ij,
10220 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10221 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10222 cgrad        ghalf=0.5d0*ggg1(ll)
10223 cd        ghalf=0.0d0
10224         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10225         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10226         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10227         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10228         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10229         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10230 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10231 cgrad        ghalf=0.5d0*ggg2(ll)
10232 cd        ghalf=0.0d0
10233         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10234         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10235         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10236         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10237         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10238         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10239       enddo
10240 cd      goto 1112
10241 cgrad      do m=i+1,j-1
10242 cgrad        do ll=1,3
10243 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10244 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10245 cgrad        enddo
10246 cgrad      enddo
10247 cgrad      do m=k+1,l-1
10248 cgrad        do ll=1,3
10249 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10250 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10251 cgrad        enddo
10252 cgrad      enddo
10253 c1112  continue
10254 cgrad      do m=i+2,j2
10255 cgrad        do ll=1,3
10256 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10257 cgrad        enddo
10258 cgrad      enddo
10259 cgrad      do m=k+2,l2
10260 cgrad        do ll=1,3
10261 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10262 cgrad        enddo
10263 cgrad      enddo
10264 cd      do iii=1,nres-3
10265 cd        write (2,*) iii,g_corr5_loc(iii)
10266 cd      enddo
10267       eello5=ekont*eel5
10268 cd      write (2,*) 'ekont',ekont
10269 cd      write (iout,*) 'eello5',ekont*eel5
10270       return
10271       end
10272 c--------------------------------------------------------------------------
10273       double precision function eello6(i,j,k,l,jj,kk)
10274       implicit real*8 (a-h,o-z)
10275       include 'DIMENSIONS'
10276       include 'COMMON.IOUNITS'
10277       include 'COMMON.CHAIN'
10278       include 'COMMON.DERIV'
10279       include 'COMMON.INTERACT'
10280       include 'COMMON.CONTACTS'
10281       include 'COMMON.TORSION'
10282       include 'COMMON.VAR'
10283       include 'COMMON.GEO'
10284       include 'COMMON.FFIELD'
10285       double precision ggg1(3),ggg2(3)
10286 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10287 cd        eello6=0.0d0
10288 cd        return
10289 cd      endif
10290 cd      write (iout,*)
10291 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10292 cd     &   ' and',k,l
10293       eello6_1=0.0d0
10294       eello6_2=0.0d0
10295       eello6_3=0.0d0
10296       eello6_4=0.0d0
10297       eello6_5=0.0d0
10298       eello6_6=0.0d0
10299 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10300 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10301       do iii=1,2
10302         do kkk=1,5
10303           do lll=1,3
10304             derx(lll,kkk,iii)=0.0d0
10305           enddo
10306         enddo
10307       enddo
10308 cd      eij=facont_hb(jj,i)
10309 cd      ekl=facont_hb(kk,k)
10310 cd      ekont=eij*ekl
10311 cd      eij=1.0d0
10312 cd      ekl=1.0d0
10313 cd      ekont=1.0d0
10314       if (l.eq.j+1) then
10315         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10316         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10317         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10318         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10319         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10320         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10321       else
10322         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10323         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10324         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10325         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10326         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10327           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10328         else
10329           eello6_5=0.0d0
10330         endif
10331         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10332       endif
10333 C If turn contributions are considered, they will be handled separately.
10334       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10335 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10336 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10337 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10338 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10339 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10340 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10341 cd      goto 1112
10342       if (j.lt.nres-1) then
10343         j1=j+1
10344         j2=j-1
10345       else
10346         j1=j-1
10347         j2=j-2
10348       endif
10349       if (l.lt.nres-1) then
10350         l1=l+1
10351         l2=l-1
10352       else
10353         l1=l-1
10354         l2=l-2
10355       endif
10356       do ll=1,3
10357 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10358 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10359 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10360 cgrad        ghalf=0.5d0*ggg1(ll)
10361 cd        ghalf=0.0d0
10362         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10363         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10364         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10365         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10366         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10367         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10368         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10369         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10370 cgrad        ghalf=0.5d0*ggg2(ll)
10371 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10372 cd        ghalf=0.0d0
10373         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10374         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10375         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10376         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10377         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10378         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10379       enddo
10380 cd      goto 1112
10381 cgrad      do m=i+1,j-1
10382 cgrad        do ll=1,3
10383 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10384 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10385 cgrad        enddo
10386 cgrad      enddo
10387 cgrad      do m=k+1,l-1
10388 cgrad        do ll=1,3
10389 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10390 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10391 cgrad        enddo
10392 cgrad      enddo
10393 cgrad1112  continue
10394 cgrad      do m=i+2,j2
10395 cgrad        do ll=1,3
10396 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10397 cgrad        enddo
10398 cgrad      enddo
10399 cgrad      do m=k+2,l2
10400 cgrad        do ll=1,3
10401 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10402 cgrad        enddo
10403 cgrad      enddo
10404 cd      do iii=1,nres-3
10405 cd        write (2,*) iii,g_corr6_loc(iii)
10406 cd      enddo
10407       eello6=ekont*eel6
10408 cd      write (2,*) 'ekont',ekont
10409 cd      write (iout,*) 'eello6',ekont*eel6
10410       return
10411       end
10412 c--------------------------------------------------------------------------
10413       double precision function eello6_graph1(i,j,k,l,imat,swap)
10414       implicit real*8 (a-h,o-z)
10415       include 'DIMENSIONS'
10416       include 'COMMON.IOUNITS'
10417       include 'COMMON.CHAIN'
10418       include 'COMMON.DERIV'
10419       include 'COMMON.INTERACT'
10420       include 'COMMON.CONTACTS'
10421       include 'COMMON.TORSION'
10422       include 'COMMON.VAR'
10423       include 'COMMON.GEO'
10424       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10425       logical swap
10426       logical lprn
10427       common /kutas/ lprn
10428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10429 C                                                                              C
10430 C      Parallel       Antiparallel                                             C
10431 C                                                                              C
10432 C          o             o                                                     C
10433 C         /l\           /j\                                                    C
10434 C        /   \         /   \                                                   C
10435 C       /| o |         | o |\                                                  C
10436 C     \ j|/k\|  /   \  |/k\|l /                                                C
10437 C      \ /   \ /     \ /   \ /                                                 C
10438 C       o     o       o     o                                                  C
10439 C       i             i                                                        C
10440 C                                                                              C
10441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10442       itk=itype2loc(itype(k))
10443       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10444       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10445       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10446       call transpose2(EUgC(1,1,k),auxmat(1,1))
10447       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10448       vv1(1)=pizda1(1,1)-pizda1(2,2)
10449       vv1(2)=pizda1(1,2)+pizda1(2,1)
10450       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10451       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10452       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10453       s5=scalar2(vv(1),Dtobr2(1,i))
10454 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10455       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10456       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10457      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10458      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10459      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10460      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10461      & +scalar2(vv(1),Dtobr2der(1,i)))
10462       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10463       vv1(1)=pizda1(1,1)-pizda1(2,2)
10464       vv1(2)=pizda1(1,2)+pizda1(2,1)
10465       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10466       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10467       if (l.eq.j+1) then
10468         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10469      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10470      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10471      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10472      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10473       else
10474         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10475      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10476      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10477      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10478      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10479       endif
10480       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10481       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10482       vv1(1)=pizda1(1,1)-pizda1(2,2)
10483       vv1(2)=pizda1(1,2)+pizda1(2,1)
10484       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10485      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10486      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10487      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10488       do iii=1,2
10489         if (swap) then
10490           ind=3-iii
10491         else
10492           ind=iii
10493         endif
10494         do kkk=1,5
10495           do lll=1,3
10496             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10497             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10498             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10499             call transpose2(EUgC(1,1,k),auxmat(1,1))
10500             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10501      &        pizda1(1,1))
10502             vv1(1)=pizda1(1,1)-pizda1(2,2)
10503             vv1(2)=pizda1(1,2)+pizda1(2,1)
10504             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10505             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10506      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10507             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10508      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10509             s5=scalar2(vv(1),Dtobr2(1,i))
10510             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10511           enddo
10512         enddo
10513       enddo
10514       return
10515       end
10516 c----------------------------------------------------------------------------
10517       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10518       implicit real*8 (a-h,o-z)
10519       include 'DIMENSIONS'
10520       include 'COMMON.IOUNITS'
10521       include 'COMMON.CHAIN'
10522       include 'COMMON.DERIV'
10523       include 'COMMON.INTERACT'
10524       include 'COMMON.CONTACTS'
10525       include 'COMMON.TORSION'
10526       include 'COMMON.VAR'
10527       include 'COMMON.GEO'
10528       logical swap
10529       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10530      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10531       logical lprn
10532       common /kutas/ lprn
10533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10534 C                                                                              C
10535 C      Parallel       Antiparallel                                             C
10536 C                                                                              C
10537 C          o             o                                                     C
10538 C     \   /l\           /j\   /                                                C
10539 C      \ /   \         /   \ /                                                 C
10540 C       o| o |         | o |o                                                  C
10541 C     \ j|/k\|      \  |/k\|l                                                  C
10542 C      \ /   \       \ /   \                                                   C
10543 C       o             o                                                        C
10544 C       i             i                                                        C
10545 C                                                                              C
10546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10547 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10548 C AL 7/4/01 s1 would occur in the sixth-order moment,
10549 C           but not in a cluster cumulant
10550 #ifdef MOMENT
10551       s1=dip(1,jj,i)*dip(1,kk,k)
10552 #endif
10553       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10554       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10555       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10556       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10557       call transpose2(EUg(1,1,k),auxmat(1,1))
10558       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10559       vv(1)=pizda(1,1)-pizda(2,2)
10560       vv(2)=pizda(1,2)+pizda(2,1)
10561       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10562 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10563 #ifdef MOMENT
10564       eello6_graph2=-(s1+s2+s3+s4)
10565 #else
10566       eello6_graph2=-(s2+s3+s4)
10567 #endif
10568 c      eello6_graph2=-s3
10569 C Derivatives in gamma(i-1)
10570       if (i.gt.1) then
10571 #ifdef MOMENT
10572         s1=dipderg(1,jj,i)*dip(1,kk,k)
10573 #endif
10574         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10575         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10576         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10577         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10578 #ifdef MOMENT
10579         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10580 #else
10581         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10582 #endif
10583 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10584       endif
10585 C Derivatives in gamma(k-1)
10586 #ifdef MOMENT
10587       s1=dip(1,jj,i)*dipderg(1,kk,k)
10588 #endif
10589       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10590       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10591       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10592       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10593       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10594       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10595       vv(1)=pizda(1,1)-pizda(2,2)
10596       vv(2)=pizda(1,2)+pizda(2,1)
10597       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10598 #ifdef MOMENT
10599       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10600 #else
10601       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10602 #endif
10603 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10604 C Derivatives in gamma(j-1) or gamma(l-1)
10605       if (j.gt.1) then
10606 #ifdef MOMENT
10607         s1=dipderg(3,jj,i)*dip(1,kk,k)
10608 #endif
10609         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10610         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10611         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10612         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10613         vv(1)=pizda(1,1)-pizda(2,2)
10614         vv(2)=pizda(1,2)+pizda(2,1)
10615         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10616 #ifdef MOMENT
10617         if (swap) then
10618           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10619         else
10620           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10621         endif
10622 #endif
10623         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10624 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10625       endif
10626 C Derivatives in gamma(l-1) or gamma(j-1)
10627       if (l.gt.1) then
10628 #ifdef MOMENT
10629         s1=dip(1,jj,i)*dipderg(3,kk,k)
10630 #endif
10631         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10632         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10633         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10634         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10635         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10636         vv(1)=pizda(1,1)-pizda(2,2)
10637         vv(2)=pizda(1,2)+pizda(2,1)
10638         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10639 #ifdef MOMENT
10640         if (swap) then
10641           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10642         else
10643           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10644         endif
10645 #endif
10646         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10647 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10648       endif
10649 C Cartesian derivatives.
10650       if (lprn) then
10651         write (2,*) 'In eello6_graph2'
10652         do iii=1,2
10653           write (2,*) 'iii=',iii
10654           do kkk=1,5
10655             write (2,*) 'kkk=',kkk
10656             do jjj=1,2
10657               write (2,'(3(2f10.5),5x)')
10658      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10659             enddo
10660           enddo
10661         enddo
10662       endif
10663       do iii=1,2
10664         do kkk=1,5
10665           do lll=1,3
10666 #ifdef MOMENT
10667             if (iii.eq.1) then
10668               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10669             else
10670               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10671             endif
10672 #endif
10673             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10674      &        auxvec(1))
10675             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10676             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10677      &        auxvec(1))
10678             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10679             call transpose2(EUg(1,1,k),auxmat(1,1))
10680             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10681      &        pizda(1,1))
10682             vv(1)=pizda(1,1)-pizda(2,2)
10683             vv(2)=pizda(1,2)+pizda(2,1)
10684             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10685 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10686 #ifdef MOMENT
10687             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10688 #else
10689             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10690 #endif
10691             if (swap) then
10692               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10693             else
10694               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10695             endif
10696           enddo
10697         enddo
10698       enddo
10699       return
10700       end
10701 c----------------------------------------------------------------------------
10702       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10703       implicit real*8 (a-h,o-z)
10704       include 'DIMENSIONS'
10705       include 'COMMON.IOUNITS'
10706       include 'COMMON.CHAIN'
10707       include 'COMMON.DERIV'
10708       include 'COMMON.INTERACT'
10709       include 'COMMON.CONTACTS'
10710       include 'COMMON.TORSION'
10711       include 'COMMON.VAR'
10712       include 'COMMON.GEO'
10713       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10714       logical swap
10715 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10716 C                                                                              C
10717 C      Parallel       Antiparallel                                             C
10718 C                                                                              C
10719 C          o             o                                                     C
10720 C         /l\   /   \   /j\                                                    C
10721 C        /   \ /     \ /   \                                                   C
10722 C       /| o |o       o| o |\                                                  C
10723 C       j|/k\|  /      |/k\|l /                                                C
10724 C        /   \ /       /   \ /                                                 C
10725 C       /     o       /     o                                                  C
10726 C       i             i                                                        C
10727 C                                                                              C
10728 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10729 C
10730 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10731 C           energy moment and not to the cluster cumulant.
10732       iti=itortyp(itype(i))
10733       if (j.lt.nres-1) then
10734         itj1=itype2loc(itype(j+1))
10735       else
10736         itj1=nloctyp
10737       endif
10738       itk=itype2loc(itype(k))
10739       itk1=itype2loc(itype(k+1))
10740       if (l.lt.nres-1) then
10741         itl1=itype2loc(itype(l+1))
10742       else
10743         itl1=nloctyp
10744       endif
10745 #ifdef MOMENT
10746       s1=dip(4,jj,i)*dip(4,kk,k)
10747 #endif
10748       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10749       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10750       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10751       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10752       call transpose2(EE(1,1,k),auxmat(1,1))
10753       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10754       vv(1)=pizda(1,1)+pizda(2,2)
10755       vv(2)=pizda(2,1)-pizda(1,2)
10756       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10757 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10758 cd     & "sum",-(s2+s3+s4)
10759 #ifdef MOMENT
10760       eello6_graph3=-(s1+s2+s3+s4)
10761 #else
10762       eello6_graph3=-(s2+s3+s4)
10763 #endif
10764 c      eello6_graph3=-s4
10765 C Derivatives in gamma(k-1)
10766       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10767       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10768       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10769       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10770 C Derivatives in gamma(l-1)
10771       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10772       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10773       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10774       vv(1)=pizda(1,1)+pizda(2,2)
10775       vv(2)=pizda(2,1)-pizda(1,2)
10776       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10777       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10778 C Cartesian derivatives.
10779       do iii=1,2
10780         do kkk=1,5
10781           do lll=1,3
10782 #ifdef MOMENT
10783             if (iii.eq.1) then
10784               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10785             else
10786               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10787             endif
10788 #endif
10789             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10790      &        auxvec(1))
10791             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10792             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10793      &        auxvec(1))
10794             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10795             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10796      &        pizda(1,1))
10797             vv(1)=pizda(1,1)+pizda(2,2)
10798             vv(2)=pizda(2,1)-pizda(1,2)
10799             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10800 #ifdef MOMENT
10801             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10802 #else
10803             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10804 #endif
10805             if (swap) then
10806               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10807             else
10808               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10809             endif
10810 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10811           enddo
10812         enddo
10813       enddo
10814       return
10815       end
10816 c----------------------------------------------------------------------------
10817       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10818       implicit real*8 (a-h,o-z)
10819       include 'DIMENSIONS'
10820       include 'COMMON.IOUNITS'
10821       include 'COMMON.CHAIN'
10822       include 'COMMON.DERIV'
10823       include 'COMMON.INTERACT'
10824       include 'COMMON.CONTACTS'
10825       include 'COMMON.TORSION'
10826       include 'COMMON.VAR'
10827       include 'COMMON.GEO'
10828       include 'COMMON.FFIELD'
10829       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10830      & auxvec1(2),auxmat1(2,2)
10831       logical swap
10832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10833 C                                                                              C
10834 C      Parallel       Antiparallel                                             C
10835 C                                                                              C
10836 C          o             o                                                     C
10837 C         /l\   /   \   /j\                                                    C
10838 C        /   \ /     \ /   \                                                   C
10839 C       /| o |o       o| o |\                                                  C
10840 C     \ j|/k\|      \  |/k\|l                                                  C
10841 C      \ /   \       \ /   \                                                   C
10842 C       o     \       o     \                                                  C
10843 C       i             i                                                        C
10844 C                                                                              C
10845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10846 C
10847 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10848 C           energy moment and not to the cluster cumulant.
10849 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10850       iti=itype2loc(itype(i))
10851       itj=itype2loc(itype(j))
10852       if (j.lt.nres-1) then
10853         itj1=itype2loc(itype(j+1))
10854       else
10855         itj1=nloctyp
10856       endif
10857       itk=itype2loc(itype(k))
10858       if (k.lt.nres-1) then
10859         itk1=itype2loc(itype(k+1))
10860       else
10861         itk1=nloctyp
10862       endif
10863       itl=itype2loc(itype(l))
10864       if (l.lt.nres-1) then
10865         itl1=itype2loc(itype(l+1))
10866       else
10867         itl1=nloctyp
10868       endif
10869 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10870 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10871 cd     & ' itl',itl,' itl1',itl1
10872 #ifdef MOMENT
10873       if (imat.eq.1) then
10874         s1=dip(3,jj,i)*dip(3,kk,k)
10875       else
10876         s1=dip(2,jj,j)*dip(2,kk,l)
10877       endif
10878 #endif
10879       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10880       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10881       if (j.eq.l+1) then
10882         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10883         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10884       else
10885         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10886         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10887       endif
10888       call transpose2(EUg(1,1,k),auxmat(1,1))
10889       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10890       vv(1)=pizda(1,1)-pizda(2,2)
10891       vv(2)=pizda(2,1)+pizda(1,2)
10892       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10893 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10894 #ifdef MOMENT
10895       eello6_graph4=-(s1+s2+s3+s4)
10896 #else
10897       eello6_graph4=-(s2+s3+s4)
10898 #endif
10899 C Derivatives in gamma(i-1)
10900       if (i.gt.1) then
10901 #ifdef MOMENT
10902         if (imat.eq.1) then
10903           s1=dipderg(2,jj,i)*dip(3,kk,k)
10904         else
10905           s1=dipderg(4,jj,j)*dip(2,kk,l)
10906         endif
10907 #endif
10908         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10909         if (j.eq.l+1) then
10910           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10911           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10912         else
10913           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10914           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10915         endif
10916         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10917         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10918 cd          write (2,*) 'turn6 derivatives'
10919 #ifdef MOMENT
10920           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10921 #else
10922           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10923 #endif
10924         else
10925 #ifdef MOMENT
10926           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10927 #else
10928           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10929 #endif
10930         endif
10931       endif
10932 C Derivatives in gamma(k-1)
10933 #ifdef MOMENT
10934       if (imat.eq.1) then
10935         s1=dip(3,jj,i)*dipderg(2,kk,k)
10936       else
10937         s1=dip(2,jj,j)*dipderg(4,kk,l)
10938       endif
10939 #endif
10940       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10941       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10942       if (j.eq.l+1) then
10943         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10944         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10945       else
10946         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10947         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10948       endif
10949       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10950       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10951       vv(1)=pizda(1,1)-pizda(2,2)
10952       vv(2)=pizda(2,1)+pizda(1,2)
10953       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10954       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10955 #ifdef MOMENT
10956         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10957 #else
10958         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10959 #endif
10960       else
10961 #ifdef MOMENT
10962         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10963 #else
10964         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10965 #endif
10966       endif
10967 C Derivatives in gamma(j-1) or gamma(l-1)
10968       if (l.eq.j+1 .and. l.gt.1) then
10969         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10970         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10971         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10972         vv(1)=pizda(1,1)-pizda(2,2)
10973         vv(2)=pizda(2,1)+pizda(1,2)
10974         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10975         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10976       else if (j.gt.1) then
10977         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10978         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10979         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10980         vv(1)=pizda(1,1)-pizda(2,2)
10981         vv(2)=pizda(2,1)+pizda(1,2)
10982         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10983         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10984           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10985         else
10986           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10987         endif
10988       endif
10989 C Cartesian derivatives.
10990       do iii=1,2
10991         do kkk=1,5
10992           do lll=1,3
10993 #ifdef MOMENT
10994             if (iii.eq.1) then
10995               if (imat.eq.1) then
10996                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10997               else
10998                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10999               endif
11000             else
11001               if (imat.eq.1) then
11002                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11003               else
11004                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11005               endif
11006             endif
11007 #endif
11008             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11009      &        auxvec(1))
11010             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11011             if (j.eq.l+1) then
11012               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11013      &          b1(1,j+1),auxvec(1))
11014               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11015             else
11016               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11017      &          b1(1,l+1),auxvec(1))
11018               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11019             endif
11020             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11021      &        pizda(1,1))
11022             vv(1)=pizda(1,1)-pizda(2,2)
11023             vv(2)=pizda(2,1)+pizda(1,2)
11024             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11025             if (swap) then
11026               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11027 #ifdef MOMENT
11028                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11029      &             -(s1+s2+s4)
11030 #else
11031                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11032      &             -(s2+s4)
11033 #endif
11034                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11035               else
11036 #ifdef MOMENT
11037                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11038 #else
11039                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11040 #endif
11041                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11042               endif
11043             else
11044 #ifdef MOMENT
11045               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11046 #else
11047               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11048 #endif
11049               if (l.eq.j+1) then
11050                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11051               else
11052                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11053               endif
11054             endif
11055           enddo
11056         enddo
11057       enddo
11058       return
11059       end
11060 c----------------------------------------------------------------------------
11061       double precision function eello_turn6(i,jj,kk)
11062       implicit real*8 (a-h,o-z)
11063       include 'DIMENSIONS'
11064       include 'COMMON.IOUNITS'
11065       include 'COMMON.CHAIN'
11066       include 'COMMON.DERIV'
11067       include 'COMMON.INTERACT'
11068       include 'COMMON.CONTACTS'
11069       include 'COMMON.TORSION'
11070       include 'COMMON.VAR'
11071       include 'COMMON.GEO'
11072       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11073      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11074      &  ggg1(3),ggg2(3)
11075       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11076      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11077 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11078 C           the respective energy moment and not to the cluster cumulant.
11079       s1=0.0d0
11080       s8=0.0d0
11081       s13=0.0d0
11082 c
11083       eello_turn6=0.0d0
11084       j=i+4
11085       k=i+1
11086       l=i+3
11087       iti=itype2loc(itype(i))
11088       itk=itype2loc(itype(k))
11089       itk1=itype2loc(itype(k+1))
11090       itl=itype2loc(itype(l))
11091       itj=itype2loc(itype(j))
11092 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11093 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11094 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11095 cd        eello6=0.0d0
11096 cd        return
11097 cd      endif
11098 cd      write (iout,*)
11099 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11100 cd     &   ' and',k,l
11101 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11102       do iii=1,2
11103         do kkk=1,5
11104           do lll=1,3
11105             derx_turn(lll,kkk,iii)=0.0d0
11106           enddo
11107         enddo
11108       enddo
11109 cd      eij=1.0d0
11110 cd      ekl=1.0d0
11111 cd      ekont=1.0d0
11112       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11113 cd      eello6_5=0.0d0
11114 cd      write (2,*) 'eello6_5',eello6_5
11115 #ifdef MOMENT
11116       call transpose2(AEA(1,1,1),auxmat(1,1))
11117       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11118       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11119       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11120 #endif
11121       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11122       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11123       s2 = scalar2(b1(1,k),vtemp1(1))
11124 #ifdef MOMENT
11125       call transpose2(AEA(1,1,2),atemp(1,1))
11126       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11127       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11128       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11129 #endif
11130       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11131       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11132       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11133 #ifdef MOMENT
11134       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11135       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11136       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11137       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11138       ss13 = scalar2(b1(1,k),vtemp4(1))
11139       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11140 #endif
11141 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11142 c      s1=0.0d0
11143 c      s2=0.0d0
11144 c      s8=0.0d0
11145 c      s12=0.0d0
11146 c      s13=0.0d0
11147       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11148 C Derivatives in gamma(i+2)
11149       s1d =0.0d0
11150       s8d =0.0d0
11151 #ifdef MOMENT
11152       call transpose2(AEA(1,1,1),auxmatd(1,1))
11153       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11154       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11155       call transpose2(AEAderg(1,1,2),atempd(1,1))
11156       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11157       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11158 #endif
11159       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11160       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11161       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11162 c      s1d=0.0d0
11163 c      s2d=0.0d0
11164 c      s8d=0.0d0
11165 c      s12d=0.0d0
11166 c      s13d=0.0d0
11167       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11168 C Derivatives in gamma(i+3)
11169 #ifdef MOMENT
11170       call transpose2(AEA(1,1,1),auxmatd(1,1))
11171       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11172       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11173       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11174 #endif
11175       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11176       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11177       s2d = scalar2(b1(1,k),vtemp1d(1))
11178 #ifdef MOMENT
11179       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11180       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11181 #endif
11182       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11183 #ifdef MOMENT
11184       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11185       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11186       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11187 #endif
11188 c      s1d=0.0d0
11189 c      s2d=0.0d0
11190 c      s8d=0.0d0
11191 c      s12d=0.0d0
11192 c      s13d=0.0d0
11193 #ifdef MOMENT
11194       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11195      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11196 #else
11197       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11198      &               -0.5d0*ekont*(s2d+s12d)
11199 #endif
11200 C Derivatives in gamma(i+4)
11201       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11202       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11203       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11204 #ifdef MOMENT
11205       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11206       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11207       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11208 #endif
11209 c      s1d=0.0d0
11210 c      s2d=0.0d0
11211 c      s8d=0.0d0
11212 C      s12d=0.0d0
11213 c      s13d=0.0d0
11214 #ifdef MOMENT
11215       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11216 #else
11217       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11218 #endif
11219 C Derivatives in gamma(i+5)
11220 #ifdef MOMENT
11221       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11222       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11223       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11224 #endif
11225       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11226       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11227       s2d = scalar2(b1(1,k),vtemp1d(1))
11228 #ifdef MOMENT
11229       call transpose2(AEA(1,1,2),atempd(1,1))
11230       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11231       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11232 #endif
11233       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11234       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11235 #ifdef MOMENT
11236       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11237       ss13d = scalar2(b1(1,k),vtemp4d(1))
11238       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11239 #endif
11240 c      s1d=0.0d0
11241 c      s2d=0.0d0
11242 c      s8d=0.0d0
11243 c      s12d=0.0d0
11244 c      s13d=0.0d0
11245 #ifdef MOMENT
11246       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11247      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11248 #else
11249       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11250      &               -0.5d0*ekont*(s2d+s12d)
11251 #endif
11252 C Cartesian derivatives
11253       do iii=1,2
11254         do kkk=1,5
11255           do lll=1,3
11256 #ifdef MOMENT
11257             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11258             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11259             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11260 #endif
11261             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11262             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11263      &          vtemp1d(1))
11264             s2d = scalar2(b1(1,k),vtemp1d(1))
11265 #ifdef MOMENT
11266             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11267             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11268             s8d = -(atempd(1,1)+atempd(2,2))*
11269      &           scalar2(cc(1,1,itl),vtemp2(1))
11270 #endif
11271             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11272      &           auxmatd(1,1))
11273             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11274             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11275 c      s1d=0.0d0
11276 c      s2d=0.0d0
11277 c      s8d=0.0d0
11278 c      s12d=0.0d0
11279 c      s13d=0.0d0
11280 #ifdef MOMENT
11281             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11282      &        - 0.5d0*(s1d+s2d)
11283 #else
11284             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11285      &        - 0.5d0*s2d
11286 #endif
11287 #ifdef MOMENT
11288             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11289      &        - 0.5d0*(s8d+s12d)
11290 #else
11291             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11292      &        - 0.5d0*s12d
11293 #endif
11294           enddo
11295         enddo
11296       enddo
11297 #ifdef MOMENT
11298       do kkk=1,5
11299         do lll=1,3
11300           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11301      &      achuj_tempd(1,1))
11302           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11303           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11304           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11305           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11306           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11307      &      vtemp4d(1))
11308           ss13d = scalar2(b1(1,k),vtemp4d(1))
11309           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11310           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11311         enddo
11312       enddo
11313 #endif
11314 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11315 cd     &  16*eel_turn6_num
11316 cd      goto 1112
11317       if (j.lt.nres-1) then
11318         j1=j+1
11319         j2=j-1
11320       else
11321         j1=j-1
11322         j2=j-2
11323       endif
11324       if (l.lt.nres-1) then
11325         l1=l+1
11326         l2=l-1
11327       else
11328         l1=l-1
11329         l2=l-2
11330       endif
11331       do ll=1,3
11332 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11333 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11334 cgrad        ghalf=0.5d0*ggg1(ll)
11335 cd        ghalf=0.0d0
11336         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11337         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11338         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11339      &    +ekont*derx_turn(ll,2,1)
11340         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11341         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11342      &    +ekont*derx_turn(ll,4,1)
11343         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11344         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11345         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11346 cgrad        ghalf=0.5d0*ggg2(ll)
11347 cd        ghalf=0.0d0
11348         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11349      &    +ekont*derx_turn(ll,2,2)
11350         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11351         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11352      &    +ekont*derx_turn(ll,4,2)
11353         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11354         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11355         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11356       enddo
11357 cd      goto 1112
11358 cgrad      do m=i+1,j-1
11359 cgrad        do ll=1,3
11360 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11361 cgrad        enddo
11362 cgrad      enddo
11363 cgrad      do m=k+1,l-1
11364 cgrad        do ll=1,3
11365 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11366 cgrad        enddo
11367 cgrad      enddo
11368 cgrad1112  continue
11369 cgrad      do m=i+2,j2
11370 cgrad        do ll=1,3
11371 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11372 cgrad        enddo
11373 cgrad      enddo
11374 cgrad      do m=k+2,l2
11375 cgrad        do ll=1,3
11376 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11377 cgrad        enddo
11378 cgrad      enddo
11379 cd      do iii=1,nres-3
11380 cd        write (2,*) iii,g_corr6_loc(iii)
11381 cd      enddo
11382       eello_turn6=ekont*eel_turn6
11383 cd      write (2,*) 'ekont',ekont
11384 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11385       return
11386       end
11387
11388 C-----------------------------------------------------------------------------
11389       double precision function scalar(u,v)
11390 !DIR$ INLINEALWAYS scalar
11391 #ifndef OSF
11392 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11393 #endif
11394       implicit none
11395       double precision u(3),v(3)
11396 cd      double precision sc
11397 cd      integer i
11398 cd      sc=0.0d0
11399 cd      do i=1,3
11400 cd        sc=sc+u(i)*v(i)
11401 cd      enddo
11402 cd      scalar=sc
11403
11404       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11405       return
11406       end
11407 crc-------------------------------------------------
11408       SUBROUTINE MATVEC2(A1,V1,V2)
11409 !DIR$ INLINEALWAYS MATVEC2
11410 #ifndef OSF
11411 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11412 #endif
11413       implicit real*8 (a-h,o-z)
11414       include 'DIMENSIONS'
11415       DIMENSION A1(2,2),V1(2),V2(2)
11416 c      DO 1 I=1,2
11417 c        VI=0.0
11418 c        DO 3 K=1,2
11419 c    3     VI=VI+A1(I,K)*V1(K)
11420 c        Vaux(I)=VI
11421 c    1 CONTINUE
11422
11423       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11424       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11425
11426       v2(1)=vaux1
11427       v2(2)=vaux2
11428       END
11429 C---------------------------------------
11430       SUBROUTINE MATMAT2(A1,A2,A3)
11431 #ifndef OSF
11432 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11433 #endif
11434       implicit real*8 (a-h,o-z)
11435       include 'DIMENSIONS'
11436       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11437 c      DIMENSION AI3(2,2)
11438 c        DO  J=1,2
11439 c          A3IJ=0.0
11440 c          DO K=1,2
11441 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11442 c          enddo
11443 c          A3(I,J)=A3IJ
11444 c       enddo
11445 c      enddo
11446
11447       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11448       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11449       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11450       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11451
11452       A3(1,1)=AI3_11
11453       A3(2,1)=AI3_21
11454       A3(1,2)=AI3_12
11455       A3(2,2)=AI3_22
11456       END
11457
11458 c-------------------------------------------------------------------------
11459       double precision function scalar2(u,v)
11460 !DIR$ INLINEALWAYS scalar2
11461       implicit none
11462       double precision u(2),v(2)
11463       double precision sc
11464       integer i
11465       scalar2=u(1)*v(1)+u(2)*v(2)
11466       return
11467       end
11468
11469 C-----------------------------------------------------------------------------
11470
11471       subroutine transpose2(a,at)
11472 !DIR$ INLINEALWAYS transpose2
11473 #ifndef OSF
11474 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11475 #endif
11476       implicit none
11477       double precision a(2,2),at(2,2)
11478       at(1,1)=a(1,1)
11479       at(1,2)=a(2,1)
11480       at(2,1)=a(1,2)
11481       at(2,2)=a(2,2)
11482       return
11483       end
11484 c--------------------------------------------------------------------------
11485       subroutine transpose(n,a,at)
11486       implicit none
11487       integer n,i,j
11488       double precision a(n,n),at(n,n)
11489       do i=1,n
11490         do j=1,n
11491           at(j,i)=a(i,j)
11492         enddo
11493       enddo
11494       return
11495       end
11496 C---------------------------------------------------------------------------
11497       subroutine prodmat3(a1,a2,kk,transp,prod)
11498 !DIR$ INLINEALWAYS prodmat3
11499 #ifndef OSF
11500 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11501 #endif
11502       implicit none
11503       integer i,j
11504       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11505       logical transp
11506 crc      double precision auxmat(2,2),prod_(2,2)
11507
11508       if (transp) then
11509 crc        call transpose2(kk(1,1),auxmat(1,1))
11510 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11511 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11512
11513            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11514      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11515            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11516      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11517            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11518      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11519            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11520      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11521
11522       else
11523 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11524 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11525
11526            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11527      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11528            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11529      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11530            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11531      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11532            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11533      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11534
11535       endif
11536 c      call transpose2(a2(1,1),a2t(1,1))
11537
11538 crc      print *,transp
11539 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11540 crc      print *,((prod(i,j),i=1,2),j=1,2)
11541
11542       return
11543       end
11544 CCC----------------------------------------------
11545       subroutine Eliptransfer(eliptran)
11546       implicit real*8 (a-h,o-z)
11547       include 'DIMENSIONS'
11548       include 'COMMON.GEO'
11549       include 'COMMON.VAR'
11550       include 'COMMON.LOCAL'
11551       include 'COMMON.CHAIN'
11552       include 'COMMON.DERIV'
11553       include 'COMMON.NAMES'
11554       include 'COMMON.INTERACT'
11555       include 'COMMON.IOUNITS'
11556       include 'COMMON.CALC'
11557       include 'COMMON.CONTROL'
11558       include 'COMMON.SPLITELE'
11559       include 'COMMON.SBRIDGE'
11560 C this is done by Adasko
11561 C      print *,"wchodze"
11562 C structure of box:
11563 C      water
11564 C--bordliptop-- buffore starts
11565 C--bufliptop--- here true lipid starts
11566 C      lipid
11567 C--buflipbot--- lipid ends buffore starts
11568 C--bordlipbot--buffore ends
11569       eliptran=0.0
11570       do i=ilip_start,ilip_end
11571 C       do i=1,1
11572         if (itype(i).eq.ntyp1) cycle
11573
11574         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11575         if (positi.le.0.0) positi=positi+boxzsize
11576 C        print *,i
11577 C first for peptide groups
11578 c for each residue check if it is in lipid or lipid water border area
11579        if ((positi.gt.bordlipbot)
11580      &.and.(positi.lt.bordliptop)) then
11581 C the energy transfer exist
11582         if (positi.lt.buflipbot) then
11583 C what fraction I am in
11584          fracinbuf=1.0d0-
11585      &        ((positi-bordlipbot)/lipbufthick)
11586 C lipbufthick is thickenes of lipid buffore
11587          sslip=sscalelip(fracinbuf)
11588          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11589          eliptran=eliptran+sslip*pepliptran
11590          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11591          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11592 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11593
11594 C        print *,"doing sccale for lower part"
11595 C         print *,i,sslip,fracinbuf,ssgradlip
11596         elseif (positi.gt.bufliptop) then
11597          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11598          sslip=sscalelip(fracinbuf)
11599          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11600          eliptran=eliptran+sslip*pepliptran
11601          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11602          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11603 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11604 C          print *, "doing sscalefor top part"
11605 C         print *,i,sslip,fracinbuf,ssgradlip
11606         else
11607          eliptran=eliptran+pepliptran
11608 C         print *,"I am in true lipid"
11609         endif
11610 C       else
11611 C       eliptran=elpitran+0.0 ! I am in water
11612        endif
11613        enddo
11614 C       print *, "nic nie bylo w lipidzie?"
11615 C now multiply all by the peptide group transfer factor
11616 C       eliptran=eliptran*pepliptran
11617 C now the same for side chains
11618 CV       do i=1,1
11619        do i=ilip_start,ilip_end
11620         if (itype(i).eq.ntyp1) cycle
11621         positi=(mod(c(3,i+nres),boxzsize))
11622         if (positi.le.0) positi=positi+boxzsize
11623 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11624 c for each residue check if it is in lipid or lipid water border area
11625 C       respos=mod(c(3,i+nres),boxzsize)
11626 C       print *,positi,bordlipbot,buflipbot
11627        if ((positi.gt.bordlipbot)
11628      & .and.(positi.lt.bordliptop)) then
11629 C the energy transfer exist
11630         if (positi.lt.buflipbot) then
11631          fracinbuf=1.0d0-
11632      &     ((positi-bordlipbot)/lipbufthick)
11633 C lipbufthick is thickenes of lipid buffore
11634          sslip=sscalelip(fracinbuf)
11635          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11636          eliptran=eliptran+sslip*liptranene(itype(i))
11637          gliptranx(3,i)=gliptranx(3,i)
11638      &+ssgradlip*liptranene(itype(i))
11639          gliptranc(3,i-1)= gliptranc(3,i-1)
11640      &+ssgradlip*liptranene(itype(i))
11641 C         print *,"doing sccale for lower part"
11642         elseif (positi.gt.bufliptop) then
11643          fracinbuf=1.0d0-
11644      &((bordliptop-positi)/lipbufthick)
11645          sslip=sscalelip(fracinbuf)
11646          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11647          eliptran=eliptran+sslip*liptranene(itype(i))
11648          gliptranx(3,i)=gliptranx(3,i)
11649      &+ssgradlip*liptranene(itype(i))
11650          gliptranc(3,i-1)= gliptranc(3,i-1)
11651      &+ssgradlip*liptranene(itype(i))
11652 C          print *, "doing sscalefor top part",sslip,fracinbuf
11653         else
11654          eliptran=eliptran+liptranene(itype(i))
11655 C         print *,"I am in true lipid"
11656         endif
11657         endif ! if in lipid or buffor
11658 C       else
11659 C       eliptran=elpitran+0.0 ! I am in water
11660        enddo
11661        return
11662        end
11663 C---------------------------------------------------------
11664 C AFM soubroutine for constant force
11665        subroutine AFMforce(Eafmforce)
11666        implicit real*8 (a-h,o-z)
11667       include 'DIMENSIONS'
11668       include 'COMMON.GEO'
11669       include 'COMMON.VAR'
11670       include 'COMMON.LOCAL'
11671       include 'COMMON.CHAIN'
11672       include 'COMMON.DERIV'
11673       include 'COMMON.NAMES'
11674       include 'COMMON.INTERACT'
11675       include 'COMMON.IOUNITS'
11676       include 'COMMON.CALC'
11677       include 'COMMON.CONTROL'
11678       include 'COMMON.SPLITELE'
11679       include 'COMMON.SBRIDGE'
11680       real*8 diffafm(3)
11681       dist=0.0d0
11682       Eafmforce=0.0d0
11683       do i=1,3
11684       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11685       dist=dist+diffafm(i)**2
11686       enddo
11687       dist=dsqrt(dist)
11688       Eafmforce=-forceAFMconst*(dist-distafminit)
11689       do i=1,3
11690       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11691       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11692       enddo
11693 C      print *,'AFM',Eafmforce
11694       return
11695       end
11696 C---------------------------------------------------------
11697 C AFM subroutine with pseudoconstant velocity
11698        subroutine AFMvel(Eafmforce)
11699        implicit real*8 (a-h,o-z)
11700       include 'DIMENSIONS'
11701       include 'COMMON.GEO'
11702       include 'COMMON.VAR'
11703       include 'COMMON.LOCAL'
11704       include 'COMMON.CHAIN'
11705       include 'COMMON.DERIV'
11706       include 'COMMON.NAMES'
11707       include 'COMMON.INTERACT'
11708       include 'COMMON.IOUNITS'
11709       include 'COMMON.CALC'
11710       include 'COMMON.CONTROL'
11711       include 'COMMON.SPLITELE'
11712       include 'COMMON.SBRIDGE'
11713       real*8 diffafm(3)
11714 C Only for check grad COMMENT if not used for checkgrad
11715 C      totT=3.0d0
11716 C--------------------------------------------------------
11717 C      print *,"wchodze"
11718       dist=0.0d0
11719       Eafmforce=0.0d0
11720       do i=1,3
11721       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11722       dist=dist+diffafm(i)**2
11723       enddo
11724       dist=dsqrt(dist)
11725       Eafmforce=0.5d0*forceAFMconst
11726      & *(distafminit+totTafm*velAFMconst-dist)**2
11727 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11728       do i=1,3
11729       gradafm(i,afmend-1)=-forceAFMconst*
11730      &(distafminit+totTafm*velAFMconst-dist)
11731      &*diffafm(i)/dist
11732       gradafm(i,afmbeg-1)=forceAFMconst*
11733      &(distafminit+totTafm*velAFMconst-dist)
11734      &*diffafm(i)/dist
11735       enddo
11736 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11737       return
11738       end
11739 C-----------------------------------------------------------
11740 C first for shielding is setting of function of side-chains
11741        subroutine set_shield_fac
11742       implicit real*8 (a-h,o-z)
11743       include 'DIMENSIONS'
11744       include 'COMMON.CHAIN'
11745       include 'COMMON.DERIV'
11746       include 'COMMON.IOUNITS'
11747       include 'COMMON.SHIELD'
11748       include 'COMMON.INTERACT'
11749 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11750       double precision div77_81/0.974996043d0/,
11751      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11752
11753 C the vector between center of side_chain and peptide group
11754        double precision pep_side(3),long,side_calf(3),
11755      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11756      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11757 C the line belowe needs to be changed for FGPROC>1
11758       do i=1,nres-1
11759       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11760       ishield_list(i)=0
11761 Cif there two consequtive dummy atoms there is no peptide group between them
11762 C the line below has to be changed for FGPROC>1
11763       VolumeTotal=0.0
11764       do k=1,nres
11765        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11766        dist_pep_side=0.0
11767        dist_side_calf=0.0
11768        do j=1,3
11769 C first lets set vector conecting the ithe side-chain with kth side-chain
11770       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11771 C      pep_side(j)=2.0d0
11772 C and vector conecting the side-chain with its proper calfa
11773       side_calf(j)=c(j,k+nres)-c(j,k)
11774 C      side_calf(j)=2.0d0
11775       pept_group(j)=c(j,i)-c(j,i+1)
11776 C lets have their lenght
11777       dist_pep_side=pep_side(j)**2+dist_pep_side
11778       dist_side_calf=dist_side_calf+side_calf(j)**2
11779       dist_pept_group=dist_pept_group+pept_group(j)**2
11780       enddo
11781        dist_pep_side=dsqrt(dist_pep_side)
11782        dist_pept_group=dsqrt(dist_pept_group)
11783        dist_side_calf=dsqrt(dist_side_calf)
11784       do j=1,3
11785         pep_side_norm(j)=pep_side(j)/dist_pep_side
11786         side_calf_norm(j)=dist_side_calf
11787       enddo
11788 C now sscale fraction
11789        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11790 C       print *,buff_shield,"buff"
11791 C now sscale
11792         if (sh_frac_dist.le.0.0) cycle
11793 C If we reach here it means that this side chain reaches the shielding sphere
11794 C Lets add him to the list for gradient
11795         ishield_list(i)=ishield_list(i)+1
11796 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11797 C this list is essential otherwise problem would be O3
11798         shield_list(ishield_list(i),i)=k
11799 C Lets have the sscale value
11800         if (sh_frac_dist.gt.1.0) then
11801          scale_fac_dist=1.0d0
11802          do j=1,3
11803          sh_frac_dist_grad(j)=0.0d0
11804          enddo
11805         else
11806          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11807      &                   *(2.0*sh_frac_dist-3.0d0)
11808          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11809      &                  /dist_pep_side/buff_shield*0.5
11810 C remember for the final gradient multiply sh_frac_dist_grad(j)
11811 C for side_chain by factor -2 !
11812          do j=1,3
11813          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11814 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11815 C     &                    sh_frac_dist_grad(j)
11816          enddo
11817         endif
11818 C        if ((i.eq.3).and.(k.eq.2)) then
11819 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11820 C     & ,"TU"
11821 C        endif
11822
11823 C this is what is now we have the distance scaling now volume...
11824       short=short_r_sidechain(itype(k))
11825       long=long_r_sidechain(itype(k))
11826       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11827 C now costhet_grad
11828 C       costhet=0.0d0
11829        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11830 C       costhet_fac=0.0d0
11831        do j=1,3
11832          costhet_grad(j)=costhet_fac*pep_side(j)
11833        enddo
11834 C remember for the final gradient multiply costhet_grad(j)
11835 C for side_chain by factor -2 !
11836 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11837 C pep_side0pept_group is vector multiplication
11838       pep_side0pept_group=0.0
11839       do j=1,3
11840       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11841       enddo
11842       cosalfa=(pep_side0pept_group/
11843      & (dist_pep_side*dist_side_calf))
11844       fac_alfa_sin=1.0-cosalfa**2
11845       fac_alfa_sin=dsqrt(fac_alfa_sin)
11846       rkprim=fac_alfa_sin*(long-short)+short
11847 C now costhet_grad
11848        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11849        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11850
11851        do j=1,3
11852          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11853      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11854      &*(long-short)/fac_alfa_sin*cosalfa/
11855      &((dist_pep_side*dist_side_calf))*
11856      &((side_calf(j))-cosalfa*
11857      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11858
11859         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11860      &*(long-short)/fac_alfa_sin*cosalfa
11861      &/((dist_pep_side*dist_side_calf))*
11862      &(pep_side(j)-
11863      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11864        enddo
11865
11866       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11867      &                    /VSolvSphere_div
11868      &                    *wshield
11869 C now the gradient...
11870 C grad_shield is gradient of Calfa for peptide groups
11871 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11872 C     &               costhet,cosphi
11873 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11874 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11875       do j=1,3
11876       grad_shield(j,i)=grad_shield(j,i)
11877 C gradient po skalowaniu
11878      &                +(sh_frac_dist_grad(j)
11879 C  gradient po costhet
11880      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11881      &-scale_fac_dist*(cosphi_grad_long(j))
11882      &/(1.0-cosphi) )*div77_81
11883      &*VofOverlap
11884 C grad_shield_side is Cbeta sidechain gradient
11885       grad_shield_side(j,ishield_list(i),i)=
11886      &        (sh_frac_dist_grad(j)*-2.0d0
11887      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11888      &       +scale_fac_dist*(cosphi_grad_long(j))
11889      &        *2.0d0/(1.0-cosphi))
11890      &        *div77_81*VofOverlap
11891
11892        grad_shield_loc(j,ishield_list(i),i)=
11893      &   scale_fac_dist*cosphi_grad_loc(j)
11894      &        *2.0d0/(1.0-cosphi)
11895      &        *div77_81*VofOverlap
11896       enddo
11897       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11898       enddo
11899       fac_shield(i)=VolumeTotal*div77_81+div4_81
11900 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11901       enddo
11902       return
11903       end
11904 C--------------------------------------------------------------------------
11905       double precision function tschebyshev(m,n,x,y)
11906       implicit none
11907       include "DIMENSIONS"
11908       integer i,m,n
11909       double precision x(n),y,yy(0:maxvar),aux
11910 c Tschebyshev polynomial. Note that the first term is omitted
11911 c m=0: the constant term is included
11912 c m=1: the constant term is not included
11913       yy(0)=1.0d0
11914       yy(1)=y
11915       do i=2,n
11916         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11917       enddo
11918       aux=0.0d0
11919       do i=m,n
11920         aux=aux+x(i)*yy(i)
11921       enddo
11922       tschebyshev=aux
11923       return
11924       end
11925 C--------------------------------------------------------------------------
11926       double precision function gradtschebyshev(m,n,x,y)
11927       implicit none
11928       include "DIMENSIONS"
11929       integer i,m,n
11930       double precision x(n+1),y,yy(0:maxvar),aux
11931 c Tschebyshev polynomial. Note that the first term is omitted
11932 c m=0: the constant term is included
11933 c m=1: the constant term is not included
11934       yy(0)=1.0d0
11935       yy(1)=2.0d0*y
11936       do i=2,n
11937         yy(i)=2*y*yy(i-1)-yy(i-2)
11938       enddo
11939       aux=0.0d0
11940       do i=m,n
11941         aux=aux+x(i+1)*yy(i)*(i+1)
11942 C        print *, x(i+1),yy(i),i
11943       enddo
11944       gradtschebyshev=aux
11945       return
11946       end
11947 C------------------------------------------------------------------------
11948 C first for shielding is setting of function of side-chains
11949        subroutine set_shield_fac2
11950       implicit real*8 (a-h,o-z)
11951       include 'DIMENSIONS'
11952       include 'COMMON.CHAIN'
11953       include 'COMMON.DERIV'
11954       include 'COMMON.IOUNITS'
11955       include 'COMMON.SHIELD'
11956       include 'COMMON.INTERACT'
11957       include 'COMMON.LOCAL'
11958
11959 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11960       double precision div77_81/0.974996043d0/,
11961      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11962
11963 C the vector between center of side_chain and peptide group
11964        double precision pep_side(3),long,side_calf(3),
11965      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11966      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11967 C      write(2,*) "ivec",ivec_start,ivec_end
11968       do i=1,nres
11969         fac_shield(i)=0.0d0
11970         do j=1,3
11971         grad_shield(j,i)=0.0d0
11972         enddo
11973       enddo
11974 C the line belowe needs to be changed for FGPROC>1
11975       do i=ivec_start,ivec_end
11976 C      do i=1,nres-1
11977 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11978       ishield_list(i)=0
11979       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11980 Cif there two consequtive dummy atoms there is no peptide group between them
11981 C the line below has to be changed for FGPROC>1
11982       VolumeTotal=0.0
11983       do k=1,nres
11984        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11985        dist_pep_side=0.0
11986        dist_side_calf=0.0
11987        do j=1,3
11988 C first lets set vector conecting the ithe side-chain with kth side-chain
11989       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11990 C      pep_side(j)=2.0d0
11991 C and vector conecting the side-chain with its proper calfa
11992       side_calf(j)=c(j,k+nres)-c(j,k)
11993 C      side_calf(j)=2.0d0
11994       pept_group(j)=c(j,i)-c(j,i+1)
11995 C lets have their lenght
11996       dist_pep_side=pep_side(j)**2+dist_pep_side
11997       dist_side_calf=dist_side_calf+side_calf(j)**2
11998       dist_pept_group=dist_pept_group+pept_group(j)**2
11999       enddo
12000        dist_pep_side=dsqrt(dist_pep_side)
12001        dist_pept_group=dsqrt(dist_pept_group)
12002        dist_side_calf=dsqrt(dist_side_calf)
12003       do j=1,3
12004         pep_side_norm(j)=pep_side(j)/dist_pep_side
12005         side_calf_norm(j)=dist_side_calf
12006       enddo
12007 C now sscale fraction
12008        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12009 C       print *,buff_shield,"buff"
12010 C now sscale
12011         if (sh_frac_dist.le.0.0) cycle
12012 C        print *,ishield_list(i),i
12013 C If we reach here it means that this side chain reaches the shielding sphere
12014 C Lets add him to the list for gradient
12015         ishield_list(i)=ishield_list(i)+1
12016 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12017 C this list is essential otherwise problem would be O3
12018         shield_list(ishield_list(i),i)=k
12019 C Lets have the sscale value
12020         if (sh_frac_dist.gt.1.0) then
12021          scale_fac_dist=1.0d0
12022          do j=1,3
12023          sh_frac_dist_grad(j)=0.0d0
12024          enddo
12025         else
12026          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12027      &                   *(2.0d0*sh_frac_dist-3.0d0)
12028          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12029      &                  /dist_pep_side/buff_shield*0.5d0
12030 C remember for the final gradient multiply sh_frac_dist_grad(j)
12031 C for side_chain by factor -2 !
12032          do j=1,3
12033          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12034 C         sh_frac_dist_grad(j)=0.0d0
12035 C         scale_fac_dist=1.0d0
12036 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12037 C     &                    sh_frac_dist_grad(j)
12038          enddo
12039         endif
12040 C this is what is now we have the distance scaling now volume...
12041       short=short_r_sidechain(itype(k))
12042       long=long_r_sidechain(itype(k))
12043       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12044       sinthet=short/dist_pep_side*costhet
12045 C now costhet_grad
12046 C       costhet=0.6d0
12047 C       sinthet=0.8
12048        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12049 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12050 C     &             -short/dist_pep_side**2/costhet)
12051 C       costhet_fac=0.0d0
12052        do j=1,3
12053          costhet_grad(j)=costhet_fac*pep_side(j)
12054        enddo
12055 C remember for the final gradient multiply costhet_grad(j)
12056 C for side_chain by factor -2 !
12057 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12058 C pep_side0pept_group is vector multiplication
12059       pep_side0pept_group=0.0d0
12060       do j=1,3
12061       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12062       enddo
12063       cosalfa=(pep_side0pept_group/
12064      & (dist_pep_side*dist_side_calf))
12065       fac_alfa_sin=1.0d0-cosalfa**2
12066       fac_alfa_sin=dsqrt(fac_alfa_sin)
12067       rkprim=fac_alfa_sin*(long-short)+short
12068 C      rkprim=short
12069
12070 C now costhet_grad
12071        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12072 C       cosphi=0.6
12073        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12074        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12075      &      dist_pep_side**2)
12076 C       sinphi=0.8
12077        do j=1,3
12078          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12079      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12080      &*(long-short)/fac_alfa_sin*cosalfa/
12081      &((dist_pep_side*dist_side_calf))*
12082      &((side_calf(j))-cosalfa*
12083      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12084 C       cosphi_grad_long(j)=0.0d0
12085         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12086      &*(long-short)/fac_alfa_sin*cosalfa
12087      &/((dist_pep_side*dist_side_calf))*
12088      &(pep_side(j)-
12089      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12090 C       cosphi_grad_loc(j)=0.0d0
12091        enddo
12092 C      print *,sinphi,sinthet
12093       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12094      &                    /VSolvSphere_div
12095 C     &                    *wshield
12096 C now the gradient...
12097       do j=1,3
12098       grad_shield(j,i)=grad_shield(j,i)
12099 C gradient po skalowaniu
12100      &                +(sh_frac_dist_grad(j)*VofOverlap
12101 C  gradient po costhet
12102      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12103      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12104      &       sinphi/sinthet*costhet*costhet_grad(j)
12105      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12106      & )*wshield
12107 C grad_shield_side is Cbeta sidechain gradient
12108       grad_shield_side(j,ishield_list(i),i)=
12109      &        (sh_frac_dist_grad(j)*-2.0d0
12110      &        *VofOverlap
12111      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12112      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12113      &       sinphi/sinthet*costhet*costhet_grad(j)
12114      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12115      &       )*wshield
12116
12117        grad_shield_loc(j,ishield_list(i),i)=
12118      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12119      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12120      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12121      &        ))
12122      &        *wshield
12123       enddo
12124       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12125       enddo
12126       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12127 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12128       enddo
12129       return
12130       end
12131 C-----------------------------------------------------------------------
12132 C-----------------------------------------------------------
12133 C This subroutine is to mimic the histone like structure but as well can be
12134 C utilizet to nanostructures (infinit) small modification has to be used to
12135 C make it finite (z gradient at the ends has to be changes as well as the x,y
12136 C gradient has to be modified at the ends
12137 C The energy function is Kihara potential
12138 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12139 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12140 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12141 C simple Kihara potential
12142       subroutine calctube(Etube)
12143        implicit real*8 (a-h,o-z)
12144       include 'DIMENSIONS'
12145       include 'COMMON.GEO'
12146       include 'COMMON.VAR'
12147       include 'COMMON.LOCAL'
12148       include 'COMMON.CHAIN'
12149       include 'COMMON.DERIV'
12150       include 'COMMON.NAMES'
12151       include 'COMMON.INTERACT'
12152       include 'COMMON.IOUNITS'
12153       include 'COMMON.CALC'
12154       include 'COMMON.CONTROL'
12155       include 'COMMON.SPLITELE'
12156       include 'COMMON.SBRIDGE'
12157       double precision tub_r,vectube(3),enetube(maxres*2)
12158       Etube=0.0d0
12159       do i=itube_start,itube_end
12160         enetube(i)=0.0d0
12161         enetube(i+nres)=0.0d0
12162       enddo
12163 C first we calculate the distance from tube center
12164 C first sugare-phosphate group for NARES this would be peptide group
12165 C for UNRES
12166        do i=itube_start,itube_end
12167 C lets ommit dummy atoms for now
12168        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12169 C now calculate distance from center of tube and direction vectors
12170       xmin=boxxsize
12171       ymin=boxysize
12172         do j=-1,1
12173          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12174          vectube(1)=vectube(1)+boxxsize*j
12175          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12176          vectube(2)=vectube(2)+boxysize*j
12177
12178          xminact=abs(vectube(1)-tubecenter(1))
12179          yminact=abs(vectube(2)-tubecenter(2))
12180            if (xmin.gt.xminact) then
12181             xmin=xminact
12182             xtemp=vectube(1)
12183            endif
12184            if (ymin.gt.yminact) then
12185              ymin=yminact
12186              ytemp=vectube(2)
12187             endif
12188          enddo
12189       vectube(1)=xtemp
12190       vectube(2)=ytemp
12191       vectube(1)=vectube(1)-tubecenter(1)
12192       vectube(2)=vectube(2)-tubecenter(2)
12193
12194 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12195 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12196
12197 C as the tube is infinity we do not calculate the Z-vector use of Z
12198 C as chosen axis
12199       vectube(3)=0.0d0
12200 C now calculte the distance
12201        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12202 C now normalize vector
12203       vectube(1)=vectube(1)/tub_r
12204       vectube(2)=vectube(2)/tub_r
12205 C calculte rdiffrence between r and r0
12206       rdiff=tub_r-tubeR0
12207 C and its 6 power
12208       rdiff6=rdiff**6.0d0
12209 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12210        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12211 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12212 C       print *,rdiff,rdiff6,pep_aa_tube
12213 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12214 C now we calculate gradient
12215        fac=(-12.0d0*pep_aa_tube/rdiff6-
12216      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12217 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12218 C     &rdiff,fac
12219
12220 C now direction of gg_tube vector
12221         do j=1,3
12222         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12223         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12224         enddo
12225         enddo
12226 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12227 C        print *,gg_tube(1,0),"TU"
12228
12229
12230        do i=itube_start,itube_end
12231 C Lets not jump over memory as we use many times iti
12232          iti=itype(i)
12233 C lets ommit dummy atoms for now
12234          if ((iti.eq.ntyp1)
12235 C in UNRES uncomment the line below as GLY has no side-chain...
12236 C      .or.(iti.eq.10)
12237      &   ) cycle
12238       xmin=boxxsize
12239       ymin=boxysize
12240         do j=-1,1
12241          vectube(1)=mod((c(1,i+nres)),boxxsize)
12242          vectube(1)=vectube(1)+boxxsize*j
12243          vectube(2)=mod((c(2,i+nres)),boxysize)
12244          vectube(2)=vectube(2)+boxysize*j
12245
12246          xminact=abs(vectube(1)-tubecenter(1))
12247          yminact=abs(vectube(2)-tubecenter(2))
12248            if (xmin.gt.xminact) then
12249             xmin=xminact
12250             xtemp=vectube(1)
12251            endif
12252            if (ymin.gt.yminact) then
12253              ymin=yminact
12254              ytemp=vectube(2)
12255             endif
12256          enddo
12257       vectube(1)=xtemp
12258       vectube(2)=ytemp
12259 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12260 C     &     tubecenter(2)
12261       vectube(1)=vectube(1)-tubecenter(1)
12262       vectube(2)=vectube(2)-tubecenter(2)
12263
12264 C as the tube is infinity we do not calculate the Z-vector use of Z
12265 C as chosen axis
12266       vectube(3)=0.0d0
12267 C now calculte the distance
12268        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12269 C now normalize vector
12270       vectube(1)=vectube(1)/tub_r
12271       vectube(2)=vectube(2)/tub_r
12272
12273 C calculte rdiffrence between r and r0
12274       rdiff=tub_r-tubeR0
12275 C and its 6 power
12276       rdiff6=rdiff**6.0d0
12277 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12278        sc_aa_tube=sc_aa_tube_par(iti)
12279        sc_bb_tube=sc_bb_tube_par(iti)
12280        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12281 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12282 C now we calculate gradient
12283        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12284      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12285 C now direction of gg_tube vector
12286          do j=1,3
12287           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12288           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12289          enddo
12290         enddo
12291         do i=itube_start,itube_end
12292           Etube=Etube+enetube(i)+enetube(i+nres)
12293         enddo
12294 C        print *,"ETUBE", etube
12295         return
12296         end
12297 C TO DO 1) add to total energy
12298 C       2) add to gradient summation
12299 C       3) add reading parameters (AND of course oppening of PARAM file)
12300 C       4) add reading the center of tube
12301 C       5) add COMMONs
12302 C       6) add to zerograd
12303
12304 C-----------------------------------------------------------------------
12305 C-----------------------------------------------------------
12306 C This subroutine is to mimic the histone like structure but as well can be
12307 C utilizet to nanostructures (infinit) small modification has to be used to
12308 C make it finite (z gradient at the ends has to be changes as well as the x,y
12309 C gradient has to be modified at the ends
12310 C The energy function is Kihara potential
12311 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12312 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12313 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12314 C simple Kihara potential
12315       subroutine calctube2(Etube)
12316        implicit real*8 (a-h,o-z)
12317       include 'DIMENSIONS'
12318       include 'COMMON.GEO'
12319       include 'COMMON.VAR'
12320       include 'COMMON.LOCAL'
12321       include 'COMMON.CHAIN'
12322       include 'COMMON.DERIV'
12323       include 'COMMON.NAMES'
12324       include 'COMMON.INTERACT'
12325       include 'COMMON.IOUNITS'
12326       include 'COMMON.CALC'
12327       include 'COMMON.CONTROL'
12328       include 'COMMON.SPLITELE'
12329       include 'COMMON.SBRIDGE'
12330       double precision tub_r,vectube(3),enetube(maxres*2)
12331       Etube=0.0d0
12332       do i=itube_start,itube_end
12333         enetube(i)=0.0d0
12334         enetube(i+nres)=0.0d0
12335       enddo
12336 C first we calculate the distance from tube center
12337 C first sugare-phosphate group for NARES this would be peptide group
12338 C for UNRES
12339        do i=itube_start,itube_end
12340 C lets ommit dummy atoms for now
12341
12342        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12343 C now calculate distance from center of tube and direction vectors
12344 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12345 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12346 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12347 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12348       xmin=boxxsize
12349       ymin=boxysize
12350         do j=-1,1
12351          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12352          vectube(1)=vectube(1)+boxxsize*j
12353          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12354          vectube(2)=vectube(2)+boxysize*j
12355
12356          xminact=abs(vectube(1)-tubecenter(1))
12357          yminact=abs(vectube(2)-tubecenter(2))
12358            if (xmin.gt.xminact) then
12359             xmin=xminact
12360             xtemp=vectube(1)
12361            endif
12362            if (ymin.gt.yminact) then
12363              ymin=yminact
12364              ytemp=vectube(2)
12365             endif
12366          enddo
12367       vectube(1)=xtemp
12368       vectube(2)=ytemp
12369       vectube(1)=vectube(1)-tubecenter(1)
12370       vectube(2)=vectube(2)-tubecenter(2)
12371
12372 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12373 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12374
12375 C as the tube is infinity we do not calculate the Z-vector use of Z
12376 C as chosen axis
12377       vectube(3)=0.0d0
12378 C now calculte the distance
12379        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12380 C now normalize vector
12381       vectube(1)=vectube(1)/tub_r
12382       vectube(2)=vectube(2)/tub_r
12383 C calculte rdiffrence between r and r0
12384       rdiff=tub_r-tubeR0
12385 C and its 6 power
12386       rdiff6=rdiff**6.0d0
12387 C THIS FRAGMENT MAKES TUBE FINITE
12388         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12389         if (positi.le.0) positi=positi+boxzsize
12390 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12391 c for each residue check if it is in lipid or lipid water border area
12392 C       respos=mod(c(3,i+nres),boxzsize)
12393        print *,positi,bordtubebot,buftubebot,bordtubetop
12394        if ((positi.gt.bordtubebot)
12395      & .and.(positi.lt.bordtubetop)) then
12396 C the energy transfer exist
12397         if (positi.lt.buftubebot) then
12398          fracinbuf=1.0d0-
12399      &     ((positi-bordtubebot)/tubebufthick)
12400 C lipbufthick is thickenes of lipid buffore
12401          sstube=sscalelip(fracinbuf)
12402          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12403          print *,ssgradtube, sstube,tubetranene(itype(i))
12404          enetube(i)=enetube(i)+sstube*tubetranenepep
12405 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12406 C     &+ssgradtube*tubetranene(itype(i))
12407 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12408 C     &+ssgradtube*tubetranene(itype(i))
12409 C         print *,"doing sccale for lower part"
12410         elseif (positi.gt.buftubetop) then
12411          fracinbuf=1.0d0-
12412      &((bordtubetop-positi)/tubebufthick)
12413          sstube=sscalelip(fracinbuf)
12414          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12415          enetube(i)=enetube(i)+sstube*tubetranenepep
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 sscalefor top part",sslip,fracinbuf
12421         else
12422          sstube=1.0d0
12423          ssgradtube=0.0d0
12424          enetube(i)=enetube(i)+sstube*tubetranenepep
12425 C         print *,"I am in true lipid"
12426         endif
12427         else
12428 C          sstube=0.0d0
12429 C          ssgradtube=0.0d0
12430         cycle
12431         endif ! if in lipid or buffor
12432
12433 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12434        enetube(i)=enetube(i)+sstube*
12435      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
12436 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12437 C       print *,rdiff,rdiff6,pep_aa_tube
12438 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12439 C now we calculate gradient
12440        fac=(-12.0d0*pep_aa_tube/rdiff6-
12441      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
12442 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12443 C     &rdiff,fac
12444
12445 C now direction of gg_tube vector
12446         do j=1,3
12447         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12448         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12449         enddo
12450          gg_tube(3,i)=gg_tube(3,i)
12451      &+ssgradtube*enetube(i)/sstube/2.0d0
12452          gg_tube(3,i-1)= gg_tube(3,i-1)
12453      &+ssgradtube*enetube(i)/sstube/2.0d0
12454
12455         enddo
12456 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12457 C        print *,gg_tube(1,0),"TU"
12458         do i=itube_start,itube_end
12459 C Lets not jump over memory as we use many times iti
12460          iti=itype(i)
12461 C lets ommit dummy atoms for now
12462          if ((iti.eq.ntyp1)
12463 C in UNRES uncomment the line below as GLY has no side-chain...
12464      &      .or.(iti.eq.10)
12465      &   ) cycle
12466           vectube(1)=c(1,i+nres)
12467           vectube(1)=mod(vectube(1),boxxsize)
12468           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12469           vectube(2)=c(2,i+nres)
12470           vectube(2)=mod(vectube(2),boxysize)
12471           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12472
12473       vectube(1)=vectube(1)-tubecenter(1)
12474       vectube(2)=vectube(2)-tubecenter(2)
12475 C THIS FRAGMENT MAKES TUBE FINITE
12476         positi=(mod(c(3,i+nres),boxzsize))
12477         if (positi.le.0) positi=positi+boxzsize
12478 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12479 c for each residue check if it is in lipid or lipid water border area
12480 C       respos=mod(c(3,i+nres),boxzsize)
12481        print *,positi,bordtubebot,buftubebot,bordtubetop
12482        if ((positi.gt.bordtubebot)
12483      & .and.(positi.lt.bordtubetop)) then
12484 C the energy transfer exist
12485         if (positi.lt.buftubebot) then
12486          fracinbuf=1.0d0-
12487      &     ((positi-bordtubebot)/tubebufthick)
12488 C lipbufthick is thickenes of lipid buffore
12489          sstube=sscalelip(fracinbuf)
12490          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12491          print *,ssgradtube, sstube,tubetranene(itype(i))
12492          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12493 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12494 C     &+ssgradtube*tubetranene(itype(i))
12495 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12496 C     &+ssgradtube*tubetranene(itype(i))
12497 C         print *,"doing sccale for lower part"
12498         elseif (positi.gt.buftubetop) then
12499          fracinbuf=1.0d0-
12500      &((bordtubetop-positi)/tubebufthick)
12501          sstube=sscalelip(fracinbuf)
12502          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12503          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12504 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12505 C     &+ssgradtube*tubetranene(itype(i))
12506 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12507 C     &+ssgradtube*tubetranene(itype(i))
12508 C          print *, "doing sscalefor top part",sslip,fracinbuf
12509         else
12510          sstube=1.0d0
12511          ssgradtube=0.0d0
12512          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12513 C         print *,"I am in true lipid"
12514         endif
12515         else
12516 C          sstube=0.0d0
12517 C          ssgradtube=0.0d0
12518         cycle
12519         endif ! if in lipid or buffor
12520 CEND OF FINITE FRAGMENT
12521 C as the tube is infinity we do not calculate the Z-vector use of Z
12522 C as chosen axis
12523       vectube(3)=0.0d0
12524 C now calculte the distance
12525        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12526 C now normalize vector
12527       vectube(1)=vectube(1)/tub_r
12528       vectube(2)=vectube(2)/tub_r
12529 C calculte rdiffrence between r and r0
12530       rdiff=tub_r-tubeR0
12531 C and its 6 power
12532       rdiff6=rdiff**6.0d0
12533 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12534        sc_aa_tube=sc_aa_tube_par(iti)
12535        sc_bb_tube=sc_bb_tube_par(iti)
12536        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12537      &                 *sstube+enetube(i+nres)
12538 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12539 C now we calculate gradient
12540        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12541      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12542 C now direction of gg_tube vector
12543          do j=1,3
12544           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12545           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12546          enddo
12547          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12548      &+ssgradtube*enetube(i+nres)/sstube
12549          gg_tube(3,i-1)= gg_tube(3,i-1)
12550      &+ssgradtube*enetube(i+nres)/sstube
12551
12552         enddo
12553         do i=itube_start,itube_end
12554           Etube=Etube+enetube(i)+enetube(i+nres)
12555         enddo
12556 C        print *,"ETUBE", etube
12557         return
12558         end
12559 C TO DO 1) add to total energy
12560 C       2) add to gradient summation
12561 C       3) add reading parameters (AND of course oppening of PARAM file)
12562 C       4) add reading the center of tube
12563 C       5) add COMMONs
12564 C       6) add to zerograd
12565
12566
12567 C#-------------------------------------------------------------------------------
12568 C This subroutine is to mimic the histone like structure but as well can be
12569 C utilizet to nanostructures (infinit) small modification has to be used to
12570 C make it finite (z gradient at the ends has to be changes as well as the x,y
12571 C gradient has to be modified at the ends
12572 C The energy function is Kihara potential
12573 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12574 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12575 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12576 C simple Kihara potential
12577       subroutine calcnano(Etube)
12578        implicit real*8 (a-h,o-z)
12579       include 'DIMENSIONS'
12580       include 'COMMON.GEO'
12581       include 'COMMON.VAR'
12582       include 'COMMON.LOCAL'
12583       include 'COMMON.CHAIN'
12584       include 'COMMON.DERIV'
12585       include 'COMMON.NAMES'
12586       include 'COMMON.INTERACT'
12587       include 'COMMON.IOUNITS'
12588       include 'COMMON.CALC'
12589       include 'COMMON.CONTROL'
12590       include 'COMMON.SPLITELE'
12591       include 'COMMON.SBRIDGE'
12592       double precision tub_r,vectube(3),enetube(maxres*2),
12593      & enecavtube(maxres*2)
12594       Etube=0.0d0
12595       do i=itube_start,itube_end
12596         enetube(i)=0.0d0
12597         enetube(i+nres)=0.0d0
12598       enddo
12599 C first we calculate the distance from tube center
12600 C first sugare-phosphate group for NARES this would be peptide group
12601 C for UNRES
12602        do i=itube_start,itube_end
12603 C lets ommit dummy atoms for now
12604        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12605 C now calculate distance from center of tube and direction vectors
12606       xmin=boxxsize
12607       ymin=boxysize
12608       zmin=boxzsize
12609
12610         do j=-1,1
12611          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12612          vectube(1)=vectube(1)+boxxsize*j
12613          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12614          vectube(2)=vectube(2)+boxysize*j
12615          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12616          vectube(3)=vectube(3)+boxzsize*j
12617
12618
12619          xminact=abs(vectube(1)-tubecenter(1))
12620          yminact=abs(vectube(2)-tubecenter(2))
12621          zminact=abs(vectube(3)-tubecenter(3))
12622
12623            if (xmin.gt.xminact) then
12624             xmin=xminact
12625             xtemp=vectube(1)
12626            endif
12627            if (ymin.gt.yminact) then
12628              ymin=yminact
12629              ytemp=vectube(2)
12630             endif
12631            if (zmin.gt.zminact) then
12632              zmin=zminact
12633              ztemp=vectube(3)
12634             endif
12635          enddo
12636       vectube(1)=xtemp
12637       vectube(2)=ytemp
12638       vectube(3)=ztemp
12639
12640       vectube(1)=vectube(1)-tubecenter(1)
12641       vectube(2)=vectube(2)-tubecenter(2)
12642       vectube(3)=vectube(3)-tubecenter(3)
12643
12644 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12645 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12646 C as the tube is infinity we do not calculate the Z-vector use of Z
12647 C as chosen axis
12648 C      vectube(3)=0.0d0
12649 C now calculte the distance
12650        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12651 C now normalize vector
12652       vectube(1)=vectube(1)/tub_r
12653       vectube(2)=vectube(2)/tub_r
12654       vectube(3)=vectube(3)/tub_r
12655 C calculte rdiffrence between r and r0
12656       rdiff=tub_r-tubeR0
12657 C and its 6 power
12658       rdiff6=rdiff**6.0d0
12659 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12660        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12661 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12662 C       print *,rdiff,rdiff6,pep_aa_tube
12663 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12664 C now we calculate gradient
12665        fac=(-12.0d0*pep_aa_tube/rdiff6-
12666      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12667 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12668 C     &rdiff,fac
12669          if (acavtubpep.eq.0.0d0) then
12670 C go to 667
12671          enecavtube(i)=0.0
12672          faccav=0.0
12673          else
12674          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
12675          enecavtube(i)=
12676      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
12677      &   /denominator
12678          enecavtube(i)=0.0
12679          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
12680      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
12681      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
12682      &   /denominator**2.0d0
12683 C         faccav=0.0
12684 C         fac=fac+faccav
12685 C 667     continue
12686          endif
12687 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
12688 C     &   enecavtube(i),faccav
12689 C         print *,"licz=",
12690 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12691 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
12692
12693 C now direction of gg_tube vector
12694         do j=1,3
12695         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12696         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12697         enddo
12698         enddo
12699
12700        do i=itube_start,itube_end
12701         enecavtube(i)=0.0
12702 C Lets not jump over memory as we use many times iti
12703          iti=itype(i)
12704 C lets ommit dummy atoms for now
12705          if ((iti.eq.ntyp1)
12706 C in UNRES uncomment the line below as GLY has no side-chain...
12707 C      .or.(iti.eq.10)
12708      &   ) cycle
12709       xmin=boxxsize
12710       ymin=boxysize
12711       zmin=boxzsize
12712         do j=-1,1
12713          vectube(1)=mod((c(1,i+nres)),boxxsize)
12714          vectube(1)=vectube(1)+boxxsize*j
12715          vectube(2)=mod((c(2,i+nres)),boxysize)
12716          vectube(2)=vectube(2)+boxysize*j
12717          vectube(3)=mod((c(3,i+nres)),boxzsize)
12718          vectube(3)=vectube(3)+boxzsize*j
12719
12720
12721          xminact=abs(vectube(1)-tubecenter(1))
12722          yminact=abs(vectube(2)-tubecenter(2))
12723          zminact=abs(vectube(3)-tubecenter(3))
12724
12725            if (xmin.gt.xminact) then
12726             xmin=xminact
12727             xtemp=vectube(1)
12728            endif
12729            if (ymin.gt.yminact) then
12730              ymin=yminact
12731              ytemp=vectube(2)
12732             endif
12733            if (zmin.gt.zminact) then
12734              zmin=zminact
12735              ztemp=vectube(3)
12736             endif
12737          enddo
12738       vectube(1)=xtemp
12739       vectube(2)=ytemp
12740       vectube(3)=ztemp
12741
12742 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12743 C     &     tubecenter(2)
12744       vectube(1)=vectube(1)-tubecenter(1)
12745       vectube(2)=vectube(2)-tubecenter(2)
12746       vectube(3)=vectube(3)-tubecenter(3)
12747 C now calculte the distance
12748        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12749 C now normalize vector
12750       vectube(1)=vectube(1)/tub_r
12751       vectube(2)=vectube(2)/tub_r
12752       vectube(3)=vectube(3)/tub_r
12753
12754 C calculte rdiffrence between r and r0
12755       rdiff=tub_r-tubeR0
12756 C and its 6 power
12757       rdiff6=rdiff**6.0d0
12758 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12759        sc_aa_tube=sc_aa_tube_par(iti)
12760        sc_bb_tube=sc_bb_tube_par(iti)
12761        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12762 C       enetube(i+nres)=0.0d0
12763 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12764 C now we calculate gradient
12765        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12766      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12767 C       fac=0.0
12768 C now direction of gg_tube vector
12769 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12770          if (acavtub(iti).eq.0.0d0) then
12771 C go to 667
12772          enecavtube(i+nres)=0.0
12773          faccav=0.0
12774          else
12775          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
12776          enecavtube(i+nres)=
12777      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12778      &   /denominator
12779 C         enecavtube(i)=0.0
12780          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
12781      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
12782      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
12783      &   /denominator**2.0d0
12784 C         faccav=0.0
12785          fac=fac+faccav
12786 C 667     continue
12787          endif
12788 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
12789 C     &   enecavtube(i),faccav
12790 C         print *,"licz=",
12791 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12792 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
12793          do j=1,3
12794           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12795           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12796          enddo
12797         enddo
12798 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12799 C        do i=itube_start,itube_end
12800 C        enecav(i)=0.0
12801 C        iti=itype(i)
12802 C        if (acavtub(iti).eq.0.0) cycle
12803
12804
12805
12806         do i=itube_start,itube_end
12807           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
12808      & +enecavtube(i+nres)
12809         enddo
12810 C        print *,"ETUBE", etube
12811         return
12812         end
12813 C TO DO 1) add to total energy
12814 C       2) add to gradient summation
12815 C       3) add reading parameters (AND of course oppening of PARAM file)
12816 C       4) add reading the center of tube
12817 C       5) add COMMONs
12818 C       6) add to zerograd
12819