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,2f7.3)')
4651      &            'eelloc',i,j,eel_loc_ij,a22*muij(1),a23*muij(2)
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         if (energy_dec) write(iout,'(a9,2i4,f8.3,3i4)') "esccor",i,j,
8227      & esccor,intertyp,
8228      & isccori, isccori1
8229 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8230         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8231         if (lprn)
8232      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8233      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8234      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8235      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8236         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8237        enddo !intertyp
8238       enddo
8239
8240       return
8241       end
8242 c----------------------------------------------------------------------------
8243       subroutine multibody(ecorr)
8244 C This subroutine calculates multi-body contributions to energy following
8245 C the idea of Skolnick et al. If side chains I and J make a contact and
8246 C at the same time side chains I+1 and J+1 make a contact, an extra
8247 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8248       implicit real*8 (a-h,o-z)
8249       include 'DIMENSIONS'
8250       include 'COMMON.IOUNITS'
8251       include 'COMMON.DERIV'
8252       include 'COMMON.INTERACT'
8253       include 'COMMON.CONTACTS'
8254       double precision gx(3),gx1(3)
8255       logical lprn
8256
8257 C Set lprn=.true. for debugging
8258       lprn=.false.
8259
8260       if (lprn) then
8261         write (iout,'(a)') 'Contact function values:'
8262         do i=nnt,nct-2
8263           write (iout,'(i2,20(1x,i2,f10.5))')
8264      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8265         enddo
8266       endif
8267       ecorr=0.0D0
8268       do i=nnt,nct
8269         do j=1,3
8270           gradcorr(j,i)=0.0D0
8271           gradxorr(j,i)=0.0D0
8272         enddo
8273       enddo
8274       do i=nnt,nct-2
8275
8276         DO ISHIFT = 3,4
8277
8278         i1=i+ishift
8279         num_conti=num_cont(i)
8280         num_conti1=num_cont(i1)
8281         do jj=1,num_conti
8282           j=jcont(jj,i)
8283           do kk=1,num_conti1
8284             j1=jcont(kk,i1)
8285             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8286 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8287 cd   &                   ' ishift=',ishift
8288 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8289 C The system gains extra energy.
8290               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8291             endif   ! j1==j+-ishift
8292           enddo     ! kk
8293         enddo       ! jj
8294
8295         ENDDO ! ISHIFT
8296
8297       enddo         ! i
8298       return
8299       end
8300 c------------------------------------------------------------------------------
8301       double precision function esccorr(i,j,k,l,jj,kk)
8302       implicit real*8 (a-h,o-z)
8303       include 'DIMENSIONS'
8304       include 'COMMON.IOUNITS'
8305       include 'COMMON.DERIV'
8306       include 'COMMON.INTERACT'
8307       include 'COMMON.CONTACTS'
8308       include 'COMMON.SHIELD'
8309       double precision gx(3),gx1(3)
8310       logical lprn
8311       lprn=.false.
8312       eij=facont(jj,i)
8313       ekl=facont(kk,k)
8314 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8315 C Calculate the multi-body contribution to energy.
8316 C Calculate multi-body contributions to the gradient.
8317 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8318 cd   & k,l,(gacont(m,kk,k),m=1,3)
8319       do m=1,3
8320         gx(m) =ekl*gacont(m,jj,i)
8321         gx1(m)=eij*gacont(m,kk,k)
8322         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8323         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8324         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8325         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8326       enddo
8327       do m=i,j-1
8328         do ll=1,3
8329           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8330         enddo
8331       enddo
8332       do m=k,l-1
8333         do ll=1,3
8334           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8335         enddo
8336       enddo
8337       esccorr=-eij*ekl
8338       return
8339       end
8340 c------------------------------------------------------------------------------
8341       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8342 C This subroutine calculates multi-body contributions to hydrogen-bonding
8343       implicit real*8 (a-h,o-z)
8344       include 'DIMENSIONS'
8345       include 'COMMON.IOUNITS'
8346 #ifdef MPI
8347       include "mpif.h"
8348       parameter (max_cont=maxconts)
8349       parameter (max_dim=26)
8350       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8351       double precision zapas(max_dim,maxconts,max_fg_procs),
8352      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8353       common /przechowalnia/ zapas
8354       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8355      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8356 #endif
8357       include 'COMMON.SETUP'
8358       include 'COMMON.FFIELD'
8359       include 'COMMON.DERIV'
8360       include 'COMMON.INTERACT'
8361       include 'COMMON.CONTACTS'
8362       include 'COMMON.CONTROL'
8363       include 'COMMON.LOCAL'
8364       double precision gx(3),gx1(3),time00
8365       logical lprn,ldone
8366
8367 C Set lprn=.true. for debugging
8368       lprn=.false.
8369 #ifdef MPI
8370       n_corr=0
8371       n_corr1=0
8372       if (nfgtasks.le.1) goto 30
8373       if (lprn) then
8374         write (iout,'(a)') 'Contact function values before RECEIVE:'
8375         do i=nnt,nct-2
8376           write (iout,'(2i3,50(1x,i2,f5.2))')
8377      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8378      &    j=1,num_cont_hb(i))
8379         enddo
8380       endif
8381       call flush(iout)
8382       do i=1,ntask_cont_from
8383         ncont_recv(i)=0
8384       enddo
8385       do i=1,ntask_cont_to
8386         ncont_sent(i)=0
8387       enddo
8388 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8389 c     & ntask_cont_to
8390 C Make the list of contacts to send to send to other procesors
8391 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8392 c      call flush(iout)
8393       do i=iturn3_start,iturn3_end
8394 c        write (iout,*) "make contact list turn3",i," num_cont",
8395 c     &    num_cont_hb(i)
8396         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8397       enddo
8398       do i=iturn4_start,iturn4_end
8399 c        write (iout,*) "make contact list turn4",i," num_cont",
8400 c     &   num_cont_hb(i)
8401         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8402       enddo
8403       do ii=1,nat_sent
8404         i=iat_sent(ii)
8405 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8406 c     &    num_cont_hb(i)
8407         do j=1,num_cont_hb(i)
8408         do k=1,4
8409           jjc=jcont_hb(j,i)
8410           iproc=iint_sent_local(k,jjc,ii)
8411 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8412           if (iproc.gt.0) then
8413             ncont_sent(iproc)=ncont_sent(iproc)+1
8414             nn=ncont_sent(iproc)
8415             zapas(1,nn,iproc)=i
8416             zapas(2,nn,iproc)=jjc
8417             zapas(3,nn,iproc)=facont_hb(j,i)
8418             zapas(4,nn,iproc)=ees0p(j,i)
8419             zapas(5,nn,iproc)=ees0m(j,i)
8420             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8421             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8422             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8423             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8424             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8425             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8426             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8427             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8428             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8429             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8430             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8431             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8432             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8433             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8434             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8435             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8436             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8437             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8438             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8439             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8440             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8441           endif
8442         enddo
8443         enddo
8444       enddo
8445       if (lprn) then
8446       write (iout,*)
8447      &  "Numbers of contacts to be sent to other processors",
8448      &  (ncont_sent(i),i=1,ntask_cont_to)
8449       write (iout,*) "Contacts sent"
8450       do ii=1,ntask_cont_to
8451         nn=ncont_sent(ii)
8452         iproc=itask_cont_to(ii)
8453         write (iout,*) nn," contacts to processor",iproc,
8454      &   " of CONT_TO_COMM group"
8455         do i=1,nn
8456           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8457         enddo
8458       enddo
8459       call flush(iout)
8460       endif
8461       CorrelType=477
8462       CorrelID=fg_rank+1
8463       CorrelType1=478
8464       CorrelID1=nfgtasks+fg_rank+1
8465       ireq=0
8466 C Receive the numbers of needed contacts from other processors
8467       do ii=1,ntask_cont_from
8468         iproc=itask_cont_from(ii)
8469         ireq=ireq+1
8470         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8471      &    FG_COMM,req(ireq),IERR)
8472       enddo
8473 c      write (iout,*) "IRECV ended"
8474 c      call flush(iout)
8475 C Send the number of contacts needed by other processors
8476       do ii=1,ntask_cont_to
8477         iproc=itask_cont_to(ii)
8478         ireq=ireq+1
8479         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8480      &    FG_COMM,req(ireq),IERR)
8481       enddo
8482 c      write (iout,*) "ISEND ended"
8483 c      write (iout,*) "number of requests (nn)",ireq
8484       call flush(iout)
8485       if (ireq.gt.0)
8486      &  call MPI_Waitall(ireq,req,status_array,ierr)
8487 c      write (iout,*)
8488 c     &  "Numbers of contacts to be received from other processors",
8489 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8490 c      call flush(iout)
8491 C Receive contacts
8492       ireq=0
8493       do ii=1,ntask_cont_from
8494         iproc=itask_cont_from(ii)
8495         nn=ncont_recv(ii)
8496 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8497 c     &   " of CONT_TO_COMM group"
8498         call flush(iout)
8499         if (nn.gt.0) then
8500           ireq=ireq+1
8501           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8502      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8503 c          write (iout,*) "ireq,req",ireq,req(ireq)
8504         endif
8505       enddo
8506 C Send the contacts to processors that need them
8507       do ii=1,ntask_cont_to
8508         iproc=itask_cont_to(ii)
8509         nn=ncont_sent(ii)
8510 c        write (iout,*) nn," contacts to processor",iproc,
8511 c     &   " of CONT_TO_COMM group"
8512         if (nn.gt.0) then
8513           ireq=ireq+1
8514           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8515      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8516 c          write (iout,*) "ireq,req",ireq,req(ireq)
8517 c          do i=1,nn
8518 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8519 c          enddo
8520         endif
8521       enddo
8522 c      write (iout,*) "number of requests (contacts)",ireq
8523 c      write (iout,*) "req",(req(i),i=1,4)
8524 c      call flush(iout)
8525       if (ireq.gt.0)
8526      & call MPI_Waitall(ireq,req,status_array,ierr)
8527       do iii=1,ntask_cont_from
8528         iproc=itask_cont_from(iii)
8529         nn=ncont_recv(iii)
8530         if (lprn) then
8531         write (iout,*) "Received",nn," contacts from processor",iproc,
8532      &   " of CONT_FROM_COMM group"
8533         call flush(iout)
8534         do i=1,nn
8535           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8536         enddo
8537         call flush(iout)
8538         endif
8539         do i=1,nn
8540           ii=zapas_recv(1,i,iii)
8541 c Flag the received contacts to prevent double-counting
8542           jj=-zapas_recv(2,i,iii)
8543 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8544 c          call flush(iout)
8545           nnn=num_cont_hb(ii)+1
8546           num_cont_hb(ii)=nnn
8547           jcont_hb(nnn,ii)=jj
8548           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8549           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8550           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8551           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8552           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8553           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8554           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8555           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8556           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8557           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8558           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8559           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8560           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8561           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8562           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8563           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8564           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8565           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8566           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8567           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8568           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8569           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8570           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8571           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8572         enddo
8573       enddo
8574       call flush(iout)
8575       if (lprn) then
8576         write (iout,'(a)') 'Contact function values after receive:'
8577         do i=nnt,nct-2
8578           write (iout,'(2i3,50(1x,i3,f5.2))')
8579      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8580      &    j=1,num_cont_hb(i))
8581         enddo
8582         call flush(iout)
8583       endif
8584    30 continue
8585 #endif
8586       if (lprn) then
8587         write (iout,'(a)') 'Contact function values:'
8588         do i=nnt,nct-2
8589           write (iout,'(2i3,50(1x,i3,f5.2))')
8590      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8591      &    j=1,num_cont_hb(i))
8592         enddo
8593       endif
8594       ecorr=0.0D0
8595 C Remove the loop below after debugging !!!
8596       do i=nnt,nct
8597         do j=1,3
8598           gradcorr(j,i)=0.0D0
8599           gradxorr(j,i)=0.0D0
8600         enddo
8601       enddo
8602 C Calculate the local-electrostatic correlation terms
8603       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8604         i1=i+1
8605         num_conti=num_cont_hb(i)
8606         num_conti1=num_cont_hb(i+1)
8607         do jj=1,num_conti
8608           j=jcont_hb(jj,i)
8609           jp=iabs(j)
8610           do kk=1,num_conti1
8611             j1=jcont_hb(kk,i1)
8612             jp1=iabs(j1)
8613 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8614 c     &         ' jj=',jj,' kk=',kk
8615             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8616      &          .or. j.lt.0 .and. j1.gt.0) .and.
8617      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8618 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8619 C The system gains extra energy.
8620               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8621               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8622      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8623               n_corr=n_corr+1
8624             else if (j1.eq.j) then
8625 C Contacts I-J and I-(J+1) occur simultaneously.
8626 C The system loses extra energy.
8627 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8628             endif
8629           enddo ! kk
8630           do kk=1,num_conti
8631             j1=jcont_hb(kk,i)
8632 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8633 c    &         ' jj=',jj,' kk=',kk
8634             if (j1.eq.j+1) then
8635 C Contacts I-J and (I+1)-J occur simultaneously.
8636 C The system loses extra energy.
8637 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8638             endif ! j1==j+1
8639           enddo ! kk
8640         enddo ! jj
8641       enddo ! i
8642       return
8643       end
8644 c------------------------------------------------------------------------------
8645       subroutine add_hb_contact(ii,jj,itask)
8646       implicit real*8 (a-h,o-z)
8647       include "DIMENSIONS"
8648       include "COMMON.IOUNITS"
8649       integer max_cont
8650       integer max_dim
8651       parameter (max_cont=maxconts)
8652       parameter (max_dim=26)
8653       include "COMMON.CONTACTS"
8654       double precision zapas(max_dim,maxconts,max_fg_procs),
8655      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8656       common /przechowalnia/ zapas
8657       integer i,j,ii,jj,iproc,itask(4),nn
8658 c      write (iout,*) "itask",itask
8659       do i=1,2
8660         iproc=itask(i)
8661         if (iproc.gt.0) then
8662           do j=1,num_cont_hb(ii)
8663             jjc=jcont_hb(j,ii)
8664 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8665             if (jjc.eq.jj) then
8666               ncont_sent(iproc)=ncont_sent(iproc)+1
8667               nn=ncont_sent(iproc)
8668               zapas(1,nn,iproc)=ii
8669               zapas(2,nn,iproc)=jjc
8670               zapas(3,nn,iproc)=facont_hb(j,ii)
8671               zapas(4,nn,iproc)=ees0p(j,ii)
8672               zapas(5,nn,iproc)=ees0m(j,ii)
8673               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8674               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8675               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8676               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8677               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8678               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8679               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8680               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8681               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8682               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8683               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8684               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8685               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8686               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8687               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8688               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8689               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8690               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8691               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8692               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8693               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8694               exit
8695             endif
8696           enddo
8697         endif
8698       enddo
8699       return
8700       end
8701 c------------------------------------------------------------------------------
8702       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8703      &  n_corr1)
8704 C This subroutine calculates multi-body contributions to hydrogen-bonding
8705       implicit real*8 (a-h,o-z)
8706       include 'DIMENSIONS'
8707       include 'COMMON.IOUNITS'
8708 #ifdef MPI
8709       include "mpif.h"
8710       parameter (max_cont=maxconts)
8711       parameter (max_dim=70)
8712       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8713       double precision zapas(max_dim,maxconts,max_fg_procs),
8714      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8715       common /przechowalnia/ zapas
8716       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8717      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8718 #endif
8719       include 'COMMON.SETUP'
8720       include 'COMMON.FFIELD'
8721       include 'COMMON.DERIV'
8722       include 'COMMON.LOCAL'
8723       include 'COMMON.INTERACT'
8724       include 'COMMON.CONTACTS'
8725       include 'COMMON.CHAIN'
8726       include 'COMMON.CONTROL'
8727       include 'COMMON.SHIELD'
8728       double precision gx(3),gx1(3)
8729       integer num_cont_hb_old(maxres)
8730       logical lprn,ldone
8731       double precision eello4,eello5,eelo6,eello_turn6
8732       external eello4,eello5,eello6,eello_turn6
8733 C Set lprn=.true. for debugging
8734       lprn=.false.
8735       eturn6=0.0d0
8736 #ifdef MPI
8737       do i=1,nres
8738         num_cont_hb_old(i)=num_cont_hb(i)
8739       enddo
8740       n_corr=0
8741       n_corr1=0
8742       if (nfgtasks.le.1) goto 30
8743       if (lprn) then
8744         write (iout,'(a)') 'Contact function values before RECEIVE:'
8745         do i=nnt,nct-2
8746           write (iout,'(2i3,50(1x,i2,f5.2))')
8747      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8748      &    j=1,num_cont_hb(i))
8749         enddo
8750       endif
8751       call flush(iout)
8752       do i=1,ntask_cont_from
8753         ncont_recv(i)=0
8754       enddo
8755       do i=1,ntask_cont_to
8756         ncont_sent(i)=0
8757       enddo
8758 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8759 c     & ntask_cont_to
8760 C Make the list of contacts to send to send to other procesors
8761       do i=iturn3_start,iturn3_end
8762 c        write (iout,*) "make contact list turn3",i," num_cont",
8763 c     &    num_cont_hb(i)
8764         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8765       enddo
8766       do i=iturn4_start,iturn4_end
8767 c        write (iout,*) "make contact list turn4",i," num_cont",
8768 c     &   num_cont_hb(i)
8769         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8770       enddo
8771       do ii=1,nat_sent
8772         i=iat_sent(ii)
8773 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8774 c     &    num_cont_hb(i)
8775         do j=1,num_cont_hb(i)
8776         do k=1,4
8777           jjc=jcont_hb(j,i)
8778           iproc=iint_sent_local(k,jjc,ii)
8779 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8780           if (iproc.ne.0) then
8781             ncont_sent(iproc)=ncont_sent(iproc)+1
8782             nn=ncont_sent(iproc)
8783             zapas(1,nn,iproc)=i
8784             zapas(2,nn,iproc)=jjc
8785             zapas(3,nn,iproc)=d_cont(j,i)
8786             ind=3
8787             do kk=1,3
8788               ind=ind+1
8789               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8790             enddo
8791             do kk=1,2
8792               do ll=1,2
8793                 ind=ind+1
8794                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8795               enddo
8796             enddo
8797             do jj=1,5
8798               do kk=1,3
8799                 do ll=1,2
8800                   do mm=1,2
8801                     ind=ind+1
8802                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8803                   enddo
8804                 enddo
8805               enddo
8806             enddo
8807           endif
8808         enddo
8809         enddo
8810       enddo
8811       if (lprn) then
8812       write (iout,*)
8813      &  "Numbers of contacts to be sent to other processors",
8814      &  (ncont_sent(i),i=1,ntask_cont_to)
8815       write (iout,*) "Contacts sent"
8816       do ii=1,ntask_cont_to
8817         nn=ncont_sent(ii)
8818         iproc=itask_cont_to(ii)
8819         write (iout,*) nn," contacts to processor",iproc,
8820      &   " of CONT_TO_COMM group"
8821         do i=1,nn
8822           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8823         enddo
8824       enddo
8825       call flush(iout)
8826       endif
8827       CorrelType=477
8828       CorrelID=fg_rank+1
8829       CorrelType1=478
8830       CorrelID1=nfgtasks+fg_rank+1
8831       ireq=0
8832 C Receive the numbers of needed contacts from other processors
8833       do ii=1,ntask_cont_from
8834         iproc=itask_cont_from(ii)
8835         ireq=ireq+1
8836         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8837      &    FG_COMM,req(ireq),IERR)
8838       enddo
8839 c      write (iout,*) "IRECV ended"
8840 c      call flush(iout)
8841 C Send the number of contacts needed by other processors
8842       do ii=1,ntask_cont_to
8843         iproc=itask_cont_to(ii)
8844         ireq=ireq+1
8845         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8846      &    FG_COMM,req(ireq),IERR)
8847       enddo
8848 c      write (iout,*) "ISEND ended"
8849 c      write (iout,*) "number of requests (nn)",ireq
8850       call flush(iout)
8851       if (ireq.gt.0)
8852      &  call MPI_Waitall(ireq,req,status_array,ierr)
8853 c      write (iout,*)
8854 c     &  "Numbers of contacts to be received from other processors",
8855 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8856 c      call flush(iout)
8857 C Receive contacts
8858       ireq=0
8859       do ii=1,ntask_cont_from
8860         iproc=itask_cont_from(ii)
8861         nn=ncont_recv(ii)
8862 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8863 c     &   " of CONT_TO_COMM group"
8864         call flush(iout)
8865         if (nn.gt.0) then
8866           ireq=ireq+1
8867           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8868      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8869 c          write (iout,*) "ireq,req",ireq,req(ireq)
8870         endif
8871       enddo
8872 C Send the contacts to processors that need them
8873       do ii=1,ntask_cont_to
8874         iproc=itask_cont_to(ii)
8875         nn=ncont_sent(ii)
8876 c        write (iout,*) nn," contacts to processor",iproc,
8877 c     &   " of CONT_TO_COMM group"
8878         if (nn.gt.0) then
8879           ireq=ireq+1
8880           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8881      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8882 c          write (iout,*) "ireq,req",ireq,req(ireq)
8883 c          do i=1,nn
8884 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8885 c          enddo
8886         endif
8887       enddo
8888 c      write (iout,*) "number of requests (contacts)",ireq
8889 c      write (iout,*) "req",(req(i),i=1,4)
8890 c      call flush(iout)
8891       if (ireq.gt.0)
8892      & call MPI_Waitall(ireq,req,status_array,ierr)
8893       do iii=1,ntask_cont_from
8894         iproc=itask_cont_from(iii)
8895         nn=ncont_recv(iii)
8896         if (lprn) then
8897         write (iout,*) "Received",nn," contacts from processor",iproc,
8898      &   " of CONT_FROM_COMM group"
8899         call flush(iout)
8900         do i=1,nn
8901           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8902         enddo
8903         call flush(iout)
8904         endif
8905         do i=1,nn
8906           ii=zapas_recv(1,i,iii)
8907 c Flag the received contacts to prevent double-counting
8908           jj=-zapas_recv(2,i,iii)
8909 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8910 c          call flush(iout)
8911           nnn=num_cont_hb(ii)+1
8912           num_cont_hb(ii)=nnn
8913           jcont_hb(nnn,ii)=jj
8914           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8915           ind=3
8916           do kk=1,3
8917             ind=ind+1
8918             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8919           enddo
8920           do kk=1,2
8921             do ll=1,2
8922               ind=ind+1
8923               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8924             enddo
8925           enddo
8926           do jj=1,5
8927             do kk=1,3
8928               do ll=1,2
8929                 do mm=1,2
8930                   ind=ind+1
8931                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8932                 enddo
8933               enddo
8934             enddo
8935           enddo
8936         enddo
8937       enddo
8938       call flush(iout)
8939       if (lprn) then
8940         write (iout,'(a)') 'Contact function values after receive:'
8941         do i=nnt,nct-2
8942           write (iout,'(2i3,50(1x,i3,5f6.3))')
8943      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8944      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8945         enddo
8946         call flush(iout)
8947       endif
8948    30 continue
8949 #endif
8950       if (lprn) then
8951         write (iout,'(a)') 'Contact function values:'
8952         do i=nnt,nct-2
8953           write (iout,'(2i3,50(1x,i2,5f6.3))')
8954      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8955      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8956         enddo
8957       endif
8958       ecorr=0.0D0
8959       ecorr5=0.0d0
8960       ecorr6=0.0d0
8961 C Remove the loop below after debugging !!!
8962       do i=nnt,nct
8963         do j=1,3
8964           gradcorr(j,i)=0.0D0
8965           gradxorr(j,i)=0.0D0
8966         enddo
8967       enddo
8968 C Calculate the dipole-dipole interaction energies
8969       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8970       do i=iatel_s,iatel_e+1
8971         num_conti=num_cont_hb(i)
8972         do jj=1,num_conti
8973           j=jcont_hb(jj,i)
8974 #ifdef MOMENT
8975           call dipole(i,j,jj)
8976 #endif
8977         enddo
8978       enddo
8979       endif
8980 C Calculate the local-electrostatic correlation terms
8981 c                write (iout,*) "gradcorr5 in eello5 before loop"
8982 c                do iii=1,nres
8983 c                  write (iout,'(i5,3f10.5)')
8984 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8985 c                enddo
8986       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8987 c        write (iout,*) "corr loop i",i
8988         i1=i+1
8989         num_conti=num_cont_hb(i)
8990         num_conti1=num_cont_hb(i+1)
8991         do jj=1,num_conti
8992           j=jcont_hb(jj,i)
8993           jp=iabs(j)
8994           do kk=1,num_conti1
8995             j1=jcont_hb(kk,i1)
8996             jp1=iabs(j1)
8997 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8998 c     &         ' jj=',jj,' kk=',kk
8999 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9000             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9001      &          .or. j.lt.0 .and. j1.gt.0) .and.
9002      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9003 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9004 C The system gains extra energy.
9005               n_corr=n_corr+1
9006               sqd1=dsqrt(d_cont(jj,i))
9007               sqd2=dsqrt(d_cont(kk,i1))
9008               sred_geom = sqd1*sqd2
9009               IF (sred_geom.lt.cutoff_corr) THEN
9010                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9011      &            ekont,fprimcont)
9012 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9013 cd     &         ' jj=',jj,' kk=',kk
9014                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9015                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9016                 do l=1,3
9017                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9018                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9019                 enddo
9020                 n_corr1=n_corr1+1
9021 cd               write (iout,*) 'sred_geom=',sred_geom,
9022 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9023 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9024 cd               write (iout,*) "g_contij",g_contij
9025 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9026 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9027                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9028                 if (wcorr4.gt.0.0d0)
9029      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9030 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9031                   if (energy_dec.and.wcorr4.gt.0.0d0)
9032      1                 write (iout,'(a6,4i5,0pf7.3)')
9033      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9034 c                write (iout,*) "gradcorr5 before eello5"
9035 c                do iii=1,nres
9036 c                  write (iout,'(i5,3f10.5)')
9037 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9038 c                enddo
9039                 if (wcorr5.gt.0.0d0)
9040      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9041 c                write (iout,*) "gradcorr5 after eello5"
9042 c                do iii=1,nres
9043 c                  write (iout,'(i5,3f10.5)')
9044 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9045 c                enddo
9046                   if (energy_dec.and.wcorr5.gt.0.0d0)
9047      1                 write (iout,'(a6,4i5,0pf7.3)')
9048      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9049 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9050 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9051                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9052      &               .or. wturn6.eq.0.0d0))then
9053 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9054                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9055                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9056      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9057 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9058 cd     &            'ecorr6=',ecorr6
9059 cd                write (iout,'(4e15.5)') sred_geom,
9060 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9061 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9062 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9063                 else if (wturn6.gt.0.0d0
9064      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9065 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9066                   eturn6=eturn6+eello_turn6(i,jj,kk)
9067                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9068      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9069 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9070                 endif
9071               ENDIF
9072 1111          continue
9073             endif
9074           enddo ! kk
9075         enddo ! jj
9076       enddo ! i
9077       do i=1,nres
9078         num_cont_hb(i)=num_cont_hb_old(i)
9079       enddo
9080 c                write (iout,*) "gradcorr5 in eello5"
9081 c                do iii=1,nres
9082 c                  write (iout,'(i5,3f10.5)')
9083 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9084 c                enddo
9085       return
9086       end
9087 c------------------------------------------------------------------------------
9088       subroutine add_hb_contact_eello(ii,jj,itask)
9089       implicit real*8 (a-h,o-z)
9090       include "DIMENSIONS"
9091       include "COMMON.IOUNITS"
9092       integer max_cont
9093       integer max_dim
9094       parameter (max_cont=maxconts)
9095       parameter (max_dim=70)
9096       include "COMMON.CONTACTS"
9097       double precision zapas(max_dim,maxconts,max_fg_procs),
9098      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9099       common /przechowalnia/ zapas
9100       integer i,j,ii,jj,iproc,itask(4),nn
9101 c      write (iout,*) "itask",itask
9102       do i=1,2
9103         iproc=itask(i)
9104         if (iproc.gt.0) then
9105           do j=1,num_cont_hb(ii)
9106             jjc=jcont_hb(j,ii)
9107 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9108             if (jjc.eq.jj) then
9109               ncont_sent(iproc)=ncont_sent(iproc)+1
9110               nn=ncont_sent(iproc)
9111               zapas(1,nn,iproc)=ii
9112               zapas(2,nn,iproc)=jjc
9113               zapas(3,nn,iproc)=d_cont(j,ii)
9114               ind=3
9115               do kk=1,3
9116                 ind=ind+1
9117                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9118               enddo
9119               do kk=1,2
9120                 do ll=1,2
9121                   ind=ind+1
9122                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9123                 enddo
9124               enddo
9125               do jj=1,5
9126                 do kk=1,3
9127                   do ll=1,2
9128                     do mm=1,2
9129                       ind=ind+1
9130                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9131                     enddo
9132                   enddo
9133                 enddo
9134               enddo
9135               exit
9136             endif
9137           enddo
9138         endif
9139       enddo
9140       return
9141       end
9142 c------------------------------------------------------------------------------
9143       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9144       implicit real*8 (a-h,o-z)
9145       include 'DIMENSIONS'
9146       include 'COMMON.IOUNITS'
9147       include 'COMMON.DERIV'
9148       include 'COMMON.INTERACT'
9149       include 'COMMON.CONTACTS'
9150       include 'COMMON.SHIELD'
9151       include 'COMMON.CONTROL'
9152       double precision gx(3),gx1(3)
9153       logical lprn
9154       lprn=.false.
9155 C      print *,"wchodze",fac_shield(i),shield_mode
9156       eij=facont_hb(jj,i)
9157       ekl=facont_hb(kk,k)
9158       ees0pij=ees0p(jj,i)
9159       ees0pkl=ees0p(kk,k)
9160       ees0mij=ees0m(jj,i)
9161       ees0mkl=ees0m(kk,k)
9162       ekont=eij*ekl
9163       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9164 C*
9165 C     & fac_shield(i)**2*fac_shield(j)**2
9166 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9167 C Following 4 lines for diagnostics.
9168 cd    ees0pkl=0.0D0
9169 cd    ees0pij=1.0D0
9170 cd    ees0mkl=0.0D0
9171 cd    ees0mij=1.0D0
9172 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9173 c     & 'Contacts ',i,j,
9174 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9175 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9176 c     & 'gradcorr_long'
9177 C Calculate the multi-body contribution to energy.
9178 C      ecorr=ecorr+ekont*ees
9179 C Calculate multi-body contributions to the gradient.
9180       coeffpees0pij=coeffp*ees0pij
9181       coeffmees0mij=coeffm*ees0mij
9182       coeffpees0pkl=coeffp*ees0pkl
9183       coeffmees0mkl=coeffm*ees0mkl
9184       do ll=1,3
9185 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9186         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9187      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9188      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9189         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9190      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9191      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9192 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9193         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9194      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9195      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9196         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9197      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9198      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9199         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9200      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9201      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9202         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9203         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9204         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9205      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9206      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9207         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9208         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9209 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9210       enddo
9211 c      write (iout,*)
9212 cgrad      do m=i+1,j-1
9213 cgrad        do ll=1,3
9214 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9215 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9216 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9217 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9218 cgrad        enddo
9219 cgrad      enddo
9220 cgrad      do m=k+1,l-1
9221 cgrad        do ll=1,3
9222 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9223 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9224 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9225 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9226 cgrad        enddo
9227 cgrad      enddo
9228 c      write (iout,*) "ehbcorr",ekont*ees
9229 C      print *,ekont,ees,i,k
9230       ehbcorr=ekont*ees
9231 C now gradient over shielding
9232 C      return
9233       if (shield_mode.gt.0) then
9234        j=ees0plist(jj,i)
9235        l=ees0plist(kk,k)
9236 C        print *,i,j,fac_shield(i),fac_shield(j),
9237 C     &fac_shield(k),fac_shield(l)
9238         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9239      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9240           do ilist=1,ishield_list(i)
9241            iresshield=shield_list(ilist,i)
9242            do m=1,3
9243            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9244 C     &      *2.0
9245            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9246      &              rlocshield
9247      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9248             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9249      &+rlocshield
9250            enddo
9251           enddo
9252           do ilist=1,ishield_list(j)
9253            iresshield=shield_list(ilist,j)
9254            do m=1,3
9255            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9256 C     &     *2.0
9257            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9258      &              rlocshield
9259      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9260            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9261      &     +rlocshield
9262            enddo
9263           enddo
9264
9265           do ilist=1,ishield_list(k)
9266            iresshield=shield_list(ilist,k)
9267            do m=1,3
9268            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9269 C     &     *2.0
9270            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9271      &              rlocshield
9272      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9273            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9274      &     +rlocshield
9275            enddo
9276           enddo
9277           do ilist=1,ishield_list(l)
9278            iresshield=shield_list(ilist,l)
9279            do m=1,3
9280            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9281 C     &     *2.0
9282            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9283      &              rlocshield
9284      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9285            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9286      &     +rlocshield
9287            enddo
9288           enddo
9289 C          print *,gshieldx(m,iresshield)
9290           do m=1,3
9291             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9292      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9293             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9294      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9295             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9296      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9297             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9298      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9299
9300             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9301      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9302             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9303      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9304             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9305      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9306             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9307      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9308
9309            enddo
9310       endif
9311       endif
9312       return
9313       end
9314 #ifdef MOMENT
9315 C---------------------------------------------------------------------------
9316       subroutine dipole(i,j,jj)
9317       implicit real*8 (a-h,o-z)
9318       include 'DIMENSIONS'
9319       include 'COMMON.IOUNITS'
9320       include 'COMMON.CHAIN'
9321       include 'COMMON.FFIELD'
9322       include 'COMMON.DERIV'
9323       include 'COMMON.INTERACT'
9324       include 'COMMON.CONTACTS'
9325       include 'COMMON.TORSION'
9326       include 'COMMON.VAR'
9327       include 'COMMON.GEO'
9328       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9329      &  auxmat(2,2)
9330       iti1 = itortyp(itype(i+1))
9331       if (j.lt.nres-1) then
9332         itj1 = itype2loc(itype(j+1))
9333       else
9334         itj1=nloctyp
9335       endif
9336       do iii=1,2
9337         dipi(iii,1)=Ub2(iii,i)
9338         dipderi(iii)=Ub2der(iii,i)
9339         dipi(iii,2)=b1(iii,i+1)
9340         dipj(iii,1)=Ub2(iii,j)
9341         dipderj(iii)=Ub2der(iii,j)
9342         dipj(iii,2)=b1(iii,j+1)
9343       enddo
9344       kkk=0
9345       do iii=1,2
9346         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9347         do jjj=1,2
9348           kkk=kkk+1
9349           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9350         enddo
9351       enddo
9352       do kkk=1,5
9353         do lll=1,3
9354           mmm=0
9355           do iii=1,2
9356             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9357      &        auxvec(1))
9358             do jjj=1,2
9359               mmm=mmm+1
9360               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9361             enddo
9362           enddo
9363         enddo
9364       enddo
9365       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9366       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9367       do iii=1,2
9368         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9369       enddo
9370       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9371       do iii=1,2
9372         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9373       enddo
9374       return
9375       end
9376 #endif
9377 C---------------------------------------------------------------------------
9378       subroutine calc_eello(i,j,k,l,jj,kk)
9379 C
9380 C This subroutine computes matrices and vectors needed to calculate
9381 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9382 C
9383       implicit real*8 (a-h,o-z)
9384       include 'DIMENSIONS'
9385       include 'COMMON.IOUNITS'
9386       include 'COMMON.CHAIN'
9387       include 'COMMON.DERIV'
9388       include 'COMMON.INTERACT'
9389       include 'COMMON.CONTACTS'
9390       include 'COMMON.TORSION'
9391       include 'COMMON.VAR'
9392       include 'COMMON.GEO'
9393       include 'COMMON.FFIELD'
9394       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9395      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9396       logical lprn
9397       common /kutas/ lprn
9398 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9399 cd     & ' jj=',jj,' kk=',kk
9400 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9401 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9402 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9403       do iii=1,2
9404         do jjj=1,2
9405           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9406           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9407         enddo
9408       enddo
9409       call transpose2(aa1(1,1),aa1t(1,1))
9410       call transpose2(aa2(1,1),aa2t(1,1))
9411       do kkk=1,5
9412         do lll=1,3
9413           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9414      &      aa1tder(1,1,lll,kkk))
9415           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9416      &      aa2tder(1,1,lll,kkk))
9417         enddo
9418       enddo
9419       if (l.eq.j+1) then
9420 C parallel orientation of the two CA-CA-CA frames.
9421         if (i.gt.1) then
9422           iti=itype2loc(itype(i))
9423         else
9424           iti=nloctyp
9425         endif
9426         itk1=itype2loc(itype(k+1))
9427         itj=itype2loc(itype(j))
9428         if (l.lt.nres-1) then
9429           itl1=itype2loc(itype(l+1))
9430         else
9431           itl1=nloctyp
9432         endif
9433 C A1 kernel(j+1) A2T
9434 cd        do iii=1,2
9435 cd          write (iout,'(3f10.5,5x,3f10.5)')
9436 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9437 cd        enddo
9438         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9439      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9440      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9441 C Following matrices are needed only for 6-th order cumulants
9442         IF (wcorr6.gt.0.0d0) THEN
9443         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9444      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9445      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9446         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9447      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9448      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9449      &   ADtEAderx(1,1,1,1,1,1))
9450         lprn=.false.
9451         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9452      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9453      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9454      &   ADtEA1derx(1,1,1,1,1,1))
9455         ENDIF
9456 C End 6-th order cumulants
9457 cd        lprn=.false.
9458 cd        if (lprn) then
9459 cd        write (2,*) 'In calc_eello6'
9460 cd        do iii=1,2
9461 cd          write (2,*) 'iii=',iii
9462 cd          do kkk=1,5
9463 cd            write (2,*) 'kkk=',kkk
9464 cd            do jjj=1,2
9465 cd              write (2,'(3(2f10.5),5x)')
9466 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9467 cd            enddo
9468 cd          enddo
9469 cd        enddo
9470 cd        endif
9471         call transpose2(EUgder(1,1,k),auxmat(1,1))
9472         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9473         call transpose2(EUg(1,1,k),auxmat(1,1))
9474         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9475         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9476         do iii=1,2
9477           do kkk=1,5
9478             do lll=1,3
9479               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9480      &          EAEAderx(1,1,lll,kkk,iii,1))
9481             enddo
9482           enddo
9483         enddo
9484 C A1T kernel(i+1) A2
9485         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9486      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9487      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9488 C Following matrices are needed only for 6-th order cumulants
9489         IF (wcorr6.gt.0.0d0) THEN
9490         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9491      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9492      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9493         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9494      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9495      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9496      &   ADtEAderx(1,1,1,1,1,2))
9497         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9498      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9499      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9500      &   ADtEA1derx(1,1,1,1,1,2))
9501         ENDIF
9502 C End 6-th order cumulants
9503         call transpose2(EUgder(1,1,l),auxmat(1,1))
9504         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9505         call transpose2(EUg(1,1,l),auxmat(1,1))
9506         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9507         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9508         do iii=1,2
9509           do kkk=1,5
9510             do lll=1,3
9511               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9512      &          EAEAderx(1,1,lll,kkk,iii,2))
9513             enddo
9514           enddo
9515         enddo
9516 C AEAb1 and AEAb2
9517 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9518 C They are needed only when the fifth- or the sixth-order cumulants are
9519 C indluded.
9520         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9521         call transpose2(AEA(1,1,1),auxmat(1,1))
9522         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9523         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9524         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9525         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9526         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9527         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9528         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9529         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9530         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9531         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9532         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9533         call transpose2(AEA(1,1,2),auxmat(1,1))
9534         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9535         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9536         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9537         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9538         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9539         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9540         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9541         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9542         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9543         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9544         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9545 C Calculate the Cartesian derivatives of the vectors.
9546         do iii=1,2
9547           do kkk=1,5
9548             do lll=1,3
9549               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9550               call matvec2(auxmat(1,1),b1(1,i),
9551      &          AEAb1derx(1,lll,kkk,iii,1,1))
9552               call matvec2(auxmat(1,1),Ub2(1,i),
9553      &          AEAb2derx(1,lll,kkk,iii,1,1))
9554               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9555      &          AEAb1derx(1,lll,kkk,iii,2,1))
9556               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9557      &          AEAb2derx(1,lll,kkk,iii,2,1))
9558               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9559               call matvec2(auxmat(1,1),b1(1,j),
9560      &          AEAb1derx(1,lll,kkk,iii,1,2))
9561               call matvec2(auxmat(1,1),Ub2(1,j),
9562      &          AEAb2derx(1,lll,kkk,iii,1,2))
9563               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9564      &          AEAb1derx(1,lll,kkk,iii,2,2))
9565               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9566      &          AEAb2derx(1,lll,kkk,iii,2,2))
9567             enddo
9568           enddo
9569         enddo
9570         ENDIF
9571 C End vectors
9572       else
9573 C Antiparallel orientation of the two CA-CA-CA frames.
9574         if (i.gt.1) then
9575           iti=itype2loc(itype(i))
9576         else
9577           iti=nloctyp
9578         endif
9579         itk1=itype2loc(itype(k+1))
9580         itl=itype2loc(itype(l))
9581         itj=itype2loc(itype(j))
9582         if (j.lt.nres-1) then
9583           itj1=itype2loc(itype(j+1))
9584         else
9585           itj1=nloctyp
9586         endif
9587 C A2 kernel(j-1)T A1T
9588         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9589      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9590      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9591 C Following matrices are needed only for 6-th order cumulants
9592         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9593      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9594         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9595      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9596      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9597         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9598      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9599      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9600      &   ADtEAderx(1,1,1,1,1,1))
9601         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9602      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9603      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9604      &   ADtEA1derx(1,1,1,1,1,1))
9605         ENDIF
9606 C End 6-th order cumulants
9607         call transpose2(EUgder(1,1,k),auxmat(1,1))
9608         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9609         call transpose2(EUg(1,1,k),auxmat(1,1))
9610         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9611         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9612         do iii=1,2
9613           do kkk=1,5
9614             do lll=1,3
9615               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9616      &          EAEAderx(1,1,lll,kkk,iii,1))
9617             enddo
9618           enddo
9619         enddo
9620 C A2T kernel(i+1)T A1
9621         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9622      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9623      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9624 C Following matrices are needed only for 6-th order cumulants
9625         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9626      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9627         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9628      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9629      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9630         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9631      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9632      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9633      &   ADtEAderx(1,1,1,1,1,2))
9634         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9635      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9636      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9637      &   ADtEA1derx(1,1,1,1,1,2))
9638         ENDIF
9639 C End 6-th order cumulants
9640         call transpose2(EUgder(1,1,j),auxmat(1,1))
9641         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9642         call transpose2(EUg(1,1,j),auxmat(1,1))
9643         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9644         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9645         do iii=1,2
9646           do kkk=1,5
9647             do lll=1,3
9648               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9649      &          EAEAderx(1,1,lll,kkk,iii,2))
9650             enddo
9651           enddo
9652         enddo
9653 C AEAb1 and AEAb2
9654 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9655 C They are needed only when the fifth- or the sixth-order cumulants are
9656 C indluded.
9657         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9658      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9659         call transpose2(AEA(1,1,1),auxmat(1,1))
9660         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9661         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9662         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9663         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9664         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9665         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9666         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9667         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9668         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9669         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9670         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9671         call transpose2(AEA(1,1,2),auxmat(1,1))
9672         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9673         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9674         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9675         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9676         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9677         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9678         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9679         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9680         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9681         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9682         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9683 C Calculate the Cartesian derivatives of the vectors.
9684         do iii=1,2
9685           do kkk=1,5
9686             do lll=1,3
9687               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9688               call matvec2(auxmat(1,1),b1(1,i),
9689      &          AEAb1derx(1,lll,kkk,iii,1,1))
9690               call matvec2(auxmat(1,1),Ub2(1,i),
9691      &          AEAb2derx(1,lll,kkk,iii,1,1))
9692               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9693      &          AEAb1derx(1,lll,kkk,iii,2,1))
9694               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9695      &          AEAb2derx(1,lll,kkk,iii,2,1))
9696               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9697               call matvec2(auxmat(1,1),b1(1,l),
9698      &          AEAb1derx(1,lll,kkk,iii,1,2))
9699               call matvec2(auxmat(1,1),Ub2(1,l),
9700      &          AEAb2derx(1,lll,kkk,iii,1,2))
9701               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9702      &          AEAb1derx(1,lll,kkk,iii,2,2))
9703               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9704      &          AEAb2derx(1,lll,kkk,iii,2,2))
9705             enddo
9706           enddo
9707         enddo
9708         ENDIF
9709 C End vectors
9710       endif
9711       return
9712       end
9713 C---------------------------------------------------------------------------
9714       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9715      &  KK,KKderg,AKA,AKAderg,AKAderx)
9716       implicit none
9717       integer nderg
9718       logical transp
9719       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9720      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9721      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9722       integer iii,kkk,lll
9723       integer jjj,mmm
9724       logical lprn
9725       common /kutas/ lprn
9726       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9727       do iii=1,nderg
9728         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9729      &    AKAderg(1,1,iii))
9730       enddo
9731 cd      if (lprn) write (2,*) 'In kernel'
9732       do kkk=1,5
9733 cd        if (lprn) write (2,*) 'kkk=',kkk
9734         do lll=1,3
9735           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9736      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9737 cd          if (lprn) then
9738 cd            write (2,*) 'lll=',lll
9739 cd            write (2,*) 'iii=1'
9740 cd            do jjj=1,2
9741 cd              write (2,'(3(2f10.5),5x)')
9742 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9743 cd            enddo
9744 cd          endif
9745           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9746      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9747 cd          if (lprn) then
9748 cd            write (2,*) 'lll=',lll
9749 cd            write (2,*) 'iii=2'
9750 cd            do jjj=1,2
9751 cd              write (2,'(3(2f10.5),5x)')
9752 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9753 cd            enddo
9754 cd          endif
9755         enddo
9756       enddo
9757       return
9758       end
9759 C---------------------------------------------------------------------------
9760       double precision function eello4(i,j,k,l,jj,kk)
9761       implicit real*8 (a-h,o-z)
9762       include 'DIMENSIONS'
9763       include 'COMMON.IOUNITS'
9764       include 'COMMON.CHAIN'
9765       include 'COMMON.DERIV'
9766       include 'COMMON.INTERACT'
9767       include 'COMMON.CONTACTS'
9768       include 'COMMON.TORSION'
9769       include 'COMMON.VAR'
9770       include 'COMMON.GEO'
9771       double precision pizda(2,2),ggg1(3),ggg2(3)
9772 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9773 cd        eello4=0.0d0
9774 cd        return
9775 cd      endif
9776 cd      print *,'eello4:',i,j,k,l,jj,kk
9777 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9778 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9779 cold      eij=facont_hb(jj,i)
9780 cold      ekl=facont_hb(kk,k)
9781 cold      ekont=eij*ekl
9782       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9783 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9784       gcorr_loc(k-1)=gcorr_loc(k-1)
9785      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9786       if (l.eq.j+1) then
9787         gcorr_loc(l-1)=gcorr_loc(l-1)
9788      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9789       else
9790         gcorr_loc(j-1)=gcorr_loc(j-1)
9791      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9792       endif
9793       do iii=1,2
9794         do kkk=1,5
9795           do lll=1,3
9796             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9797      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9798 cd            derx(lll,kkk,iii)=0.0d0
9799           enddo
9800         enddo
9801       enddo
9802 cd      gcorr_loc(l-1)=0.0d0
9803 cd      gcorr_loc(j-1)=0.0d0
9804 cd      gcorr_loc(k-1)=0.0d0
9805 cd      eel4=1.0d0
9806 cd      write (iout,*)'Contacts have occurred for peptide groups',
9807 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9808 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9809       if (j.lt.nres-1) then
9810         j1=j+1
9811         j2=j-1
9812       else
9813         j1=j-1
9814         j2=j-2
9815       endif
9816       if (l.lt.nres-1) then
9817         l1=l+1
9818         l2=l-1
9819       else
9820         l1=l-1
9821         l2=l-2
9822       endif
9823       do ll=1,3
9824 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9825 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9826         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9827         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9828 cgrad        ghalf=0.5d0*ggg1(ll)
9829         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9830         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9831         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9832         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9833         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9834         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9835 cgrad        ghalf=0.5d0*ggg2(ll)
9836         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9837         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9838         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9839         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9840         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9841         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9842       enddo
9843 cgrad      do m=i+1,j-1
9844 cgrad        do ll=1,3
9845 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9846 cgrad        enddo
9847 cgrad      enddo
9848 cgrad      do m=k+1,l-1
9849 cgrad        do ll=1,3
9850 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9851 cgrad        enddo
9852 cgrad      enddo
9853 cgrad      do m=i+2,j2
9854 cgrad        do ll=1,3
9855 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9856 cgrad        enddo
9857 cgrad      enddo
9858 cgrad      do m=k+2,l2
9859 cgrad        do ll=1,3
9860 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9861 cgrad        enddo
9862 cgrad      enddo
9863 cd      do iii=1,nres-3
9864 cd        write (2,*) iii,gcorr_loc(iii)
9865 cd      enddo
9866       eello4=ekont*eel4
9867 cd      write (2,*) 'ekont',ekont
9868 cd      write (iout,*) 'eello4',ekont*eel4
9869       return
9870       end
9871 C---------------------------------------------------------------------------
9872       double precision function eello5(i,j,k,l,jj,kk)
9873       implicit real*8 (a-h,o-z)
9874       include 'DIMENSIONS'
9875       include 'COMMON.IOUNITS'
9876       include 'COMMON.CHAIN'
9877       include 'COMMON.DERIV'
9878       include 'COMMON.INTERACT'
9879       include 'COMMON.CONTACTS'
9880       include 'COMMON.TORSION'
9881       include 'COMMON.VAR'
9882       include 'COMMON.GEO'
9883       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9884       double precision ggg1(3),ggg2(3)
9885 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9886 C                                                                              C
9887 C                            Parallel chains                                   C
9888 C                                                                              C
9889 C          o             o                   o             o                   C
9890 C         /l\           / \             \   / \           / \   /              C
9891 C        /   \         /   \             \ /   \         /   \ /               C
9892 C       j| o |l1       | o |              o| o |         | o |o                C
9893 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9894 C      \i/   \         /   \ /             /   \         /   \                 C
9895 C       o    k1             o                                                  C
9896 C         (I)          (II)                (III)          (IV)                 C
9897 C                                                                              C
9898 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9899 C                                                                              C
9900 C                            Antiparallel chains                               C
9901 C                                                                              C
9902 C          o             o                   o             o                   C
9903 C         /j\           / \             \   / \           / \   /              C
9904 C        /   \         /   \             \ /   \         /   \ /               C
9905 C      j1| o |l        | o |              o| o |         | o |o                C
9906 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9907 C      \i/   \         /   \ /             /   \         /   \                 C
9908 C       o     k1            o                                                  C
9909 C         (I)          (II)                (III)          (IV)                 C
9910 C                                                                              C
9911 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9912 C                                                                              C
9913 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9914 C                                                                              C
9915 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9916 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9917 cd        eello5=0.0d0
9918 cd        return
9919 cd      endif
9920 cd      write (iout,*)
9921 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9922 cd     &   ' and',k,l
9923       itk=itype2loc(itype(k))
9924       itl=itype2loc(itype(l))
9925       itj=itype2loc(itype(j))
9926       eello5_1=0.0d0
9927       eello5_2=0.0d0
9928       eello5_3=0.0d0
9929       eello5_4=0.0d0
9930 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9931 cd     &   eel5_3_num,eel5_4_num)
9932       do iii=1,2
9933         do kkk=1,5
9934           do lll=1,3
9935             derx(lll,kkk,iii)=0.0d0
9936           enddo
9937         enddo
9938       enddo
9939 cd      eij=facont_hb(jj,i)
9940 cd      ekl=facont_hb(kk,k)
9941 cd      ekont=eij*ekl
9942 cd      write (iout,*)'Contacts have occurred for peptide groups',
9943 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9944 cd      goto 1111
9945 C Contribution from the graph I.
9946 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9947 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9948       call transpose2(EUg(1,1,k),auxmat(1,1))
9949       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9950       vv(1)=pizda(1,1)-pizda(2,2)
9951       vv(2)=pizda(1,2)+pizda(2,1)
9952       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9953      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9954 C Explicit gradient in virtual-dihedral angles.
9955       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9956      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9957      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9958       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9959       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9960       vv(1)=pizda(1,1)-pizda(2,2)
9961       vv(2)=pizda(1,2)+pizda(2,1)
9962       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9963      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9964      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9965       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9966       vv(1)=pizda(1,1)-pizda(2,2)
9967       vv(2)=pizda(1,2)+pizda(2,1)
9968       if (l.eq.j+1) then
9969         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9970      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9971      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9972       else
9973         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9974      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9975      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9976       endif
9977 C Cartesian gradient
9978       do iii=1,2
9979         do kkk=1,5
9980           do lll=1,3
9981             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9982      &        pizda(1,1))
9983             vv(1)=pizda(1,1)-pizda(2,2)
9984             vv(2)=pizda(1,2)+pizda(2,1)
9985             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9986      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9987      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9988           enddo
9989         enddo
9990       enddo
9991 c      goto 1112
9992 c1111  continue
9993 C Contribution from graph II
9994       call transpose2(EE(1,1,k),auxmat(1,1))
9995       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9996       vv(1)=pizda(1,1)+pizda(2,2)
9997       vv(2)=pizda(2,1)-pizda(1,2)
9998       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9999      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10000 C Explicit gradient in virtual-dihedral angles.
10001       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10002      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10003       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10004       vv(1)=pizda(1,1)+pizda(2,2)
10005       vv(2)=pizda(2,1)-pizda(1,2)
10006       if (l.eq.j+1) then
10007         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10008      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10009      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10010       else
10011         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10012      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10013      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10014       endif
10015 C Cartesian gradient
10016       do iii=1,2
10017         do kkk=1,5
10018           do lll=1,3
10019             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10020      &        pizda(1,1))
10021             vv(1)=pizda(1,1)+pizda(2,2)
10022             vv(2)=pizda(2,1)-pizda(1,2)
10023             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10024      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10025      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10026           enddo
10027         enddo
10028       enddo
10029 cd      goto 1112
10030 cd1111  continue
10031       if (l.eq.j+1) then
10032 cd        goto 1110
10033 C Parallel orientation
10034 C Contribution from graph III
10035         call transpose2(EUg(1,1,l),auxmat(1,1))
10036         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10037         vv(1)=pizda(1,1)-pizda(2,2)
10038         vv(2)=pizda(1,2)+pizda(2,1)
10039         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10040      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10041 C Explicit gradient in virtual-dihedral angles.
10042         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10043      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10044      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10045         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10046         vv(1)=pizda(1,1)-pizda(2,2)
10047         vv(2)=pizda(1,2)+pizda(2,1)
10048         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10049      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10050      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10051         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10052         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10053         vv(1)=pizda(1,1)-pizda(2,2)
10054         vv(2)=pizda(1,2)+pizda(2,1)
10055         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10056      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10057      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10058 C Cartesian gradient
10059         do iii=1,2
10060           do kkk=1,5
10061             do lll=1,3
10062               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10063      &          pizda(1,1))
10064               vv(1)=pizda(1,1)-pizda(2,2)
10065               vv(2)=pizda(1,2)+pizda(2,1)
10066               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10067      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10068      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10069             enddo
10070           enddo
10071         enddo
10072 cd        goto 1112
10073 C Contribution from graph IV
10074 cd1110    continue
10075         call transpose2(EE(1,1,l),auxmat(1,1))
10076         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10077         vv(1)=pizda(1,1)+pizda(2,2)
10078         vv(2)=pizda(2,1)-pizda(1,2)
10079         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10080      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10081 C Explicit gradient in virtual-dihedral angles.
10082         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10083      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10084         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10085         vv(1)=pizda(1,1)+pizda(2,2)
10086         vv(2)=pizda(2,1)-pizda(1,2)
10087         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10088      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10089      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10090 C Cartesian gradient
10091         do iii=1,2
10092           do kkk=1,5
10093             do lll=1,3
10094               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10095      &          pizda(1,1))
10096               vv(1)=pizda(1,1)+pizda(2,2)
10097               vv(2)=pizda(2,1)-pizda(1,2)
10098               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10099      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10100      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10101             enddo
10102           enddo
10103         enddo
10104       else
10105 C Antiparallel orientation
10106 C Contribution from graph III
10107 c        goto 1110
10108         call transpose2(EUg(1,1,j),auxmat(1,1))
10109         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10110         vv(1)=pizda(1,1)-pizda(2,2)
10111         vv(2)=pizda(1,2)+pizda(2,1)
10112         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10113      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10114 C Explicit gradient in virtual-dihedral angles.
10115         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10116      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10117      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10118         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10119         vv(1)=pizda(1,1)-pizda(2,2)
10120         vv(2)=pizda(1,2)+pizda(2,1)
10121         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10122      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10123      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10124         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10125         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10126         vv(1)=pizda(1,1)-pizda(2,2)
10127         vv(2)=pizda(1,2)+pizda(2,1)
10128         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10129      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10130      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10131 C Cartesian gradient
10132         do iii=1,2
10133           do kkk=1,5
10134             do lll=1,3
10135               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10136      &          pizda(1,1))
10137               vv(1)=pizda(1,1)-pizda(2,2)
10138               vv(2)=pizda(1,2)+pizda(2,1)
10139               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10140      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10141      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10142             enddo
10143           enddo
10144         enddo
10145 cd        goto 1112
10146 C Contribution from graph IV
10147 1110    continue
10148         call transpose2(EE(1,1,j),auxmat(1,1))
10149         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10150         vv(1)=pizda(1,1)+pizda(2,2)
10151         vv(2)=pizda(2,1)-pizda(1,2)
10152         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10153      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10154 C Explicit gradient in virtual-dihedral angles.
10155         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10156      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10157         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10158         vv(1)=pizda(1,1)+pizda(2,2)
10159         vv(2)=pizda(2,1)-pizda(1,2)
10160         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10161      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10162      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10163 C Cartesian gradient
10164         do iii=1,2
10165           do kkk=1,5
10166             do lll=1,3
10167               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10168      &          pizda(1,1))
10169               vv(1)=pizda(1,1)+pizda(2,2)
10170               vv(2)=pizda(2,1)-pizda(1,2)
10171               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10172      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10173      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10174             enddo
10175           enddo
10176         enddo
10177       endif
10178 1112  continue
10179       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10180 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10181 cd        write (2,*) 'ijkl',i,j,k,l
10182 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10183 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10184 cd      endif
10185 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10186 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10187 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10188 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10189       if (j.lt.nres-1) then
10190         j1=j+1
10191         j2=j-1
10192       else
10193         j1=j-1
10194         j2=j-2
10195       endif
10196       if (l.lt.nres-1) then
10197         l1=l+1
10198         l2=l-1
10199       else
10200         l1=l-1
10201         l2=l-2
10202       endif
10203 cd      eij=1.0d0
10204 cd      ekl=1.0d0
10205 cd      ekont=1.0d0
10206 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10207 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10208 C        summed up outside the subrouine as for the other subroutines
10209 C        handling long-range interactions. The old code is commented out
10210 C        with "cgrad" to keep track of changes.
10211       do ll=1,3
10212 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10213 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10214         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10215         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10216 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10217 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10218 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10219 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10220 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10221 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10222 c     &   gradcorr5ij,
10223 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10224 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10225 cgrad        ghalf=0.5d0*ggg1(ll)
10226 cd        ghalf=0.0d0
10227         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10228         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10229         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10230         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10231         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10232         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10233 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10234 cgrad        ghalf=0.5d0*ggg2(ll)
10235 cd        ghalf=0.0d0
10236         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10237         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10238         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10239         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10240         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10241         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10242       enddo
10243 cd      goto 1112
10244 cgrad      do m=i+1,j-1
10245 cgrad        do ll=1,3
10246 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10247 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10248 cgrad        enddo
10249 cgrad      enddo
10250 cgrad      do m=k+1,l-1
10251 cgrad        do ll=1,3
10252 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10253 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10254 cgrad        enddo
10255 cgrad      enddo
10256 c1112  continue
10257 cgrad      do m=i+2,j2
10258 cgrad        do ll=1,3
10259 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10260 cgrad        enddo
10261 cgrad      enddo
10262 cgrad      do m=k+2,l2
10263 cgrad        do ll=1,3
10264 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10265 cgrad        enddo
10266 cgrad      enddo
10267 cd      do iii=1,nres-3
10268 cd        write (2,*) iii,g_corr5_loc(iii)
10269 cd      enddo
10270       eello5=ekont*eel5
10271 cd      write (2,*) 'ekont',ekont
10272 cd      write (iout,*) 'eello5',ekont*eel5
10273       return
10274       end
10275 c--------------------------------------------------------------------------
10276       double precision function eello6(i,j,k,l,jj,kk)
10277       implicit real*8 (a-h,o-z)
10278       include 'DIMENSIONS'
10279       include 'COMMON.IOUNITS'
10280       include 'COMMON.CHAIN'
10281       include 'COMMON.DERIV'
10282       include 'COMMON.INTERACT'
10283       include 'COMMON.CONTACTS'
10284       include 'COMMON.TORSION'
10285       include 'COMMON.VAR'
10286       include 'COMMON.GEO'
10287       include 'COMMON.FFIELD'
10288       double precision ggg1(3),ggg2(3)
10289 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10290 cd        eello6=0.0d0
10291 cd        return
10292 cd      endif
10293 cd      write (iout,*)
10294 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10295 cd     &   ' and',k,l
10296       eello6_1=0.0d0
10297       eello6_2=0.0d0
10298       eello6_3=0.0d0
10299       eello6_4=0.0d0
10300       eello6_5=0.0d0
10301       eello6_6=0.0d0
10302 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10303 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10304       do iii=1,2
10305         do kkk=1,5
10306           do lll=1,3
10307             derx(lll,kkk,iii)=0.0d0
10308           enddo
10309         enddo
10310       enddo
10311 cd      eij=facont_hb(jj,i)
10312 cd      ekl=facont_hb(kk,k)
10313 cd      ekont=eij*ekl
10314 cd      eij=1.0d0
10315 cd      ekl=1.0d0
10316 cd      ekont=1.0d0
10317       if (l.eq.j+1) then
10318         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10319         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10320         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10321         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10322         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10323         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10324       else
10325         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10326         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10327         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10328         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10329         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10330           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10331         else
10332           eello6_5=0.0d0
10333         endif
10334         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10335       endif
10336 C If turn contributions are considered, they will be handled separately.
10337       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10338 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10339 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10340 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10341 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10342 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10343 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10344 cd      goto 1112
10345       if (j.lt.nres-1) then
10346         j1=j+1
10347         j2=j-1
10348       else
10349         j1=j-1
10350         j2=j-2
10351       endif
10352       if (l.lt.nres-1) then
10353         l1=l+1
10354         l2=l-1
10355       else
10356         l1=l-1
10357         l2=l-2
10358       endif
10359       do ll=1,3
10360 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10361 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10362 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10363 cgrad        ghalf=0.5d0*ggg1(ll)
10364 cd        ghalf=0.0d0
10365         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10366         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10367         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10368         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10369         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10370         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10371         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10372         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10373 cgrad        ghalf=0.5d0*ggg2(ll)
10374 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10375 cd        ghalf=0.0d0
10376         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10377         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10378         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10379         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10380         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10381         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10382       enddo
10383 cd      goto 1112
10384 cgrad      do m=i+1,j-1
10385 cgrad        do ll=1,3
10386 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10387 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10388 cgrad        enddo
10389 cgrad      enddo
10390 cgrad      do m=k+1,l-1
10391 cgrad        do ll=1,3
10392 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10393 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10394 cgrad        enddo
10395 cgrad      enddo
10396 cgrad1112  continue
10397 cgrad      do m=i+2,j2
10398 cgrad        do ll=1,3
10399 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10400 cgrad        enddo
10401 cgrad      enddo
10402 cgrad      do m=k+2,l2
10403 cgrad        do ll=1,3
10404 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10405 cgrad        enddo
10406 cgrad      enddo
10407 cd      do iii=1,nres-3
10408 cd        write (2,*) iii,g_corr6_loc(iii)
10409 cd      enddo
10410       eello6=ekont*eel6
10411 cd      write (2,*) 'ekont',ekont
10412 cd      write (iout,*) 'eello6',ekont*eel6
10413       return
10414       end
10415 c--------------------------------------------------------------------------
10416       double precision function eello6_graph1(i,j,k,l,imat,swap)
10417       implicit real*8 (a-h,o-z)
10418       include 'DIMENSIONS'
10419       include 'COMMON.IOUNITS'
10420       include 'COMMON.CHAIN'
10421       include 'COMMON.DERIV'
10422       include 'COMMON.INTERACT'
10423       include 'COMMON.CONTACTS'
10424       include 'COMMON.TORSION'
10425       include 'COMMON.VAR'
10426       include 'COMMON.GEO'
10427       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10428       logical swap
10429       logical lprn
10430       common /kutas/ lprn
10431 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10432 C                                                                              C
10433 C      Parallel       Antiparallel                                             C
10434 C                                                                              C
10435 C          o             o                                                     C
10436 C         /l\           /j\                                                    C
10437 C        /   \         /   \                                                   C
10438 C       /| o |         | o |\                                                  C
10439 C     \ j|/k\|  /   \  |/k\|l /                                                C
10440 C      \ /   \ /     \ /   \ /                                                 C
10441 C       o     o       o     o                                                  C
10442 C       i             i                                                        C
10443 C                                                                              C
10444 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10445       itk=itype2loc(itype(k))
10446       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10447       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10448       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10449       call transpose2(EUgC(1,1,k),auxmat(1,1))
10450       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10451       vv1(1)=pizda1(1,1)-pizda1(2,2)
10452       vv1(2)=pizda1(1,2)+pizda1(2,1)
10453       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10454       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10455       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10456       s5=scalar2(vv(1),Dtobr2(1,i))
10457 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10458       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10459       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10460      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10461      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10462      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10463      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10464      & +scalar2(vv(1),Dtobr2der(1,i)))
10465       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10466       vv1(1)=pizda1(1,1)-pizda1(2,2)
10467       vv1(2)=pizda1(1,2)+pizda1(2,1)
10468       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10469       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10470       if (l.eq.j+1) then
10471         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10472      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10473      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10474      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10475      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10476       else
10477         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10478      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10479      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10480      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10481      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10482       endif
10483       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10484       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10485       vv1(1)=pizda1(1,1)-pizda1(2,2)
10486       vv1(2)=pizda1(1,2)+pizda1(2,1)
10487       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10488      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10489      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10490      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10491       do iii=1,2
10492         if (swap) then
10493           ind=3-iii
10494         else
10495           ind=iii
10496         endif
10497         do kkk=1,5
10498           do lll=1,3
10499             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10500             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10501             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10502             call transpose2(EUgC(1,1,k),auxmat(1,1))
10503             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10504      &        pizda1(1,1))
10505             vv1(1)=pizda1(1,1)-pizda1(2,2)
10506             vv1(2)=pizda1(1,2)+pizda1(2,1)
10507             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10508             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10509      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10510             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10511      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10512             s5=scalar2(vv(1),Dtobr2(1,i))
10513             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10514           enddo
10515         enddo
10516       enddo
10517       return
10518       end
10519 c----------------------------------------------------------------------------
10520       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10521       implicit real*8 (a-h,o-z)
10522       include 'DIMENSIONS'
10523       include 'COMMON.IOUNITS'
10524       include 'COMMON.CHAIN'
10525       include 'COMMON.DERIV'
10526       include 'COMMON.INTERACT'
10527       include 'COMMON.CONTACTS'
10528       include 'COMMON.TORSION'
10529       include 'COMMON.VAR'
10530       include 'COMMON.GEO'
10531       logical swap
10532       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10533      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10534       logical lprn
10535       common /kutas/ lprn
10536 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10537 C                                                                              C
10538 C      Parallel       Antiparallel                                             C
10539 C                                                                              C
10540 C          o             o                                                     C
10541 C     \   /l\           /j\   /                                                C
10542 C      \ /   \         /   \ /                                                 C
10543 C       o| o |         | o |o                                                  C
10544 C     \ j|/k\|      \  |/k\|l                                                  C
10545 C      \ /   \       \ /   \                                                   C
10546 C       o             o                                                        C
10547 C       i             i                                                        C
10548 C                                                                              C
10549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10550 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10551 C AL 7/4/01 s1 would occur in the sixth-order moment,
10552 C           but not in a cluster cumulant
10553 #ifdef MOMENT
10554       s1=dip(1,jj,i)*dip(1,kk,k)
10555 #endif
10556       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10557       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10558       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10559       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10560       call transpose2(EUg(1,1,k),auxmat(1,1))
10561       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10562       vv(1)=pizda(1,1)-pizda(2,2)
10563       vv(2)=pizda(1,2)+pizda(2,1)
10564       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10565 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10566 #ifdef MOMENT
10567       eello6_graph2=-(s1+s2+s3+s4)
10568 #else
10569       eello6_graph2=-(s2+s3+s4)
10570 #endif
10571 c      eello6_graph2=-s3
10572 C Derivatives in gamma(i-1)
10573       if (i.gt.1) then
10574 #ifdef MOMENT
10575         s1=dipderg(1,jj,i)*dip(1,kk,k)
10576 #endif
10577         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10578         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10579         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10580         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10581 #ifdef MOMENT
10582         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10583 #else
10584         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10585 #endif
10586 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10587       endif
10588 C Derivatives in gamma(k-1)
10589 #ifdef MOMENT
10590       s1=dip(1,jj,i)*dipderg(1,kk,k)
10591 #endif
10592       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10593       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10594       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10595       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10596       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10597       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10598       vv(1)=pizda(1,1)-pizda(2,2)
10599       vv(2)=pizda(1,2)+pizda(2,1)
10600       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10601 #ifdef MOMENT
10602       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10603 #else
10604       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10605 #endif
10606 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10607 C Derivatives in gamma(j-1) or gamma(l-1)
10608       if (j.gt.1) then
10609 #ifdef MOMENT
10610         s1=dipderg(3,jj,i)*dip(1,kk,k)
10611 #endif
10612         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10613         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10614         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10615         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10616         vv(1)=pizda(1,1)-pizda(2,2)
10617         vv(2)=pizda(1,2)+pizda(2,1)
10618         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10619 #ifdef MOMENT
10620         if (swap) then
10621           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10622         else
10623           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10624         endif
10625 #endif
10626         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10627 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10628       endif
10629 C Derivatives in gamma(l-1) or gamma(j-1)
10630       if (l.gt.1) then
10631 #ifdef MOMENT
10632         s1=dip(1,jj,i)*dipderg(3,kk,k)
10633 #endif
10634         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10635         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10636         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10637         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10638         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10639         vv(1)=pizda(1,1)-pizda(2,2)
10640         vv(2)=pizda(1,2)+pizda(2,1)
10641         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10642 #ifdef MOMENT
10643         if (swap) then
10644           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10645         else
10646           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10647         endif
10648 #endif
10649         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10650 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10651       endif
10652 C Cartesian derivatives.
10653       if (lprn) then
10654         write (2,*) 'In eello6_graph2'
10655         do iii=1,2
10656           write (2,*) 'iii=',iii
10657           do kkk=1,5
10658             write (2,*) 'kkk=',kkk
10659             do jjj=1,2
10660               write (2,'(3(2f10.5),5x)')
10661      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10662             enddo
10663           enddo
10664         enddo
10665       endif
10666       do iii=1,2
10667         do kkk=1,5
10668           do lll=1,3
10669 #ifdef MOMENT
10670             if (iii.eq.1) then
10671               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10672             else
10673               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10674             endif
10675 #endif
10676             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10677      &        auxvec(1))
10678             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10679             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10680      &        auxvec(1))
10681             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10682             call transpose2(EUg(1,1,k),auxmat(1,1))
10683             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10684      &        pizda(1,1))
10685             vv(1)=pizda(1,1)-pizda(2,2)
10686             vv(2)=pizda(1,2)+pizda(2,1)
10687             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10688 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10689 #ifdef MOMENT
10690             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10691 #else
10692             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10693 #endif
10694             if (swap) then
10695               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10696             else
10697               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10698             endif
10699           enddo
10700         enddo
10701       enddo
10702       return
10703       end
10704 c----------------------------------------------------------------------------
10705       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10706       implicit real*8 (a-h,o-z)
10707       include 'DIMENSIONS'
10708       include 'COMMON.IOUNITS'
10709       include 'COMMON.CHAIN'
10710       include 'COMMON.DERIV'
10711       include 'COMMON.INTERACT'
10712       include 'COMMON.CONTACTS'
10713       include 'COMMON.TORSION'
10714       include 'COMMON.VAR'
10715       include 'COMMON.GEO'
10716       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10717       logical swap
10718 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10719 C                                                                              C
10720 C      Parallel       Antiparallel                                             C
10721 C                                                                              C
10722 C          o             o                                                     C
10723 C         /l\   /   \   /j\                                                    C
10724 C        /   \ /     \ /   \                                                   C
10725 C       /| o |o       o| o |\                                                  C
10726 C       j|/k\|  /      |/k\|l /                                                C
10727 C        /   \ /       /   \ /                                                 C
10728 C       /     o       /     o                                                  C
10729 C       i             i                                                        C
10730 C                                                                              C
10731 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10732 C
10733 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10734 C           energy moment and not to the cluster cumulant.
10735       iti=itortyp(itype(i))
10736       if (j.lt.nres-1) then
10737         itj1=itype2loc(itype(j+1))
10738       else
10739         itj1=nloctyp
10740       endif
10741       itk=itype2loc(itype(k))
10742       itk1=itype2loc(itype(k+1))
10743       if (l.lt.nres-1) then
10744         itl1=itype2loc(itype(l+1))
10745       else
10746         itl1=nloctyp
10747       endif
10748 #ifdef MOMENT
10749       s1=dip(4,jj,i)*dip(4,kk,k)
10750 #endif
10751       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10752       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10753       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10754       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10755       call transpose2(EE(1,1,k),auxmat(1,1))
10756       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10757       vv(1)=pizda(1,1)+pizda(2,2)
10758       vv(2)=pizda(2,1)-pizda(1,2)
10759       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10760 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10761 cd     & "sum",-(s2+s3+s4)
10762 #ifdef MOMENT
10763       eello6_graph3=-(s1+s2+s3+s4)
10764 #else
10765       eello6_graph3=-(s2+s3+s4)
10766 #endif
10767 c      eello6_graph3=-s4
10768 C Derivatives in gamma(k-1)
10769       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10770       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10771       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10772       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10773 C Derivatives in gamma(l-1)
10774       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10775       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10776       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10777       vv(1)=pizda(1,1)+pizda(2,2)
10778       vv(2)=pizda(2,1)-pizda(1,2)
10779       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10780       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10781 C Cartesian derivatives.
10782       do iii=1,2
10783         do kkk=1,5
10784           do lll=1,3
10785 #ifdef MOMENT
10786             if (iii.eq.1) then
10787               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10788             else
10789               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10790             endif
10791 #endif
10792             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10793      &        auxvec(1))
10794             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10795             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10796      &        auxvec(1))
10797             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10798             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10799      &        pizda(1,1))
10800             vv(1)=pizda(1,1)+pizda(2,2)
10801             vv(2)=pizda(2,1)-pizda(1,2)
10802             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10803 #ifdef MOMENT
10804             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10805 #else
10806             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10807 #endif
10808             if (swap) then
10809               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10810             else
10811               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10812             endif
10813 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10814           enddo
10815         enddo
10816       enddo
10817       return
10818       end
10819 c----------------------------------------------------------------------------
10820       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10821       implicit real*8 (a-h,o-z)
10822       include 'DIMENSIONS'
10823       include 'COMMON.IOUNITS'
10824       include 'COMMON.CHAIN'
10825       include 'COMMON.DERIV'
10826       include 'COMMON.INTERACT'
10827       include 'COMMON.CONTACTS'
10828       include 'COMMON.TORSION'
10829       include 'COMMON.VAR'
10830       include 'COMMON.GEO'
10831       include 'COMMON.FFIELD'
10832       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10833      & auxvec1(2),auxmat1(2,2)
10834       logical swap
10835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10836 C                                                                              C
10837 C      Parallel       Antiparallel                                             C
10838 C                                                                              C
10839 C          o             o                                                     C
10840 C         /l\   /   \   /j\                                                    C
10841 C        /   \ /     \ /   \                                                   C
10842 C       /| o |o       o| o |\                                                  C
10843 C     \ j|/k\|      \  |/k\|l                                                  C
10844 C      \ /   \       \ /   \                                                   C
10845 C       o     \       o     \                                                  C
10846 C       i             i                                                        C
10847 C                                                                              C
10848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10849 C
10850 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10851 C           energy moment and not to the cluster cumulant.
10852 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10853       iti=itype2loc(itype(i))
10854       itj=itype2loc(itype(j))
10855       if (j.lt.nres-1) then
10856         itj1=itype2loc(itype(j+1))
10857       else
10858         itj1=nloctyp
10859       endif
10860       itk=itype2loc(itype(k))
10861       if (k.lt.nres-1) then
10862         itk1=itype2loc(itype(k+1))
10863       else
10864         itk1=nloctyp
10865       endif
10866       itl=itype2loc(itype(l))
10867       if (l.lt.nres-1) then
10868         itl1=itype2loc(itype(l+1))
10869       else
10870         itl1=nloctyp
10871       endif
10872 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10873 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10874 cd     & ' itl',itl,' itl1',itl1
10875 #ifdef MOMENT
10876       if (imat.eq.1) then
10877         s1=dip(3,jj,i)*dip(3,kk,k)
10878       else
10879         s1=dip(2,jj,j)*dip(2,kk,l)
10880       endif
10881 #endif
10882       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10883       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10884       if (j.eq.l+1) then
10885         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10886         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10887       else
10888         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10889         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10890       endif
10891       call transpose2(EUg(1,1,k),auxmat(1,1))
10892       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10893       vv(1)=pizda(1,1)-pizda(2,2)
10894       vv(2)=pizda(2,1)+pizda(1,2)
10895       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10896 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10897 #ifdef MOMENT
10898       eello6_graph4=-(s1+s2+s3+s4)
10899 #else
10900       eello6_graph4=-(s2+s3+s4)
10901 #endif
10902 C Derivatives in gamma(i-1)
10903       if (i.gt.1) then
10904 #ifdef MOMENT
10905         if (imat.eq.1) then
10906           s1=dipderg(2,jj,i)*dip(3,kk,k)
10907         else
10908           s1=dipderg(4,jj,j)*dip(2,kk,l)
10909         endif
10910 #endif
10911         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10912         if (j.eq.l+1) then
10913           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10914           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10915         else
10916           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10917           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10918         endif
10919         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10920         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10921 cd          write (2,*) 'turn6 derivatives'
10922 #ifdef MOMENT
10923           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10924 #else
10925           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10926 #endif
10927         else
10928 #ifdef MOMENT
10929           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10930 #else
10931           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10932 #endif
10933         endif
10934       endif
10935 C Derivatives in gamma(k-1)
10936 #ifdef MOMENT
10937       if (imat.eq.1) then
10938         s1=dip(3,jj,i)*dipderg(2,kk,k)
10939       else
10940         s1=dip(2,jj,j)*dipderg(4,kk,l)
10941       endif
10942 #endif
10943       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10944       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10945       if (j.eq.l+1) then
10946         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10947         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10948       else
10949         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10950         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10951       endif
10952       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10953       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10954       vv(1)=pizda(1,1)-pizda(2,2)
10955       vv(2)=pizda(2,1)+pizda(1,2)
10956       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10957       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10958 #ifdef MOMENT
10959         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10960 #else
10961         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10962 #endif
10963       else
10964 #ifdef MOMENT
10965         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10966 #else
10967         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10968 #endif
10969       endif
10970 C Derivatives in gamma(j-1) or gamma(l-1)
10971       if (l.eq.j+1 .and. l.gt.1) then
10972         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10973         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10974         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10975         vv(1)=pizda(1,1)-pizda(2,2)
10976         vv(2)=pizda(2,1)+pizda(1,2)
10977         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10978         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10979       else if (j.gt.1) then
10980         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10981         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10982         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10983         vv(1)=pizda(1,1)-pizda(2,2)
10984         vv(2)=pizda(2,1)+pizda(1,2)
10985         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10986         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10987           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10988         else
10989           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10990         endif
10991       endif
10992 C Cartesian derivatives.
10993       do iii=1,2
10994         do kkk=1,5
10995           do lll=1,3
10996 #ifdef MOMENT
10997             if (iii.eq.1) then
10998               if (imat.eq.1) then
10999                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11000               else
11001                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11002               endif
11003             else
11004               if (imat.eq.1) then
11005                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11006               else
11007                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11008               endif
11009             endif
11010 #endif
11011             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11012      &        auxvec(1))
11013             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11014             if (j.eq.l+1) then
11015               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11016      &          b1(1,j+1),auxvec(1))
11017               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11018             else
11019               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11020      &          b1(1,l+1),auxvec(1))
11021               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11022             endif
11023             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11024      &        pizda(1,1))
11025             vv(1)=pizda(1,1)-pizda(2,2)
11026             vv(2)=pizda(2,1)+pizda(1,2)
11027             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11028             if (swap) then
11029               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11030 #ifdef MOMENT
11031                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11032      &             -(s1+s2+s4)
11033 #else
11034                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11035      &             -(s2+s4)
11036 #endif
11037                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11038               else
11039 #ifdef MOMENT
11040                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11041 #else
11042                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11043 #endif
11044                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11045               endif
11046             else
11047 #ifdef MOMENT
11048               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11049 #else
11050               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11051 #endif
11052               if (l.eq.j+1) then
11053                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11054               else
11055                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11056               endif
11057             endif
11058           enddo
11059         enddo
11060       enddo
11061       return
11062       end
11063 c----------------------------------------------------------------------------
11064       double precision function eello_turn6(i,jj,kk)
11065       implicit real*8 (a-h,o-z)
11066       include 'DIMENSIONS'
11067       include 'COMMON.IOUNITS'
11068       include 'COMMON.CHAIN'
11069       include 'COMMON.DERIV'
11070       include 'COMMON.INTERACT'
11071       include 'COMMON.CONTACTS'
11072       include 'COMMON.TORSION'
11073       include 'COMMON.VAR'
11074       include 'COMMON.GEO'
11075       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11076      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11077      &  ggg1(3),ggg2(3)
11078       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11079      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11080 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11081 C           the respective energy moment and not to the cluster cumulant.
11082       s1=0.0d0
11083       s8=0.0d0
11084       s13=0.0d0
11085 c
11086       eello_turn6=0.0d0
11087       j=i+4
11088       k=i+1
11089       l=i+3
11090       iti=itype2loc(itype(i))
11091       itk=itype2loc(itype(k))
11092       itk1=itype2loc(itype(k+1))
11093       itl=itype2loc(itype(l))
11094       itj=itype2loc(itype(j))
11095 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11096 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11097 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11098 cd        eello6=0.0d0
11099 cd        return
11100 cd      endif
11101 cd      write (iout,*)
11102 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11103 cd     &   ' and',k,l
11104 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11105       do iii=1,2
11106         do kkk=1,5
11107           do lll=1,3
11108             derx_turn(lll,kkk,iii)=0.0d0
11109           enddo
11110         enddo
11111       enddo
11112 cd      eij=1.0d0
11113 cd      ekl=1.0d0
11114 cd      ekont=1.0d0
11115       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11116 cd      eello6_5=0.0d0
11117 cd      write (2,*) 'eello6_5',eello6_5
11118 #ifdef MOMENT
11119       call transpose2(AEA(1,1,1),auxmat(1,1))
11120       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11121       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11122       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11123 #endif
11124       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11125       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11126       s2 = scalar2(b1(1,k),vtemp1(1))
11127 #ifdef MOMENT
11128       call transpose2(AEA(1,1,2),atemp(1,1))
11129       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11130       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11131       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11132 #endif
11133       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11134       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11135       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11136 #ifdef MOMENT
11137       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11138       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11139       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11140       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11141       ss13 = scalar2(b1(1,k),vtemp4(1))
11142       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11143 #endif
11144 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11145 c      s1=0.0d0
11146 c      s2=0.0d0
11147 c      s8=0.0d0
11148 c      s12=0.0d0
11149 c      s13=0.0d0
11150       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11151 C Derivatives in gamma(i+2)
11152       s1d =0.0d0
11153       s8d =0.0d0
11154 #ifdef MOMENT
11155       call transpose2(AEA(1,1,1),auxmatd(1,1))
11156       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11157       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11158       call transpose2(AEAderg(1,1,2),atempd(1,1))
11159       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11160       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11161 #endif
11162       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11163       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11164       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11165 c      s1d=0.0d0
11166 c      s2d=0.0d0
11167 c      s8d=0.0d0
11168 c      s12d=0.0d0
11169 c      s13d=0.0d0
11170       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11171 C Derivatives in gamma(i+3)
11172 #ifdef MOMENT
11173       call transpose2(AEA(1,1,1),auxmatd(1,1))
11174       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11175       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11176       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11177 #endif
11178       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11179       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11180       s2d = scalar2(b1(1,k),vtemp1d(1))
11181 #ifdef MOMENT
11182       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11183       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11184 #endif
11185       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11186 #ifdef MOMENT
11187       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11188       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11189       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11190 #endif
11191 c      s1d=0.0d0
11192 c      s2d=0.0d0
11193 c      s8d=0.0d0
11194 c      s12d=0.0d0
11195 c      s13d=0.0d0
11196 #ifdef MOMENT
11197       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11198      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11199 #else
11200       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11201      &               -0.5d0*ekont*(s2d+s12d)
11202 #endif
11203 C Derivatives in gamma(i+4)
11204       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11205       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11206       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11207 #ifdef MOMENT
11208       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11209       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11210       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11211 #endif
11212 c      s1d=0.0d0
11213 c      s2d=0.0d0
11214 c      s8d=0.0d0
11215 C      s12d=0.0d0
11216 c      s13d=0.0d0
11217 #ifdef MOMENT
11218       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11219 #else
11220       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11221 #endif
11222 C Derivatives in gamma(i+5)
11223 #ifdef MOMENT
11224       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11225       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11226       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11227 #endif
11228       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11229       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11230       s2d = scalar2(b1(1,k),vtemp1d(1))
11231 #ifdef MOMENT
11232       call transpose2(AEA(1,1,2),atempd(1,1))
11233       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11234       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11235 #endif
11236       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11237       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11238 #ifdef MOMENT
11239       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11240       ss13d = scalar2(b1(1,k),vtemp4d(1))
11241       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11242 #endif
11243 c      s1d=0.0d0
11244 c      s2d=0.0d0
11245 c      s8d=0.0d0
11246 c      s12d=0.0d0
11247 c      s13d=0.0d0
11248 #ifdef MOMENT
11249       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11250      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11251 #else
11252       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11253      &               -0.5d0*ekont*(s2d+s12d)
11254 #endif
11255 C Cartesian derivatives
11256       do iii=1,2
11257         do kkk=1,5
11258           do lll=1,3
11259 #ifdef MOMENT
11260             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11261             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11262             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11263 #endif
11264             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11265             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11266      &          vtemp1d(1))
11267             s2d = scalar2(b1(1,k),vtemp1d(1))
11268 #ifdef MOMENT
11269             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11270             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11271             s8d = -(atempd(1,1)+atempd(2,2))*
11272      &           scalar2(cc(1,1,itl),vtemp2(1))
11273 #endif
11274             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11275      &           auxmatd(1,1))
11276             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11277             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11278 c      s1d=0.0d0
11279 c      s2d=0.0d0
11280 c      s8d=0.0d0
11281 c      s12d=0.0d0
11282 c      s13d=0.0d0
11283 #ifdef MOMENT
11284             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11285      &        - 0.5d0*(s1d+s2d)
11286 #else
11287             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11288      &        - 0.5d0*s2d
11289 #endif
11290 #ifdef MOMENT
11291             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11292      &        - 0.5d0*(s8d+s12d)
11293 #else
11294             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11295      &        - 0.5d0*s12d
11296 #endif
11297           enddo
11298         enddo
11299       enddo
11300 #ifdef MOMENT
11301       do kkk=1,5
11302         do lll=1,3
11303           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11304      &      achuj_tempd(1,1))
11305           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11306           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11307           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11308           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11309           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11310      &      vtemp4d(1))
11311           ss13d = scalar2(b1(1,k),vtemp4d(1))
11312           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11313           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11314         enddo
11315       enddo
11316 #endif
11317 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11318 cd     &  16*eel_turn6_num
11319 cd      goto 1112
11320       if (j.lt.nres-1) then
11321         j1=j+1
11322         j2=j-1
11323       else
11324         j1=j-1
11325         j2=j-2
11326       endif
11327       if (l.lt.nres-1) then
11328         l1=l+1
11329         l2=l-1
11330       else
11331         l1=l-1
11332         l2=l-2
11333       endif
11334       do ll=1,3
11335 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11336 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11337 cgrad        ghalf=0.5d0*ggg1(ll)
11338 cd        ghalf=0.0d0
11339         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11340         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11341         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11342      &    +ekont*derx_turn(ll,2,1)
11343         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11344         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11345      &    +ekont*derx_turn(ll,4,1)
11346         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11347         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11348         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11349 cgrad        ghalf=0.5d0*ggg2(ll)
11350 cd        ghalf=0.0d0
11351         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11352      &    +ekont*derx_turn(ll,2,2)
11353         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11354         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11355      &    +ekont*derx_turn(ll,4,2)
11356         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11357         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11358         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11359       enddo
11360 cd      goto 1112
11361 cgrad      do m=i+1,j-1
11362 cgrad        do ll=1,3
11363 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11364 cgrad        enddo
11365 cgrad      enddo
11366 cgrad      do m=k+1,l-1
11367 cgrad        do ll=1,3
11368 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11369 cgrad        enddo
11370 cgrad      enddo
11371 cgrad1112  continue
11372 cgrad      do m=i+2,j2
11373 cgrad        do ll=1,3
11374 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11375 cgrad        enddo
11376 cgrad      enddo
11377 cgrad      do m=k+2,l2
11378 cgrad        do ll=1,3
11379 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11380 cgrad        enddo
11381 cgrad      enddo
11382 cd      do iii=1,nres-3
11383 cd        write (2,*) iii,g_corr6_loc(iii)
11384 cd      enddo
11385       eello_turn6=ekont*eel_turn6
11386 cd      write (2,*) 'ekont',ekont
11387 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11388       return
11389       end
11390
11391 C-----------------------------------------------------------------------------
11392       double precision function scalar(u,v)
11393 !DIR$ INLINEALWAYS scalar
11394 #ifndef OSF
11395 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11396 #endif
11397       implicit none
11398       double precision u(3),v(3)
11399 cd      double precision sc
11400 cd      integer i
11401 cd      sc=0.0d0
11402 cd      do i=1,3
11403 cd        sc=sc+u(i)*v(i)
11404 cd      enddo
11405 cd      scalar=sc
11406
11407       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11408       return
11409       end
11410 crc-------------------------------------------------
11411       SUBROUTINE MATVEC2(A1,V1,V2)
11412 !DIR$ INLINEALWAYS MATVEC2
11413 #ifndef OSF
11414 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11415 #endif
11416       implicit real*8 (a-h,o-z)
11417       include 'DIMENSIONS'
11418       DIMENSION A1(2,2),V1(2),V2(2)
11419 c      DO 1 I=1,2
11420 c        VI=0.0
11421 c        DO 3 K=1,2
11422 c    3     VI=VI+A1(I,K)*V1(K)
11423 c        Vaux(I)=VI
11424 c    1 CONTINUE
11425
11426       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11427       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11428
11429       v2(1)=vaux1
11430       v2(2)=vaux2
11431       END
11432 C---------------------------------------
11433       SUBROUTINE MATMAT2(A1,A2,A3)
11434 #ifndef OSF
11435 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11436 #endif
11437       implicit real*8 (a-h,o-z)
11438       include 'DIMENSIONS'
11439       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11440 c      DIMENSION AI3(2,2)
11441 c        DO  J=1,2
11442 c          A3IJ=0.0
11443 c          DO K=1,2
11444 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11445 c          enddo
11446 c          A3(I,J)=A3IJ
11447 c       enddo
11448 c      enddo
11449
11450       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11451       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11452       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11453       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11454
11455       A3(1,1)=AI3_11
11456       A3(2,1)=AI3_21
11457       A3(1,2)=AI3_12
11458       A3(2,2)=AI3_22
11459       END
11460
11461 c-------------------------------------------------------------------------
11462       double precision function scalar2(u,v)
11463 !DIR$ INLINEALWAYS scalar2
11464       implicit none
11465       double precision u(2),v(2)
11466       double precision sc
11467       integer i
11468       scalar2=u(1)*v(1)+u(2)*v(2)
11469       return
11470       end
11471
11472 C-----------------------------------------------------------------------------
11473
11474       subroutine transpose2(a,at)
11475 !DIR$ INLINEALWAYS transpose2
11476 #ifndef OSF
11477 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11478 #endif
11479       implicit none
11480       double precision a(2,2),at(2,2)
11481       at(1,1)=a(1,1)
11482       at(1,2)=a(2,1)
11483       at(2,1)=a(1,2)
11484       at(2,2)=a(2,2)
11485       return
11486       end
11487 c--------------------------------------------------------------------------
11488       subroutine transpose(n,a,at)
11489       implicit none
11490       integer n,i,j
11491       double precision a(n,n),at(n,n)
11492       do i=1,n
11493         do j=1,n
11494           at(j,i)=a(i,j)
11495         enddo
11496       enddo
11497       return
11498       end
11499 C---------------------------------------------------------------------------
11500       subroutine prodmat3(a1,a2,kk,transp,prod)
11501 !DIR$ INLINEALWAYS prodmat3
11502 #ifndef OSF
11503 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11504 #endif
11505       implicit none
11506       integer i,j
11507       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11508       logical transp
11509 crc      double precision auxmat(2,2),prod_(2,2)
11510
11511       if (transp) then
11512 crc        call transpose2(kk(1,1),auxmat(1,1))
11513 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11514 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11515
11516            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11517      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11518            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11519      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11520            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11521      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11522            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11523      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11524
11525       else
11526 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11527 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11528
11529            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11530      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11531            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11532      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11533            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11534      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11535            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11536      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11537
11538       endif
11539 c      call transpose2(a2(1,1),a2t(1,1))
11540
11541 crc      print *,transp
11542 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11543 crc      print *,((prod(i,j),i=1,2),j=1,2)
11544
11545       return
11546       end
11547 CCC----------------------------------------------
11548       subroutine Eliptransfer(eliptran)
11549       implicit real*8 (a-h,o-z)
11550       include 'DIMENSIONS'
11551       include 'COMMON.GEO'
11552       include 'COMMON.VAR'
11553       include 'COMMON.LOCAL'
11554       include 'COMMON.CHAIN'
11555       include 'COMMON.DERIV'
11556       include 'COMMON.NAMES'
11557       include 'COMMON.INTERACT'
11558       include 'COMMON.IOUNITS'
11559       include 'COMMON.CALC'
11560       include 'COMMON.CONTROL'
11561       include 'COMMON.SPLITELE'
11562       include 'COMMON.SBRIDGE'
11563 C this is done by Adasko
11564 C      print *,"wchodze"
11565 C structure of box:
11566 C      water
11567 C--bordliptop-- buffore starts
11568 C--bufliptop--- here true lipid starts
11569 C      lipid
11570 C--buflipbot--- lipid ends buffore starts
11571 C--bordlipbot--buffore ends
11572       eliptran=0.0
11573       do i=ilip_start,ilip_end
11574 C       do i=1,1
11575         if (itype(i).eq.ntyp1) cycle
11576
11577         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11578         if (positi.le.0.0) positi=positi+boxzsize
11579 C        print *,i
11580 C first for peptide groups
11581 c for each residue check if it is in lipid or lipid water border area
11582        if ((positi.gt.bordlipbot)
11583      &.and.(positi.lt.bordliptop)) then
11584 C the energy transfer exist
11585         if (positi.lt.buflipbot) then
11586 C what fraction I am in
11587          fracinbuf=1.0d0-
11588      &        ((positi-bordlipbot)/lipbufthick)
11589 C lipbufthick is thickenes of lipid buffore
11590          sslip=sscalelip(fracinbuf)
11591          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11592          eliptran=eliptran+sslip*pepliptran
11593          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11594          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11595 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11596
11597 C        print *,"doing sccale for lower part"
11598 C         print *,i,sslip,fracinbuf,ssgradlip
11599         elseif (positi.gt.bufliptop) then
11600          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11601          sslip=sscalelip(fracinbuf)
11602          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11603          eliptran=eliptran+sslip*pepliptran
11604          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11605          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11606 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11607 C          print *, "doing sscalefor top part"
11608 C         print *,i,sslip,fracinbuf,ssgradlip
11609         else
11610          eliptran=eliptran+pepliptran
11611 C         print *,"I am in true lipid"
11612         endif
11613 C       else
11614 C       eliptran=elpitran+0.0 ! I am in water
11615        endif
11616        enddo
11617 C       print *, "nic nie bylo w lipidzie?"
11618 C now multiply all by the peptide group transfer factor
11619 C       eliptran=eliptran*pepliptran
11620 C now the same for side chains
11621 CV       do i=1,1
11622        do i=ilip_start,ilip_end
11623         if (itype(i).eq.ntyp1) cycle
11624         positi=(mod(c(3,i+nres),boxzsize))
11625         if (positi.le.0) positi=positi+boxzsize
11626 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11627 c for each residue check if it is in lipid or lipid water border area
11628 C       respos=mod(c(3,i+nres),boxzsize)
11629 C       print *,positi,bordlipbot,buflipbot
11630        if ((positi.gt.bordlipbot)
11631      & .and.(positi.lt.bordliptop)) then
11632 C the energy transfer exist
11633         if (positi.lt.buflipbot) then
11634          fracinbuf=1.0d0-
11635      &     ((positi-bordlipbot)/lipbufthick)
11636 C lipbufthick is thickenes of lipid buffore
11637          sslip=sscalelip(fracinbuf)
11638          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11639          eliptran=eliptran+sslip*liptranene(itype(i))
11640          gliptranx(3,i)=gliptranx(3,i)
11641      &+ssgradlip*liptranene(itype(i))
11642          gliptranc(3,i-1)= gliptranc(3,i-1)
11643      &+ssgradlip*liptranene(itype(i))
11644 C         print *,"doing sccale for lower part"
11645         elseif (positi.gt.bufliptop) then
11646          fracinbuf=1.0d0-
11647      &((bordliptop-positi)/lipbufthick)
11648          sslip=sscalelip(fracinbuf)
11649          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11650          eliptran=eliptran+sslip*liptranene(itype(i))
11651          gliptranx(3,i)=gliptranx(3,i)
11652      &+ssgradlip*liptranene(itype(i))
11653          gliptranc(3,i-1)= gliptranc(3,i-1)
11654      &+ssgradlip*liptranene(itype(i))
11655 C          print *, "doing sscalefor top part",sslip,fracinbuf
11656         else
11657          eliptran=eliptran+liptranene(itype(i))
11658 C         print *,"I am in true lipid"
11659         endif
11660         endif ! if in lipid or buffor
11661 C       else
11662 C       eliptran=elpitran+0.0 ! I am in water
11663        enddo
11664        return
11665        end
11666 C---------------------------------------------------------
11667 C AFM soubroutine for constant force
11668        subroutine AFMforce(Eafmforce)
11669        implicit real*8 (a-h,o-z)
11670       include 'DIMENSIONS'
11671       include 'COMMON.GEO'
11672       include 'COMMON.VAR'
11673       include 'COMMON.LOCAL'
11674       include 'COMMON.CHAIN'
11675       include 'COMMON.DERIV'
11676       include 'COMMON.NAMES'
11677       include 'COMMON.INTERACT'
11678       include 'COMMON.IOUNITS'
11679       include 'COMMON.CALC'
11680       include 'COMMON.CONTROL'
11681       include 'COMMON.SPLITELE'
11682       include 'COMMON.SBRIDGE'
11683       real*8 diffafm(3)
11684       dist=0.0d0
11685       Eafmforce=0.0d0
11686       do i=1,3
11687       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11688       dist=dist+diffafm(i)**2
11689       enddo
11690       dist=dsqrt(dist)
11691       Eafmforce=-forceAFMconst*(dist-distafminit)
11692       do i=1,3
11693       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11694       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11695       enddo
11696 C      print *,'AFM',Eafmforce
11697       return
11698       end
11699 C---------------------------------------------------------
11700 C AFM subroutine with pseudoconstant velocity
11701        subroutine AFMvel(Eafmforce)
11702        implicit real*8 (a-h,o-z)
11703       include 'DIMENSIONS'
11704       include 'COMMON.GEO'
11705       include 'COMMON.VAR'
11706       include 'COMMON.LOCAL'
11707       include 'COMMON.CHAIN'
11708       include 'COMMON.DERIV'
11709       include 'COMMON.NAMES'
11710       include 'COMMON.INTERACT'
11711       include 'COMMON.IOUNITS'
11712       include 'COMMON.CALC'
11713       include 'COMMON.CONTROL'
11714       include 'COMMON.SPLITELE'
11715       include 'COMMON.SBRIDGE'
11716       real*8 diffafm(3)
11717 C Only for check grad COMMENT if not used for checkgrad
11718 C      totT=3.0d0
11719 C--------------------------------------------------------
11720 C      print *,"wchodze"
11721       dist=0.0d0
11722       Eafmforce=0.0d0
11723       do i=1,3
11724       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11725       dist=dist+diffafm(i)**2
11726       enddo
11727       dist=dsqrt(dist)
11728       Eafmforce=0.5d0*forceAFMconst
11729      & *(distafminit+totTafm*velAFMconst-dist)**2
11730 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11731       do i=1,3
11732       gradafm(i,afmend-1)=-forceAFMconst*
11733      &(distafminit+totTafm*velAFMconst-dist)
11734      &*diffafm(i)/dist
11735       gradafm(i,afmbeg-1)=forceAFMconst*
11736      &(distafminit+totTafm*velAFMconst-dist)
11737      &*diffafm(i)/dist
11738       enddo
11739 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11740       return
11741       end
11742 C-----------------------------------------------------------
11743 C first for shielding is setting of function of side-chains
11744        subroutine set_shield_fac
11745       implicit real*8 (a-h,o-z)
11746       include 'DIMENSIONS'
11747       include 'COMMON.CHAIN'
11748       include 'COMMON.DERIV'
11749       include 'COMMON.IOUNITS'
11750       include 'COMMON.SHIELD'
11751       include 'COMMON.INTERACT'
11752 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11753       double precision div77_81/0.974996043d0/,
11754      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11755
11756 C the vector between center of side_chain and peptide group
11757        double precision pep_side(3),long,side_calf(3),
11758      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11759      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11760 C the line belowe needs to be changed for FGPROC>1
11761       do i=1,nres-1
11762       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11763       ishield_list(i)=0
11764 Cif there two consequtive dummy atoms there is no peptide group between them
11765 C the line below has to be changed for FGPROC>1
11766       VolumeTotal=0.0
11767       do k=1,nres
11768        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11769        dist_pep_side=0.0
11770        dist_side_calf=0.0
11771        do j=1,3
11772 C first lets set vector conecting the ithe side-chain with kth side-chain
11773       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11774 C      pep_side(j)=2.0d0
11775 C and vector conecting the side-chain with its proper calfa
11776       side_calf(j)=c(j,k+nres)-c(j,k)
11777 C      side_calf(j)=2.0d0
11778       pept_group(j)=c(j,i)-c(j,i+1)
11779 C lets have their lenght
11780       dist_pep_side=pep_side(j)**2+dist_pep_side
11781       dist_side_calf=dist_side_calf+side_calf(j)**2
11782       dist_pept_group=dist_pept_group+pept_group(j)**2
11783       enddo
11784        dist_pep_side=dsqrt(dist_pep_side)
11785        dist_pept_group=dsqrt(dist_pept_group)
11786        dist_side_calf=dsqrt(dist_side_calf)
11787       do j=1,3
11788         pep_side_norm(j)=pep_side(j)/dist_pep_side
11789         side_calf_norm(j)=dist_side_calf
11790       enddo
11791 C now sscale fraction
11792        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11793 C       print *,buff_shield,"buff"
11794 C now sscale
11795         if (sh_frac_dist.le.0.0) cycle
11796 C If we reach here it means that this side chain reaches the shielding sphere
11797 C Lets add him to the list for gradient
11798         ishield_list(i)=ishield_list(i)+1
11799 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11800 C this list is essential otherwise problem would be O3
11801         shield_list(ishield_list(i),i)=k
11802 C Lets have the sscale value
11803         if (sh_frac_dist.gt.1.0) then
11804          scale_fac_dist=1.0d0
11805          do j=1,3
11806          sh_frac_dist_grad(j)=0.0d0
11807          enddo
11808         else
11809          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11810      &                   *(2.0*sh_frac_dist-3.0d0)
11811          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11812      &                  /dist_pep_side/buff_shield*0.5
11813 C remember for the final gradient multiply sh_frac_dist_grad(j)
11814 C for side_chain by factor -2 !
11815          do j=1,3
11816          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11817 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11818 C     &                    sh_frac_dist_grad(j)
11819          enddo
11820         endif
11821 C        if ((i.eq.3).and.(k.eq.2)) then
11822 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11823 C     & ,"TU"
11824 C        endif
11825
11826 C this is what is now we have the distance scaling now volume...
11827       short=short_r_sidechain(itype(k))
11828       long=long_r_sidechain(itype(k))
11829       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11830 C now costhet_grad
11831 C       costhet=0.0d0
11832        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11833 C       costhet_fac=0.0d0
11834        do j=1,3
11835          costhet_grad(j)=costhet_fac*pep_side(j)
11836        enddo
11837 C remember for the final gradient multiply costhet_grad(j)
11838 C for side_chain by factor -2 !
11839 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11840 C pep_side0pept_group is vector multiplication
11841       pep_side0pept_group=0.0
11842       do j=1,3
11843       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11844       enddo
11845       cosalfa=(pep_side0pept_group/
11846      & (dist_pep_side*dist_side_calf))
11847       fac_alfa_sin=1.0-cosalfa**2
11848       fac_alfa_sin=dsqrt(fac_alfa_sin)
11849       rkprim=fac_alfa_sin*(long-short)+short
11850 C now costhet_grad
11851        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11852        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11853
11854        do j=1,3
11855          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11856      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11857      &*(long-short)/fac_alfa_sin*cosalfa/
11858      &((dist_pep_side*dist_side_calf))*
11859      &((side_calf(j))-cosalfa*
11860      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11861
11862         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11863      &*(long-short)/fac_alfa_sin*cosalfa
11864      &/((dist_pep_side*dist_side_calf))*
11865      &(pep_side(j)-
11866      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11867        enddo
11868
11869       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11870      &                    /VSolvSphere_div
11871      &                    *wshield
11872 C now the gradient...
11873 C grad_shield is gradient of Calfa for peptide groups
11874 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11875 C     &               costhet,cosphi
11876 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11877 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11878       do j=1,3
11879       grad_shield(j,i)=grad_shield(j,i)
11880 C gradient po skalowaniu
11881      &                +(sh_frac_dist_grad(j)
11882 C  gradient po costhet
11883      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11884      &-scale_fac_dist*(cosphi_grad_long(j))
11885      &/(1.0-cosphi) )*div77_81
11886      &*VofOverlap
11887 C grad_shield_side is Cbeta sidechain gradient
11888       grad_shield_side(j,ishield_list(i),i)=
11889      &        (sh_frac_dist_grad(j)*-2.0d0
11890      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11891      &       +scale_fac_dist*(cosphi_grad_long(j))
11892      &        *2.0d0/(1.0-cosphi))
11893      &        *div77_81*VofOverlap
11894
11895        grad_shield_loc(j,ishield_list(i),i)=
11896      &   scale_fac_dist*cosphi_grad_loc(j)
11897      &        *2.0d0/(1.0-cosphi)
11898      &        *div77_81*VofOverlap
11899       enddo
11900       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11901       enddo
11902       fac_shield(i)=VolumeTotal*div77_81+div4_81
11903 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11904       enddo
11905       return
11906       end
11907 C--------------------------------------------------------------------------
11908       double precision function tschebyshev(m,n,x,y)
11909       implicit none
11910       include "DIMENSIONS"
11911       integer i,m,n
11912       double precision x(n),y,yy(0:maxvar),aux
11913 c Tschebyshev polynomial. Note that the first term is omitted
11914 c m=0: the constant term is included
11915 c m=1: the constant term is not included
11916       yy(0)=1.0d0
11917       yy(1)=y
11918       do i=2,n
11919         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11920       enddo
11921       aux=0.0d0
11922       do i=m,n
11923         aux=aux+x(i)*yy(i)
11924       enddo
11925       tschebyshev=aux
11926       return
11927       end
11928 C--------------------------------------------------------------------------
11929       double precision function gradtschebyshev(m,n,x,y)
11930       implicit none
11931       include "DIMENSIONS"
11932       integer i,m,n
11933       double precision x(n+1),y,yy(0:maxvar),aux
11934 c Tschebyshev polynomial. Note that the first term is omitted
11935 c m=0: the constant term is included
11936 c m=1: the constant term is not included
11937       yy(0)=1.0d0
11938       yy(1)=2.0d0*y
11939       do i=2,n
11940         yy(i)=2*y*yy(i-1)-yy(i-2)
11941       enddo
11942       aux=0.0d0
11943       do i=m,n
11944         aux=aux+x(i+1)*yy(i)*(i+1)
11945 C        print *, x(i+1),yy(i),i
11946       enddo
11947       gradtschebyshev=aux
11948       return
11949       end
11950 C------------------------------------------------------------------------
11951 C first for shielding is setting of function of side-chains
11952        subroutine set_shield_fac2
11953       implicit real*8 (a-h,o-z)
11954       include 'DIMENSIONS'
11955       include 'COMMON.CHAIN'
11956       include 'COMMON.DERIV'
11957       include 'COMMON.IOUNITS'
11958       include 'COMMON.SHIELD'
11959       include 'COMMON.INTERACT'
11960       include 'COMMON.LOCAL'
11961
11962 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11963       double precision div77_81/0.974996043d0/,
11964      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11965
11966 C the vector between center of side_chain and peptide group
11967        double precision pep_side(3),long,side_calf(3),
11968      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11969      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11970 C      write(2,*) "ivec",ivec_start,ivec_end
11971       do i=1,nres
11972         fac_shield(i)=0.0d0
11973         do j=1,3
11974         grad_shield(j,i)=0.0d0
11975         enddo
11976       enddo
11977 C the line belowe needs to be changed for FGPROC>1
11978       do i=ivec_start,ivec_end
11979 C      do i=1,nres-1
11980 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11981       ishield_list(i)=0
11982       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11983 Cif there two consequtive dummy atoms there is no peptide group between them
11984 C the line below has to be changed for FGPROC>1
11985       VolumeTotal=0.0
11986       do k=1,nres
11987        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11988        dist_pep_side=0.0
11989        dist_side_calf=0.0
11990        do j=1,3
11991 C first lets set vector conecting the ithe side-chain with kth side-chain
11992       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11993 C      pep_side(j)=2.0d0
11994 C and vector conecting the side-chain with its proper calfa
11995       side_calf(j)=c(j,k+nres)-c(j,k)
11996 C      side_calf(j)=2.0d0
11997       pept_group(j)=c(j,i)-c(j,i+1)
11998 C lets have their lenght
11999       dist_pep_side=pep_side(j)**2+dist_pep_side
12000       dist_side_calf=dist_side_calf+side_calf(j)**2
12001       dist_pept_group=dist_pept_group+pept_group(j)**2
12002       enddo
12003        dist_pep_side=dsqrt(dist_pep_side)
12004        dist_pept_group=dsqrt(dist_pept_group)
12005        dist_side_calf=dsqrt(dist_side_calf)
12006       do j=1,3
12007         pep_side_norm(j)=pep_side(j)/dist_pep_side
12008         side_calf_norm(j)=dist_side_calf
12009       enddo
12010 C now sscale fraction
12011        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12012 C       print *,buff_shield,"buff"
12013 C now sscale
12014         if (sh_frac_dist.le.0.0) cycle
12015 C        print *,ishield_list(i),i
12016 C If we reach here it means that this side chain reaches the shielding sphere
12017 C Lets add him to the list for gradient
12018         ishield_list(i)=ishield_list(i)+1
12019 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12020 C this list is essential otherwise problem would be O3
12021         shield_list(ishield_list(i),i)=k
12022 C Lets have the sscale value
12023         if (sh_frac_dist.gt.1.0) then
12024          scale_fac_dist=1.0d0
12025          do j=1,3
12026          sh_frac_dist_grad(j)=0.0d0
12027          enddo
12028         else
12029          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12030      &                   *(2.0d0*sh_frac_dist-3.0d0)
12031          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12032      &                  /dist_pep_side/buff_shield*0.5d0
12033 C remember for the final gradient multiply sh_frac_dist_grad(j)
12034 C for side_chain by factor -2 !
12035          do j=1,3
12036          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12037 C         sh_frac_dist_grad(j)=0.0d0
12038 C         scale_fac_dist=1.0d0
12039 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12040 C     &                    sh_frac_dist_grad(j)
12041          enddo
12042         endif
12043 C this is what is now we have the distance scaling now volume...
12044       short=short_r_sidechain(itype(k))
12045       long=long_r_sidechain(itype(k))
12046       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12047       sinthet=short/dist_pep_side*costhet
12048 C now costhet_grad
12049 C       costhet=0.6d0
12050 C       sinthet=0.8
12051        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12052 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12053 C     &             -short/dist_pep_side**2/costhet)
12054 C       costhet_fac=0.0d0
12055        do j=1,3
12056          costhet_grad(j)=costhet_fac*pep_side(j)
12057        enddo
12058 C remember for the final gradient multiply costhet_grad(j)
12059 C for side_chain by factor -2 !
12060 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12061 C pep_side0pept_group is vector multiplication
12062       pep_side0pept_group=0.0d0
12063       do j=1,3
12064       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12065       enddo
12066       cosalfa=(pep_side0pept_group/
12067      & (dist_pep_side*dist_side_calf))
12068       fac_alfa_sin=1.0d0-cosalfa**2
12069       fac_alfa_sin=dsqrt(fac_alfa_sin)
12070       rkprim=fac_alfa_sin*(long-short)+short
12071 C      rkprim=short
12072
12073 C now costhet_grad
12074        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12075 C       cosphi=0.6
12076        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12077        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12078      &      dist_pep_side**2)
12079 C       sinphi=0.8
12080        do j=1,3
12081          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12082      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12083      &*(long-short)/fac_alfa_sin*cosalfa/
12084      &((dist_pep_side*dist_side_calf))*
12085      &((side_calf(j))-cosalfa*
12086      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12087 C       cosphi_grad_long(j)=0.0d0
12088         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12089      &*(long-short)/fac_alfa_sin*cosalfa
12090      &/((dist_pep_side*dist_side_calf))*
12091      &(pep_side(j)-
12092      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12093 C       cosphi_grad_loc(j)=0.0d0
12094        enddo
12095 C      print *,sinphi,sinthet
12096       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12097      &                    /VSolvSphere_div
12098 C     &                    *wshield
12099 C now the gradient...
12100       do j=1,3
12101       grad_shield(j,i)=grad_shield(j,i)
12102 C gradient po skalowaniu
12103      &                +(sh_frac_dist_grad(j)*VofOverlap
12104 C  gradient po costhet
12105      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12106      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12107      &       sinphi/sinthet*costhet*costhet_grad(j)
12108      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12109      & )*wshield
12110 C grad_shield_side is Cbeta sidechain gradient
12111       grad_shield_side(j,ishield_list(i),i)=
12112      &        (sh_frac_dist_grad(j)*-2.0d0
12113      &        *VofOverlap
12114      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12115      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12116      &       sinphi/sinthet*costhet*costhet_grad(j)
12117      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12118      &       )*wshield
12119
12120        grad_shield_loc(j,ishield_list(i),i)=
12121      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12122      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12123      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12124      &        ))
12125      &        *wshield
12126       enddo
12127       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12128       enddo
12129       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12130 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12131       enddo
12132       return
12133       end
12134 C-----------------------------------------------------------------------
12135 C-----------------------------------------------------------
12136 C This subroutine is to mimic the histone like structure but as well can be
12137 C utilizet to nanostructures (infinit) small modification has to be used to
12138 C make it finite (z gradient at the ends has to be changes as well as the x,y
12139 C gradient has to be modified at the ends
12140 C The energy function is Kihara potential
12141 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12142 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12143 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12144 C simple Kihara potential
12145       subroutine calctube(Etube)
12146        implicit real*8 (a-h,o-z)
12147       include 'DIMENSIONS'
12148       include 'COMMON.GEO'
12149       include 'COMMON.VAR'
12150       include 'COMMON.LOCAL'
12151       include 'COMMON.CHAIN'
12152       include 'COMMON.DERIV'
12153       include 'COMMON.NAMES'
12154       include 'COMMON.INTERACT'
12155       include 'COMMON.IOUNITS'
12156       include 'COMMON.CALC'
12157       include 'COMMON.CONTROL'
12158       include 'COMMON.SPLITELE'
12159       include 'COMMON.SBRIDGE'
12160       double precision tub_r,vectube(3),enetube(maxres*2)
12161       Etube=0.0d0
12162       do i=itube_start,itube_end
12163         enetube(i)=0.0d0
12164         enetube(i+nres)=0.0d0
12165       enddo
12166 C first we calculate the distance from tube center
12167 C first sugare-phosphate group for NARES this would be peptide group
12168 C for UNRES
12169        do i=itube_start,itube_end
12170 C lets ommit dummy atoms for now
12171        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12172 C now calculate distance from center of tube and direction vectors
12173       xmin=boxxsize
12174       ymin=boxysize
12175         do j=-1,1
12176          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12177          vectube(1)=vectube(1)+boxxsize*j
12178          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12179          vectube(2)=vectube(2)+boxysize*j
12180
12181          xminact=abs(vectube(1)-tubecenter(1))
12182          yminact=abs(vectube(2)-tubecenter(2))
12183            if (xmin.gt.xminact) then
12184             xmin=xminact
12185             xtemp=vectube(1)
12186            endif
12187            if (ymin.gt.yminact) then
12188              ymin=yminact
12189              ytemp=vectube(2)
12190             endif
12191          enddo
12192       vectube(1)=xtemp
12193       vectube(2)=ytemp
12194       vectube(1)=vectube(1)-tubecenter(1)
12195       vectube(2)=vectube(2)-tubecenter(2)
12196
12197 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12198 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12199
12200 C as the tube is infinity we do not calculate the Z-vector use of Z
12201 C as chosen axis
12202       vectube(3)=0.0d0
12203 C now calculte the distance
12204        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12205 C now normalize vector
12206       vectube(1)=vectube(1)/tub_r
12207       vectube(2)=vectube(2)/tub_r
12208 C calculte rdiffrence between r and r0
12209       rdiff=tub_r-tubeR0
12210 C and its 6 power
12211       rdiff6=rdiff**6.0d0
12212 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12213        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12214 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12215 C       print *,rdiff,rdiff6,pep_aa_tube
12216 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12217 C now we calculate gradient
12218        fac=(-12.0d0*pep_aa_tube/rdiff6-
12219      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12220 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12221 C     &rdiff,fac
12222
12223 C now direction of gg_tube vector
12224         do j=1,3
12225         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12226         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12227         enddo
12228         enddo
12229 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12230 C        print *,gg_tube(1,0),"TU"
12231
12232
12233        do i=itube_start,itube_end
12234 C Lets not jump over memory as we use many times iti
12235          iti=itype(i)
12236 C lets ommit dummy atoms for now
12237          if ((iti.eq.ntyp1)
12238 C in UNRES uncomment the line below as GLY has no side-chain...
12239 C      .or.(iti.eq.10)
12240      &   ) cycle
12241       xmin=boxxsize
12242       ymin=boxysize
12243         do j=-1,1
12244          vectube(1)=mod((c(1,i+nres)),boxxsize)
12245          vectube(1)=vectube(1)+boxxsize*j
12246          vectube(2)=mod((c(2,i+nres)),boxysize)
12247          vectube(2)=vectube(2)+boxysize*j
12248
12249          xminact=abs(vectube(1)-tubecenter(1))
12250          yminact=abs(vectube(2)-tubecenter(2))
12251            if (xmin.gt.xminact) then
12252             xmin=xminact
12253             xtemp=vectube(1)
12254            endif
12255            if (ymin.gt.yminact) then
12256              ymin=yminact
12257              ytemp=vectube(2)
12258             endif
12259          enddo
12260       vectube(1)=xtemp
12261       vectube(2)=ytemp
12262 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12263 C     &     tubecenter(2)
12264       vectube(1)=vectube(1)-tubecenter(1)
12265       vectube(2)=vectube(2)-tubecenter(2)
12266
12267 C as the tube is infinity we do not calculate the Z-vector use of Z
12268 C as chosen axis
12269       vectube(3)=0.0d0
12270 C now calculte the distance
12271        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12272 C now normalize vector
12273       vectube(1)=vectube(1)/tub_r
12274       vectube(2)=vectube(2)/tub_r
12275
12276 C calculte rdiffrence between r and r0
12277       rdiff=tub_r-tubeR0
12278 C and its 6 power
12279       rdiff6=rdiff**6.0d0
12280 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12281        sc_aa_tube=sc_aa_tube_par(iti)
12282        sc_bb_tube=sc_bb_tube_par(iti)
12283        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12284 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12285 C now we calculate gradient
12286        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12287      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12288 C now direction of gg_tube vector
12289          do j=1,3
12290           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12291           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12292          enddo
12293         enddo
12294         do i=itube_start,itube_end
12295           Etube=Etube+enetube(i)+enetube(i+nres)
12296         enddo
12297 C        print *,"ETUBE", etube
12298         return
12299         end
12300 C TO DO 1) add to total energy
12301 C       2) add to gradient summation
12302 C       3) add reading parameters (AND of course oppening of PARAM file)
12303 C       4) add reading the center of tube
12304 C       5) add COMMONs
12305 C       6) add to zerograd
12306
12307 C-----------------------------------------------------------------------
12308 C-----------------------------------------------------------
12309 C This subroutine is to mimic the histone like structure but as well can be
12310 C utilizet to nanostructures (infinit) small modification has to be used to
12311 C make it finite (z gradient at the ends has to be changes as well as the x,y
12312 C gradient has to be modified at the ends
12313 C The energy function is Kihara potential
12314 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12315 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12316 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12317 C simple Kihara potential
12318       subroutine calctube2(Etube)
12319        implicit real*8 (a-h,o-z)
12320       include 'DIMENSIONS'
12321       include 'COMMON.GEO'
12322       include 'COMMON.VAR'
12323       include 'COMMON.LOCAL'
12324       include 'COMMON.CHAIN'
12325       include 'COMMON.DERIV'
12326       include 'COMMON.NAMES'
12327       include 'COMMON.INTERACT'
12328       include 'COMMON.IOUNITS'
12329       include 'COMMON.CALC'
12330       include 'COMMON.CONTROL'
12331       include 'COMMON.SPLITELE'
12332       include 'COMMON.SBRIDGE'
12333       double precision tub_r,vectube(3),enetube(maxres*2)
12334       Etube=0.0d0
12335       do i=itube_start,itube_end
12336         enetube(i)=0.0d0
12337         enetube(i+nres)=0.0d0
12338       enddo
12339 C first we calculate the distance from tube center
12340 C first sugare-phosphate group for NARES this would be peptide group
12341 C for UNRES
12342        do i=itube_start,itube_end
12343 C lets ommit dummy atoms for now
12344
12345        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12346 C now calculate distance from center of tube and direction vectors
12347 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12348 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12349 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12350 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12351       xmin=boxxsize
12352       ymin=boxysize
12353         do j=-1,1
12354          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12355          vectube(1)=vectube(1)+boxxsize*j
12356          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12357          vectube(2)=vectube(2)+boxysize*j
12358
12359          xminact=abs(vectube(1)-tubecenter(1))
12360          yminact=abs(vectube(2)-tubecenter(2))
12361            if (xmin.gt.xminact) then
12362             xmin=xminact
12363             xtemp=vectube(1)
12364            endif
12365            if (ymin.gt.yminact) then
12366              ymin=yminact
12367              ytemp=vectube(2)
12368             endif
12369          enddo
12370       vectube(1)=xtemp
12371       vectube(2)=ytemp
12372       vectube(1)=vectube(1)-tubecenter(1)
12373       vectube(2)=vectube(2)-tubecenter(2)
12374
12375 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12376 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12377
12378 C as the tube is infinity we do not calculate the Z-vector use of Z
12379 C as chosen axis
12380       vectube(3)=0.0d0
12381 C now calculte the distance
12382        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12383 C now normalize vector
12384       vectube(1)=vectube(1)/tub_r
12385       vectube(2)=vectube(2)/tub_r
12386 C calculte rdiffrence between r and r0
12387       rdiff=tub_r-tubeR0
12388 C and its 6 power
12389       rdiff6=rdiff**6.0d0
12390 C THIS FRAGMENT MAKES TUBE FINITE
12391         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12392         if (positi.le.0) positi=positi+boxzsize
12393 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12394 c for each residue check if it is in lipid or lipid water border area
12395 C       respos=mod(c(3,i+nres),boxzsize)
12396        print *,positi,bordtubebot,buftubebot,bordtubetop
12397        if ((positi.gt.bordtubebot)
12398      & .and.(positi.lt.bordtubetop)) then
12399 C the energy transfer exist
12400         if (positi.lt.buftubebot) then
12401          fracinbuf=1.0d0-
12402      &     ((positi-bordtubebot)/tubebufthick)
12403 C lipbufthick is thickenes of lipid buffore
12404          sstube=sscalelip(fracinbuf)
12405          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12406          print *,ssgradtube, sstube,tubetranene(itype(i))
12407          enetube(i)=enetube(i)+sstube*tubetranenepep
12408 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12409 C     &+ssgradtube*tubetranene(itype(i))
12410 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12411 C     &+ssgradtube*tubetranene(itype(i))
12412 C         print *,"doing sccale for lower part"
12413         elseif (positi.gt.buftubetop) then
12414          fracinbuf=1.0d0-
12415      &((bordtubetop-positi)/tubebufthick)
12416          sstube=sscalelip(fracinbuf)
12417          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12418          enetube(i)=enetube(i)+sstube*tubetranenepep
12419 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12420 C     &+ssgradtube*tubetranene(itype(i))
12421 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12422 C     &+ssgradtube*tubetranene(itype(i))
12423 C          print *, "doing sscalefor top part",sslip,fracinbuf
12424         else
12425          sstube=1.0d0
12426          ssgradtube=0.0d0
12427          enetube(i)=enetube(i)+sstube*tubetranenepep
12428 C         print *,"I am in true lipid"
12429         endif
12430         else
12431 C          sstube=0.0d0
12432 C          ssgradtube=0.0d0
12433         cycle
12434         endif ! if in lipid or buffor
12435
12436 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12437        enetube(i)=enetube(i)+sstube*
12438      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
12439 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12440 C       print *,rdiff,rdiff6,pep_aa_tube
12441 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12442 C now we calculate gradient
12443        fac=(-12.0d0*pep_aa_tube/rdiff6-
12444      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
12445 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12446 C     &rdiff,fac
12447
12448 C now direction of gg_tube vector
12449         do j=1,3
12450         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12451         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12452         enddo
12453          gg_tube(3,i)=gg_tube(3,i)
12454      &+ssgradtube*enetube(i)/sstube/2.0d0
12455          gg_tube(3,i-1)= gg_tube(3,i-1)
12456      &+ssgradtube*enetube(i)/sstube/2.0d0
12457
12458         enddo
12459 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12460 C        print *,gg_tube(1,0),"TU"
12461         do i=itube_start,itube_end
12462 C Lets not jump over memory as we use many times iti
12463          iti=itype(i)
12464 C lets ommit dummy atoms for now
12465          if ((iti.eq.ntyp1)
12466 C in UNRES uncomment the line below as GLY has no side-chain...
12467      &      .or.(iti.eq.10)
12468      &   ) cycle
12469           vectube(1)=c(1,i+nres)
12470           vectube(1)=mod(vectube(1),boxxsize)
12471           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12472           vectube(2)=c(2,i+nres)
12473           vectube(2)=mod(vectube(2),boxysize)
12474           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12475
12476       vectube(1)=vectube(1)-tubecenter(1)
12477       vectube(2)=vectube(2)-tubecenter(2)
12478 C THIS FRAGMENT MAKES TUBE FINITE
12479         positi=(mod(c(3,i+nres),boxzsize))
12480         if (positi.le.0) positi=positi+boxzsize
12481 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12482 c for each residue check if it is in lipid or lipid water border area
12483 C       respos=mod(c(3,i+nres),boxzsize)
12484        print *,positi,bordtubebot,buftubebot,bordtubetop
12485        if ((positi.gt.bordtubebot)
12486      & .and.(positi.lt.bordtubetop)) then
12487 C the energy transfer exist
12488         if (positi.lt.buftubebot) then
12489          fracinbuf=1.0d0-
12490      &     ((positi-bordtubebot)/tubebufthick)
12491 C lipbufthick is thickenes of lipid buffore
12492          sstube=sscalelip(fracinbuf)
12493          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12494          print *,ssgradtube, sstube,tubetranene(itype(i))
12495          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12496 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12497 C     &+ssgradtube*tubetranene(itype(i))
12498 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12499 C     &+ssgradtube*tubetranene(itype(i))
12500 C         print *,"doing sccale for lower part"
12501         elseif (positi.gt.buftubetop) then
12502          fracinbuf=1.0d0-
12503      &((bordtubetop-positi)/tubebufthick)
12504          sstube=sscalelip(fracinbuf)
12505          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12506          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12507 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12508 C     &+ssgradtube*tubetranene(itype(i))
12509 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12510 C     &+ssgradtube*tubetranene(itype(i))
12511 C          print *, "doing sscalefor top part",sslip,fracinbuf
12512         else
12513          sstube=1.0d0
12514          ssgradtube=0.0d0
12515          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12516 C         print *,"I am in true lipid"
12517         endif
12518         else
12519 C          sstube=0.0d0
12520 C          ssgradtube=0.0d0
12521         cycle
12522         endif ! if in lipid or buffor
12523 CEND OF FINITE FRAGMENT
12524 C as the tube is infinity we do not calculate the Z-vector use of Z
12525 C as chosen axis
12526       vectube(3)=0.0d0
12527 C now calculte the distance
12528        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12529 C now normalize vector
12530       vectube(1)=vectube(1)/tub_r
12531       vectube(2)=vectube(2)/tub_r
12532 C calculte rdiffrence between r and r0
12533       rdiff=tub_r-tubeR0
12534 C and its 6 power
12535       rdiff6=rdiff**6.0d0
12536 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12537        sc_aa_tube=sc_aa_tube_par(iti)
12538        sc_bb_tube=sc_bb_tube_par(iti)
12539        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12540      &                 *sstube+enetube(i+nres)
12541 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12542 C now we calculate gradient
12543        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12544      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12545 C now direction of gg_tube vector
12546          do j=1,3
12547           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12548           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12549          enddo
12550          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12551      &+ssgradtube*enetube(i+nres)/sstube
12552          gg_tube(3,i-1)= gg_tube(3,i-1)
12553      &+ssgradtube*enetube(i+nres)/sstube
12554
12555         enddo
12556         do i=itube_start,itube_end
12557           Etube=Etube+enetube(i)+enetube(i+nres)
12558         enddo
12559 C        print *,"ETUBE", etube
12560         return
12561         end
12562 C TO DO 1) add to total energy
12563 C       2) add to gradient summation
12564 C       3) add reading parameters (AND of course oppening of PARAM file)
12565 C       4) add reading the center of tube
12566 C       5) add COMMONs
12567 C       6) add to zerograd
12568
12569
12570 C#-------------------------------------------------------------------------------
12571 C This subroutine is to mimic the histone like structure but as well can be
12572 C utilizet to nanostructures (infinit) small modification has to be used to
12573 C make it finite (z gradient at the ends has to be changes as well as the x,y
12574 C gradient has to be modified at the ends
12575 C The energy function is Kihara potential
12576 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12577 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12578 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12579 C simple Kihara potential
12580       subroutine calcnano(Etube)
12581        implicit real*8 (a-h,o-z)
12582       include 'DIMENSIONS'
12583       include 'COMMON.GEO'
12584       include 'COMMON.VAR'
12585       include 'COMMON.LOCAL'
12586       include 'COMMON.CHAIN'
12587       include 'COMMON.DERIV'
12588       include 'COMMON.NAMES'
12589       include 'COMMON.INTERACT'
12590       include 'COMMON.IOUNITS'
12591       include 'COMMON.CALC'
12592       include 'COMMON.CONTROL'
12593       include 'COMMON.SPLITELE'
12594       include 'COMMON.SBRIDGE'
12595       double precision tub_r,vectube(3),enetube(maxres*2),
12596      & enecavtube(maxres*2)
12597       Etube=0.0d0
12598       do i=itube_start,itube_end
12599         enetube(i)=0.0d0
12600         enetube(i+nres)=0.0d0
12601       enddo
12602 C first we calculate the distance from tube center
12603 C first sugare-phosphate group for NARES this would be peptide group
12604 C for UNRES
12605        do i=itube_start,itube_end
12606 C lets ommit dummy atoms for now
12607        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12608 C now calculate distance from center of tube and direction vectors
12609       xmin=boxxsize
12610       ymin=boxysize
12611       zmin=boxzsize
12612
12613         do j=-1,1
12614          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12615          vectube(1)=vectube(1)+boxxsize*j
12616          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12617          vectube(2)=vectube(2)+boxysize*j
12618          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12619          vectube(3)=vectube(3)+boxzsize*j
12620
12621
12622          xminact=dabs(vectube(1)-tubecenter(1))
12623          yminact=dabs(vectube(2)-tubecenter(2))
12624          zminact=dabs(vectube(3)-tubecenter(3))
12625
12626            if (xmin.gt.xminact) then
12627             xmin=xminact
12628             xtemp=vectube(1)
12629            endif
12630            if (ymin.gt.yminact) then
12631              ymin=yminact
12632              ytemp=vectube(2)
12633             endif
12634            if (zmin.gt.zminact) then
12635              zmin=zminact
12636              ztemp=vectube(3)
12637             endif
12638          enddo
12639       vectube(1)=xtemp
12640       vectube(2)=ytemp
12641       vectube(3)=ztemp
12642
12643       vectube(1)=vectube(1)-tubecenter(1)
12644       vectube(2)=vectube(2)-tubecenter(2)
12645       vectube(3)=vectube(3)-tubecenter(3)
12646
12647 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12648 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12649 C as the tube is infinity we do not calculate the Z-vector use of Z
12650 C as chosen axis
12651 C      vectube(3)=0.0d0
12652 C now calculte the distance
12653        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12654 C now normalize vector
12655       vectube(1)=vectube(1)/tub_r
12656       vectube(2)=vectube(2)/tub_r
12657       vectube(3)=vectube(3)/tub_r
12658 C calculte rdiffrence between r and r0
12659       rdiff=tub_r-tubeR0
12660 C and its 6 power
12661       rdiff6=rdiff**6.0d0
12662 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12663        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12664 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12665 C       print *,rdiff,rdiff6,pep_aa_tube
12666 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12667 C now we calculate gradient
12668        fac=(-12.0d0*pep_aa_tube/rdiff6-
12669      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12670 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12671 C     &rdiff,fac
12672          if (acavtubpep.eq.0.0d0) then
12673 C go to 667
12674          enecavtube(i)=0.0
12675          faccav=0.0
12676          else
12677          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
12678          enecavtube(i)=
12679      &   (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep)
12680      &   /denominator
12681          enecavtube(i)=0.0
12682          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff))
12683      &   *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)
12684      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
12685      &   /denominator**2.0d0
12686 C         faccav=0.0
12687 C         fac=fac+faccav
12688 C 667     continue
12689          endif
12690 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
12691 C     &   enecavtube(i),faccav
12692 C         print *,"licz=",
12693 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12694 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
12695
12696 C now direction of gg_tube vector
12697         do j=1,3
12698         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12699         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12700         enddo
12701         enddo
12702
12703        do i=itube_start,itube_end
12704         enecavtube(i)=0.0d0
12705 C Lets not jump over memory as we use many times iti
12706          iti=itype(i)
12707 C lets ommit dummy atoms for now
12708          if ((iti.eq.ntyp1)
12709 C in UNRES uncomment the line below as GLY has no side-chain...
12710 C      .or.(iti.eq.10)
12711      &   ) cycle
12712       xmin=boxxsize
12713       ymin=boxysize
12714       zmin=boxzsize
12715         do j=-1,1
12716          vectube(1)=dmod((c(1,i+nres)),boxxsize)
12717          vectube(1)=vectube(1)+boxxsize*j
12718          vectube(2)=dmod((c(2,i+nres)),boxysize)
12719          vectube(2)=vectube(2)+boxysize*j
12720          vectube(3)=dmod((c(3,i+nres)),boxzsize)
12721          vectube(3)=vectube(3)+boxzsize*j
12722
12723
12724          xminact=dabs(vectube(1)-tubecenter(1))
12725          yminact=dabs(vectube(2)-tubecenter(2))
12726          zminact=dabs(vectube(3)-tubecenter(3))
12727
12728            if (xmin.gt.xminact) then
12729             xmin=xminact
12730             xtemp=vectube(1)
12731            endif
12732            if (ymin.gt.yminact) then
12733              ymin=yminact
12734              ytemp=vectube(2)
12735             endif
12736            if (zmin.gt.zminact) then
12737              zmin=zminact
12738              ztemp=vectube(3)
12739             endif
12740          enddo
12741       vectube(1)=xtemp
12742       vectube(2)=ytemp
12743       vectube(3)=ztemp
12744
12745 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12746 C     &     tubecenter(2)
12747       vectube(1)=vectube(1)-tubecenter(1)
12748       vectube(2)=vectube(2)-tubecenter(2)
12749       vectube(3)=vectube(3)-tubecenter(3)
12750 C now calculte the distance
12751        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12752 C now normalize vector
12753       vectube(1)=vectube(1)/tub_r
12754       vectube(2)=vectube(2)/tub_r
12755       vectube(3)=vectube(3)/tub_r
12756
12757 C calculte rdiffrence between r and r0
12758       rdiff=tub_r-tubeR0
12759 C and its 6 power
12760       rdiff6=rdiff**6.0d0
12761 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12762        sc_aa_tube=sc_aa_tube_par(iti)
12763        sc_bb_tube=sc_bb_tube_par(iti)
12764        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12765 C       enetube(i+nres)=0.0d0
12766 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12767 C now we calculate gradient
12768        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12769      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12770 C       fac=0.0
12771 C now direction of gg_tube vector
12772 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12773          if (acavtub(iti).eq.0.0d0) then
12774 C go to 667
12775          enecavtube(i+nres)=0.0d0
12776          faccav=0.0d0
12777          else
12778          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
12779          enecavtube(i+nres)=
12780      &   (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti))
12781      &   /denominator
12782 C         enecavtube(i)=0.0
12783          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff))
12784      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)
12785      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
12786      &   /denominator**2.0d0
12787 C         faccav=0.0
12788          fac=fac+faccav
12789 C 667     continue
12790          endif
12791 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
12792 C     &   enecavtube(i),faccav
12793 C         print *,"licz=",
12794 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12795 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
12796          do j=1,3
12797           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12798           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12799          enddo
12800         enddo
12801 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12802 C        do i=itube_start,itube_end
12803 C        enecav(i)=0.0
12804 C        iti=itype(i)
12805 C        if (acavtub(iti).eq.0.0) cycle
12806
12807
12808
12809         do i=itube_start,itube_end
12810           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
12811      & +enecavtube(i+nres)
12812         enddo
12813 C        print *,"ETUBE", etube
12814         return
12815         end
12816 C TO DO 1) add to total energy
12817 C       2) add to gradient summation
12818 C       3) add reading parameters (AND of course oppening of PARAM file)
12819 C       4) add reading the center of tube
12820 C       5) add COMMONs
12821 C       6) add to zerograd
12822