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        else
 400        Etube=0.0d0
 401        endif
 402
 403 #ifdef TIMING
 404       time_enecalc=time_enecalc+MPI_Wtime()-time00
 405 #endif
 406 c      print *,"Processor",myrank," computed Uconstr"
 407 #ifdef TIMING
 408       time00=MPI_Wtime()
 409 #endif
 410 c
 411 C Sum the energies
 412 C
 413       energia(1)=evdw
 414 #ifdef SCP14
 415       energia(2)=evdw2-evdw2_14
 416       energia(18)=evdw2_14
 417 #else
 418       energia(2)=evdw2
 419       energia(18)=0.0d0
 420 #endif
 421 #ifdef SPLITELE
 422       energia(3)=ees
 423       energia(16)=evdw1
 424 #else
 425       energia(3)=ees+evdw1
 426       energia(16)=0.0d0
 427 #endif
 428       energia(4)=ecorr
 429       energia(5)=ecorr5
 430       energia(6)=ecorr6
 431       energia(7)=eel_loc
 432       energia(8)=eello_turn3
 433       energia(9)=eello_turn4
 434       energia(10)=eturn6
 435       energia(11)=ebe
 436       energia(12)=escloc
 437       energia(13)=etors
 438       energia(14)=etors_d
 439       energia(15)=ehpb
 440       energia(19)=edihcnstr
 441       energia(17)=estr
 442       energia(20)=Uconst+Uconst_back
 443       energia(21)=esccor
 444       energia(22)=eliptran
 445       energia(23)=Eafmforce
 446       energia(24)=ethetacnstr
 447       energia(25)=Etube
 448 c    Here are the energies showed per procesor if the are more processors
 449 c    per molecule then we sum it up in sum_energy subroutine
 450 c      print *," Processor",myrank," calls SUM_ENERGY"
 451       call sum_energy(energia,.true.)
 452       if (dyn_ss) call dyn_set_nss
 453 c      print *," Processor",myrank," left SUM_ENERGY"
 454 #ifdef TIMING
 455       time_sumene=time_sumene+MPI_Wtime()-time00
 456 #endif
 457       return
 458       end
 459 c-------------------------------------------------------------------------------
 460       subroutine sum_energy(energia,reduce)
 461       implicit real*8 (a-h,o-z)
 462       include 'DIMENSIONS'
 463 #ifndef ISNAN
 464       external proc_proc
 465 #ifdef WINPGI
 466 cMS$ATTRIBUTES C ::  proc_proc
 467 #endif
 468 #endif
 469 #ifdef MPI
 470       include "mpif.h"
 471 #endif
 472       include 'COMMON.SETUP'
 473       include 'COMMON.IOUNITS'
 474       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 475       include 'COMMON.FFIELD'
 476       include 'COMMON.DERIV'
 477       include 'COMMON.INTERACT'
 478       include 'COMMON.SBRIDGE'
 479       include 'COMMON.CHAIN'
 480       include 'COMMON.VAR'
 481       include 'COMMON.CONTROL'
 482       include 'COMMON.TIME1'
 483       logical reduce
 484 #ifdef MPI
 485       if (nfgtasks.gt.1 .and. reduce) then
 486 #ifdef DEBUG
 487         write (iout,*) "energies before REDUCE"
 488         call enerprint(energia)
 489         call flush(iout)
 490 #endif
 491         do i=0,n_ene
 492           enebuff(i)=energia(i)
 493         enddo
 494         time00=MPI_Wtime()
 495         call MPI_Barrier(FG_COMM,IERR)
 496         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 497         time00=MPI_Wtime()
 498         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 499      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 500 #ifdef DEBUG
 501         write (iout,*) "energies after REDUCE"
 502         call enerprint(energia)
 503         call flush(iout)
 504 #endif
 505         time_Reduce=time_Reduce+MPI_Wtime()-time00
 506       endif
 507       if (fg_rank.eq.0) then
 508 #endif
 509       evdw=energia(1)
 510 #ifdef SCP14
 511       evdw2=energia(2)+energia(18)
 512       evdw2_14=energia(18)
 513 #else
 514       evdw2=energia(2)
 515 #endif
 516 #ifdef SPLITELE
 517       ees=energia(3)
 518       evdw1=energia(16)
 519 #else
 520       ees=energia(3)
 521       evdw1=0.0d0
 522 #endif
 523       ecorr=energia(4)
 524       ecorr5=energia(5)
 525       ecorr6=energia(6)
 526       eel_loc=energia(7)
 527       eello_turn3=energia(8)
 528       eello_turn4=energia(9)
 529       eturn6=energia(10)
 530       ebe=energia(11)
 531       escloc=energia(12)
 532       etors=energia(13)
 533       etors_d=energia(14)
 534       ehpb=energia(15)
 535       edihcnstr=energia(19)
 536       estr=energia(17)
 537       Uconst=energia(20)
 538       esccor=energia(21)
 539       eliptran=energia(22)
 540       Eafmforce=energia(23)
 541       ethetacnstr=energia(24)
 542       Etube=energia(25)
 543 #ifdef SPLITELE
 544       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 545      & +wang*ebe+wtor*etors+wscloc*escloc
 546      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 547      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 548      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 549      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 550      & +ethetacnstr+wtube*Etube
 551 #else
 552       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 553      & +wang*ebe+wtor*etors+wscloc*escloc
 554      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 555      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 556      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 557      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 558      & +Eafmforce
 559      & +ethetacnstr+wtube*Etube
 560 #endif
 561       energia(0)=etot
 562 c detecting NaNQ
 563 #ifdef ISNAN
 564 #ifdef AIX
 565       if (isnan(etot).ne.0) energia(0)=1.0d+99
 566 #else
 567       if (isnan(etot)) energia(0)=1.0d+99
 568 #endif
 569 #else
 570       i=0
 571 #ifdef WINPGI
 572       idumm=proc_proc(etot,i)
 573 #else
 574       call proc_proc(etot,i)
 575 #endif
 576       if(i.eq.1)energia(0)=1.0d+99
 577 #endif
 578 #ifdef MPI
 579       endif
 580 #endif
 581       return
 582       end
 583 c-------------------------------------------------------------------------------
 584       subroutine sum_gradient
 585       implicit real*8 (a-h,o-z)
 586       include 'DIMENSIONS'
 587 #ifndef ISNAN
 588       external proc_proc
 589 #ifdef WINPGI
 590 cMS$ATTRIBUTES C ::  proc_proc
 591 #endif
 592 #endif
 593 #ifdef MPI
 594       include 'mpif.h'
 595 #endif
 596       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 597      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 598      & ,gloc_scbuf(3,-1:maxres)
 599       include 'COMMON.SETUP'
 600       include 'COMMON.IOUNITS'
 601       include 'COMMON.FFIELD'
 602       include 'COMMON.DERIV'
 603       include 'COMMON.INTERACT'
 604       include 'COMMON.SBRIDGE'
 605       include 'COMMON.CHAIN'
 606       include 'COMMON.VAR'
 607       include 'COMMON.CONTROL'
 608       include 'COMMON.TIME1'
 609       include 'COMMON.MAXGRAD'
 610       include 'COMMON.SCCOR'
 611 #ifdef TIMING
 612       time01=MPI_Wtime()
 613 #endif
 614 #ifdef DEBUG
 615       write (iout,*) "sum_gradient gvdwc, gvdwx"
 616       do i=1,nres
 617         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 618      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 619       enddo
 620       call flush(iout)
 621 #endif
 622 #ifdef MPI
 623 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 624         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 625      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 626 #endif
 627 C
 628 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 629 C            in virtual-bond-vector coordinates
 630 C
 631 #ifdef DEBUG
 632 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 633 c      do i=1,nres-1
 634 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 635 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 636 c      enddo
 637 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 638 c      do i=1,nres-1
 639 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 640 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 641 c      enddo
 642       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 643       do i=1,nres
 644         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 645      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 646      &   g_corr5_loc(i)
 647       enddo
 648       call flush(iout)
 649 #endif
 650 #ifdef SPLITELE
 651       do i=0,nct
 652         do j=1,3
 653           gradbufc(j,i)=wsc*gvdwc(j,i)+
 654      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 655      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 656      &                wel_loc*gel_loc_long(j,i)+
 657      &                wcorr*gradcorr_long(j,i)+
 658      &                wcorr5*gradcorr5_long(j,i)+
 659      &                wcorr6*gradcorr6_long(j,i)+
 660      &                wturn6*gcorr6_turn_long(j,i)+
 661      &                wstrain*ghpbc(j,i)
 662      &                +wliptran*gliptranc(j,i)
 663      &                +gradafm(j,i)
 664      &                 +welec*gshieldc(j,i)
 665      &                 +wcorr*gshieldc_ec(j,i)
 666      &                 +wturn3*gshieldc_t3(j,i)
 667      &                 +wturn4*gshieldc_t4(j,i)
 668      &                 +wel_loc*gshieldc_ll(j,i)
 669      &                +wtube*gg_tube(j,i)
 670
 671
 672
 673         enddo
 674       enddo
 675       j=1
 676       i=0
 677       print *,"KUPA2",gradbufc(j,i),wsc*gvdwc(j,i),
 678      &                wscp*gvdwc_scp(j,i),gvdwc_scpp(j,i),
 679      &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 680      &                wel_loc*gel_loc_long(j,i),
 681      &                wcorr*gradcorr_long(j,i),
 682      &                wcorr5*gradcorr5_long(j,i),
 683      &                wcorr6*gradcorr6_long(j,i),
 684      &                wturn6*gcorr6_turn_long(j,i),
 685      &                wstrain*ghpbc(j,i)
 686      &                ,wliptran*gliptranc(j,i)
 687      &                ,gradafm(j,i)
 688      &                 ,welec*gshieldc(j,i)
 689      &                 ,wcorr*gshieldc_ec(j,i)
 690      &                 ,wturn3*gshieldc_t3(j,i)
 691      &                 ,wturn4*gshieldc_t4(j,i)
 692      &                 ,wel_loc*gshieldc_ll(j,i)
 693      &                ,wtube*gg_tube(j,i)
 694 #else
 695       do i=0,nct
 696         do j=1,3
 697           gradbufc(j,i)=wsc*gvdwc(j,i)+
 698      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 699      &                welec*gelc_long(j,i)+
 700      &                wbond*gradb(j,i)+
 701      &                wel_loc*gel_loc_long(j,i)+
 702      &                wcorr*gradcorr_long(j,i)+
 703      &                wcorr5*gradcorr5_long(j,i)+
 704      &                wcorr6*gradcorr6_long(j,i)+
 705      &                wturn6*gcorr6_turn_long(j,i)+
 706      &                wstrain*ghpbc(j,i)
 707      &                +wliptran*gliptranc(j,i)
 708      &                +gradafm(j,i)
 709      &                 +welec*gshieldc(j,i)
 710      &                 +wcorr*gshieldc_ec(j,i)
 711      &                 +wturn4*gshieldc_t4(j,i)
 712      &                 +wel_loc*gshieldc_ll(j,i)
 713      &                +wtube*gg_tube(j,i)
 714
 715
 716
 717         enddo
 718       enddo
 719 #endif
 720 #ifdef MPI
 721       if (nfgtasks.gt.1) then
 722       time00=MPI_Wtime()
 723 #ifdef DEBUG
 724       write (iout,*) "gradbufc before allreduce"
 725       do i=1,nres
 726         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 727       enddo
 728       call flush(iout)
 729 #endif
 730       do i=0,nres
 731         do j=1,3
 732           gradbufc_sum(j,i)=gradbufc(j,i)
 733         enddo
 734       enddo
 735 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 736 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 737 c      time_reduce=time_reduce+MPI_Wtime()-time00
 738 #ifdef DEBUG
 739 c      write (iout,*) "gradbufc_sum after allreduce"
 740 c      do i=1,nres
 741 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 742 c      enddo
 743 c      call flush(iout)
 744 #endif
 745 #ifdef TIMING
 746 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 747 #endif
 748       do i=0,nres
 749         do k=1,3
 750           gradbufc(k,i)=0.0d0
 751         enddo
 752       enddo
 753 #ifdef DEBUG
 754       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 755       write (iout,*) (i," jgrad_start",jgrad_start(i),
 756      &                  " jgrad_end  ",jgrad_end(i),
 757      &                  i=igrad_start,igrad_end)
 758 #endif
 759 c
 760 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 761 c do not parallelize this part.
 762 c
 763 c      do i=igrad_start,igrad_end
 764 c        do j=jgrad_start(i),jgrad_end(i)
 765 c          do k=1,3
 766 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 767 c          enddo
 768 c        enddo
 769 c      enddo
 770       do j=1,3
 771         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 772       enddo
 773       do i=nres-2,-1,-1
 774         do j=1,3
 775           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 776         enddo
 777       enddo
 778 #ifdef DEBUG
 779       write (iout,*) "gradbufc after summing"
 780       do i=1,nres
 781         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 782       enddo
 783       call flush(iout)
 784 #endif
 785       else
 786 #endif
 787 #ifdef DEBUG
 788       write (iout,*) "gradbufc"
 789       do i=1,nres
 790         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 791       enddo
 792       call flush(iout)
 793 #endif
 794       do i=-1,nres
 795         do j=1,3
 796           gradbufc_sum(j,i)=gradbufc(j,i)
 797           gradbufc(j,i)=0.0d0
 798         enddo
 799       enddo
 800       do j=1,3
 801         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 802       enddo
 803       do i=nres-2,-1,-1
 804         do j=1,3
 805           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 806         enddo
 807       enddo
 808 c      do i=nnt,nres-1
 809 c        do k=1,3
 810 c          gradbufc(k,i)=0.0d0
 811 c        enddo
 812 c        do j=i+1,nres
 813 c          do k=1,3
 814 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 815 c          enddo
 816 c        enddo
 817 c      enddo
 818 #ifdef DEBUG
 819       write (iout,*) "gradbufc after summing"
 820       do i=1,nres
 821         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 822       enddo
 823       call flush(iout)
 824 #endif
 825 #ifdef MPI
 826       endif
 827 #endif
 828       do k=1,3
 829         gradbufc(k,nres)=0.0d0
 830       enddo
 831       do i=-1,nct
 832         do j=1,3
 833 #ifdef SPLITELE
 834 C          print *,gradbufc(1,13)
 835 C          print *,welec*gelc(1,13)
 836 C          print *,wel_loc*gel_loc(1,13)
 837 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 838 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 839 C          print *,wel_loc*gel_loc_long(1,13)
 840 C          print *,gradafm(1,13),"AFM"
 841           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 842      &                wel_loc*gel_loc(j,i)+
 843      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 844      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 845      &                wel_loc*gel_loc_long(j,i)+
 846      &                wcorr*gradcorr_long(j,i)+
 847      &                wcorr5*gradcorr5_long(j,i)+
 848      &                wcorr6*gradcorr6_long(j,i)+
 849      &                wturn6*gcorr6_turn_long(j,i))+
 850      &                wbond*gradb(j,i)+
 851      &                wcorr*gradcorr(j,i)+
 852      &                wturn3*gcorr3_turn(j,i)+
 853      &                wturn4*gcorr4_turn(j,i)+
 854      &                wcorr5*gradcorr5(j,i)+
 855      &                wcorr6*gradcorr6(j,i)+
 856      &                wturn6*gcorr6_turn(j,i)+
 857      &                wsccor*gsccorc(j,i)
 858      &               +wscloc*gscloc(j,i)
 859      &               +wliptran*gliptranc(j,i)
 860      &                +gradafm(j,i)
 861      &                 +welec*gshieldc(j,i)
 862      &                 +welec*gshieldc_loc(j,i)
 863      &                 +wcorr*gshieldc_ec(j,i)
 864      &                 +wcorr*gshieldc_loc_ec(j,i)
 865      &                 +wturn3*gshieldc_t3(j,i)
 866      &                 +wturn3*gshieldc_loc_t3(j,i)
 867      &                 +wturn4*gshieldc_t4(j,i)
 868      &                 +wturn4*gshieldc_loc_t4(j,i)
 869      &                 +wel_loc*gshieldc_ll(j,i)
 870      &                 +wel_loc*gshieldc_loc_ll(j,i)
 871      &                +wtube*gg_tube(j,i)
 872
 873 #else
 874           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 875      &                wel_loc*gel_loc(j,i)+
 876      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 877      &                welec*gelc_long(j,i)+
 878      &                wel_loc*gel_loc_long(j,i)+
 879      &                wcorr*gcorr_long(j,i)+
 880      &                wcorr5*gradcorr5_long(j,i)+
 881      &                wcorr6*gradcorr6_long(j,i)+
 882      &                wturn6*gcorr6_turn_long(j,i))+
 883      &                wbond*gradb(j,i)+
 884      &                wcorr*gradcorr(j,i)+
 885      &                wturn3*gcorr3_turn(j,i)+
 886      &                wturn4*gcorr4_turn(j,i)+
 887      &                wcorr5*gradcorr5(j,i)+
 888      &                wcorr6*gradcorr6(j,i)+
 889      &                wturn6*gcorr6_turn(j,i)+
 890      &                wsccor*gsccorc(j,i)
 891      &               +wscloc*gscloc(j,i)
 892      &               +wliptran*gliptranc(j,i)
 893      &                +gradafm(j,i)
 894      &                 +welec*gshieldc(j,i)
 895      &                 +welec*gshieldc_loc(j,i)
 896      &                 +wcorr*gshieldc_ec(j,i)
 897      &                 +wcorr*gshieldc_loc_ec(j,i)
 898      &                 +wturn3*gshieldc_t3(j,i)
 899      &                 +wturn3*gshieldc_loc_t3(j,i)
 900      &                 +wturn4*gshieldc_t4(j,i)
 901      &                 +wturn4*gshieldc_loc_t4(j,i)
 902      &                 +wel_loc*gshieldc_ll(j,i)
 903      &                 +wel_loc*gshieldc_loc_ll(j,i)
 904      &                +wtube*gg_tube(j,i)
 905
 906
 907 #endif
 908           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 909      &                  wbond*gradbx(j,i)+
 910      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 911      &                  wsccor*gsccorx(j,i)
 912      &                 +wscloc*gsclocx(j,i)
 913      &                 +wliptran*gliptranx(j,i)
 914      &                 +welec*gshieldx(j,i)
 915      &                 +wcorr*gshieldx_ec(j,i)
 916      &                 +wturn3*gshieldx_t3(j,i)
 917      &                 +wturn4*gshieldx_t4(j,i)
 918      &                 +wel_loc*gshieldx_ll(j,i)
 919      &                 +wtube*gg_tube_sc(j,i)
 920
 921
 922
 923         enddo
 924       enddo
 925 C       i=0
 926 C       j=1
 927 C       print *,"KUPA",    gradbufc(j,i),welec*gelc(j,i),
 928 C     &                wel_loc*gel_loc(j,i),
 929 C     &                0.5d0*wscp*gvdwc_scpp(j,i),
 930 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 931 C     &                wel_loc*gel_loc_long(j,i),
 932 C     &                wcorr*gradcorr_long(j,i),
 933 C     &                wcorr5*gradcorr5_long(j,i),
 934 C     &                wcorr6*gradcorr6_long(j,i),
 935 C     &                wturn6*gcorr6_turn_long(j,i),
 936 C     &                wbond*gradb(j,i),
 937 C     &                wcorr*gradcorr(j,i),
 938 C     &                wturn3*gcorr3_turn(j,i),
 939 C     &                wturn4*gcorr4_turn(j,i),
 940 C     &                wcorr5*gradcorr5(j,i),
 941 C     &                wcorr6*gradcorr6(j,i),
 942 C     &                wturn6*gcorr6_turn(j,i),
 943 C     &                wsccor*gsccorc(j,i)
 944 C     &               ,wscloc*gscloc(j,i)
 945 C     &               ,wliptran*gliptranc(j,i)
 946 C     &                ,gradafm(j,i)
 947 C     &                 +welec*gshieldc(j,i)
 948 C     &                 +welec*gshieldc_loc(j,i)
 949 C     &                 +wcorr*gshieldc_ec(j,i)
 950 C     &                 +wcorr*gshieldc_loc_ec(j,i)
 951 C     &                 +wturn3*gshieldc_t3(j,i)
 952 C     &                 +wturn3*gshieldc_loc_t3(j,i)
 953 C     &                 +wturn4*gshieldc_t4(j,i)
 954 C     &                 ,wturn4*gshieldc_loc_t4(j,i)
 955 C     &                 ,wel_loc*gshieldc_ll(j,i)
 956 C     &                 ,wel_loc*gshieldc_loc_ll(j,i)
 957 C     &                ,wtube*gg_tube(j,i)
 958
 959 C      print *,gg_tube(1,0),"TU3"
 960 #ifdef DEBUG
 961       write (iout,*) "gloc before adding corr"
 962       do i=1,4*nres
 963         write (iout,*) i,gloc(i,icg)
 964       enddo
 965 #endif
 966       do i=1,nres-3
 967         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 968      &   +wcorr5*g_corr5_loc(i)
 969      &   +wcorr6*g_corr6_loc(i)
 970      &   +wturn4*gel_loc_turn4(i)
 971      &   +wturn3*gel_loc_turn3(i)
 972      &   +wturn6*gel_loc_turn6(i)
 973      &   +wel_loc*gel_loc_loc(i)
 974       enddo
 975 #ifdef DEBUG
 976       write (iout,*) "gloc after adding corr"
 977       do i=1,4*nres
 978         write (iout,*) i,gloc(i,icg)
 979       enddo
 980 #endif
 981 #ifdef MPI
 982       if (nfgtasks.gt.1) then
 983         do j=1,3
 984           do i=1,nres
 985             gradbufc(j,i)=gradc(j,i,icg)
 986             gradbufx(j,i)=gradx(j,i,icg)
 987           enddo
 988         enddo
 989         do i=1,4*nres
 990           glocbuf(i)=gloc(i,icg)
 991         enddo
 992 c#define DEBUG
 993 #ifdef DEBUG
 994       write (iout,*) "gloc_sc before reduce"
 995       do i=1,nres
 996        do j=1,1
 997         write (iout,*) i,j,gloc_sc(j,i,icg)
 998        enddo
 999       enddo
1000 #endif
1001 c#undef DEBUG
1002         do i=1,nres
1003          do j=1,3
1004           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1005          enddo
1006         enddo
1007         time00=MPI_Wtime()
1008         call MPI_Barrier(FG_COMM,IERR)
1009         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1010         time00=MPI_Wtime()
1011         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,
1012      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1013         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1014      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1015         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1016      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1017         time_reduce=time_reduce+MPI_Wtime()-time00
1018         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1019      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1020         time_reduce=time_reduce+MPI_Wtime()-time00
1021 c#define DEBUG
1022 #ifdef DEBUG
1023       write (iout,*) "gloc_sc after reduce"
1024       do i=1,nres
1025        do j=1,1
1026         write (iout,*) i,j,gloc_sc(j,i,icg)
1027        enddo
1028       enddo
1029 #endif
1030 c#undef DEBUG
1031 #ifdef DEBUG
1032       write (iout,*) "gloc after reduce"
1033       do i=1,4*nres
1034         write (iout,*) i,gloc(i,icg)
1035       enddo
1036 #endif
1037       endif
1038 #endif
1039       if (gnorm_check) then
1040 c
1041 c Compute the maximum elements of the gradient
1042 c
1043       gvdwc_max=0.0d0
1044       gvdwc_scp_max=0.0d0
1045       gelc_max=0.0d0
1046       gvdwpp_max=0.0d0
1047       gradb_max=0.0d0
1048       ghpbc_max=0.0d0
1049       gradcorr_max=0.0d0
1050       gel_loc_max=0.0d0
1051       gcorr3_turn_max=0.0d0
1052       gcorr4_turn_max=0.0d0
1053       gradcorr5_max=0.0d0
1054       gradcorr6_max=0.0d0
1055       gcorr6_turn_max=0.0d0
1056       gsccorc_max=0.0d0
1057       gscloc_max=0.0d0
1058       gvdwx_max=0.0d0
1059       gradx_scp_max=0.0d0
1060       ghpbx_max=0.0d0
1061       gradxorr_max=0.0d0
1062       gsccorx_max=0.0d0
1063       gsclocx_max=0.0d0
1064       do i=1,nct
1065         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1066         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1067         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1068         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1069      &   gvdwc_scp_max=gvdwc_scp_norm
1070         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1071         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1072         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1073         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1074         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1075         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1076         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1077         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1078         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1079         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1080         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1081         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1082         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1083      &    gcorr3_turn(1,i)))
1084         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1085      &    gcorr3_turn_max=gcorr3_turn_norm
1086         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1087      &    gcorr4_turn(1,i)))
1088         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1089      &    gcorr4_turn_max=gcorr4_turn_norm
1090         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1091         if (gradcorr5_norm.gt.gradcorr5_max)
1092      &    gradcorr5_max=gradcorr5_norm
1093         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1094         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1095         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1096      &    gcorr6_turn(1,i)))
1097         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1098      &    gcorr6_turn_max=gcorr6_turn_norm
1099         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1100         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1101         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1102         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1103         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1104         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1105         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1106         if (gradx_scp_norm.gt.gradx_scp_max)
1107      &    gradx_scp_max=gradx_scp_norm
1108         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1109         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1110         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1111         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1112         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1113         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1114         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1115         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1116       enddo
1117       if (gradout) then
1118 #ifdef AIX
1119         open(istat,file=statname,position="append")
1120 #else
1121         open(istat,file=statname,access="append")
1122 #endif
1123         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1124      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1125      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1126      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1127      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1128      &     gsccorx_max,gsclocx_max
1129         close(istat)
1130         if (gvdwc_max.gt.1.0d4) then
1131           write (iout,*) "gvdwc gvdwx gradb gradbx"
1132           do i=nnt,nct
1133             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1134      &        gradb(j,i),gradbx(j,i),j=1,3)
1135           enddo
1136           call pdbout(0.0d0,'cipiszcze',iout)
1137           call flush(iout)
1138         endif
1139       endif
1140       endif
1141 #ifdef DEBUG
1142       write (iout,*) "gradc gradx gloc"
1143       do i=1,nres
1144         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1145      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1146       enddo
1147 #endif
1148 #ifdef TIMING
1149       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1150 #endif
1151       return
1152       end
1153 c-------------------------------------------------------------------------------
1154       subroutine rescale_weights(t_bath)
1155       implicit real*8 (a-h,o-z)
1156       include 'DIMENSIONS'
1157       include 'COMMON.IOUNITS'
1158       include 'COMMON.FFIELD'
1159       include 'COMMON.SBRIDGE'
1160       include 'COMMON.CONTROL'
1161       double precision kfac /2.4d0/
1162       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1163 c      facT=temp0/t_bath
1164 c      facT=2*temp0/(t_bath+temp0)
1165       if (rescale_mode.eq.0) then
1166         facT=1.0d0
1167         facT2=1.0d0
1168         facT3=1.0d0
1169         facT4=1.0d0
1170         facT5=1.0d0
1171       else if (rescale_mode.eq.1) then
1172         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1173         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1174         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1175         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1176         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1177       else if (rescale_mode.eq.2) then
1178         x=t_bath/temp0
1179         x2=x*x
1180         x3=x2*x
1181         x4=x3*x
1182         x5=x4*x
1183         facT=licznik/dlog(dexp(x)+dexp(-x))
1184         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1185         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1186         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1187         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1188       else
1189         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1190         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1191 #ifdef MPI
1192        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1193 #endif
1194        stop 555
1195       endif
1196       if (shield_mode.gt.0) then
1197        wscp=weights(2)*fact
1198        wsc=weights(1)*fact
1199        wvdwpp=weights(16)*fact
1200       endif
1201       welec=weights(3)*fact
1202       wcorr=weights(4)*fact3
1203       wcorr5=weights(5)*fact4
1204       wcorr6=weights(6)*fact5
1205       wel_loc=weights(7)*fact2
1206       wturn3=weights(8)*fact2
1207       wturn4=weights(9)*fact3
1208       wturn6=weights(10)*fact5
1209       wtor=weights(13)*fact
1210       wtor_d=weights(14)*fact2
1211       wsccor=weights(21)*fact
1212
1213       return
1214       end
1215 C------------------------------------------------------------------------
1216       subroutine enerprint(energia)
1217       implicit real*8 (a-h,o-z)
1218       include 'DIMENSIONS'
1219       include 'COMMON.IOUNITS'
1220       include 'COMMON.FFIELD'
1221       include 'COMMON.SBRIDGE'
1222       include 'COMMON.MD'
1223       double precision energia(0:n_ene)
1224       etot=energia(0)
1225       evdw=energia(1)
1226       evdw2=energia(2)
1227 #ifdef SCP14
1228       evdw2=energia(2)+energia(18)
1229 #else
1230       evdw2=energia(2)
1231 #endif
1232       ees=energia(3)
1233 #ifdef SPLITELE
1234       evdw1=energia(16)
1235 #endif
1236       ecorr=energia(4)
1237       ecorr5=energia(5)
1238       ecorr6=energia(6)
1239       eel_loc=energia(7)
1240       eello_turn3=energia(8)
1241       eello_turn4=energia(9)
1242       eello_turn6=energia(10)
1243       ebe=energia(11)
1244       escloc=energia(12)
1245       etors=energia(13)
1246       etors_d=energia(14)
1247       ehpb=energia(15)
1248       edihcnstr=energia(19)
1249       estr=energia(17)
1250       Uconst=energia(20)
1251       esccor=energia(21)
1252       eliptran=energia(22)
1253       Eafmforce=energia(23)
1254       ethetacnstr=energia(24)
1255       etube=energia(25)
1256 #ifdef SPLITELE
1257       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1258      &  estr,wbond,ebe,wang,
1259      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1260      &  ecorr,wcorr,
1261      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1262      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1263      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1264      &  etube,wtube,
1265      &  etot
1266    10 format (/'Virtual-chain energies:'//
1267      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1268      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1269      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1270      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1271      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1272      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1273      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1274      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1275      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1276      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1277      & ' (SS bridges & dist. cnstr.)'/
1278      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1279      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1280      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1281      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1282      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1283      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1284      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1285      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1286      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1287      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1288      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1289      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1290      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1291      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1292      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1293      & 'ETOT=  ',1pE16.6,' (total)')
1294
1295 #else
1296       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1297      &  estr,wbond,ebe,wang,
1298      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1299      &  ecorr,wcorr,
1300      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1301      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1302      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1303      &  etube,wtube,
1304      &  etot
1305    10 format (/'Virtual-chain energies:'//
1306      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1307      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1308      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1309      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1310      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1311      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1312      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1313      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1314      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1315      & ' (SS bridges & dist. cnstr.)'/
1316      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1317      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1318      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1319      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1320      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1321      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1322      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1323      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1324      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1325      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1326      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1327      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1328      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1329      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1330      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1331      & 'ETOT=  ',1pE16.6,' (total)')
1332 #endif
1333       return
1334       end
1335 C-----------------------------------------------------------------------
1336       subroutine elj(evdw)
1337 C
1338 C This subroutine calculates the interaction energy of nonbonded side chains
1339 C assuming the LJ potential of interaction.
1340 C
1341       implicit real*8 (a-h,o-z)
1342       include 'DIMENSIONS'
1343       parameter (accur=1.0d-10)
1344       include 'COMMON.GEO'
1345       include 'COMMON.VAR'
1346       include 'COMMON.LOCAL'
1347       include 'COMMON.CHAIN'
1348       include 'COMMON.DERIV'
1349       include 'COMMON.INTERACT'
1350       include 'COMMON.TORSION'
1351       include 'COMMON.SBRIDGE'
1352       include 'COMMON.NAMES'
1353       include 'COMMON.IOUNITS'
1354       include 'COMMON.CONTACTS'
1355       dimension gg(3)
1356 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1357       evdw=0.0D0
1358       do i=iatsc_s,iatsc_e
1359         itypi=iabs(itype(i))
1360         if (itypi.eq.ntyp1) cycle
1361         itypi1=iabs(itype(i+1))
1362         xi=c(1,nres+i)
1363         yi=c(2,nres+i)
1364         zi=c(3,nres+i)
1365 C Change 12/1/95
1366         num_conti=0
1367 C
1368 C Calculate SC interaction energy.
1369 C
1370         do iint=1,nint_gr(i)
1371 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1372 cd   &                  'iend=',iend(i,iint)
1373           do j=istart(i,iint),iend(i,iint)
1374             itypj=iabs(itype(j))
1375             if (itypj.eq.ntyp1) cycle
1376             xj=c(1,nres+j)-xi
1377             yj=c(2,nres+j)-yi
1378             zj=c(3,nres+j)-zi
1379 C Change 12/1/95 to calculate four-body interactions
1380             rij=xj*xj+yj*yj+zj*zj
1381             rrij=1.0D0/rij
1382 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1383             eps0ij=eps(itypi,itypj)
1384             fac=rrij**expon2
1385 C have you changed here?
1386             e1=fac*fac*aa
1387             e2=fac*bb
1388             evdwij=e1+e2
1389 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1390 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1391 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1392 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1393 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1394 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1395             evdw=evdw+evdwij
1396 C
1397 C Calculate the components of the gradient in DC and X
1398 C
1399             fac=-rrij*(e1+evdwij)
1400             gg(1)=xj*fac
1401             gg(2)=yj*fac
1402             gg(3)=zj*fac
1403             do k=1,3
1404               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1405               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1406               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1407               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1408             enddo
1409 cgrad            do k=i,j-1
1410 cgrad              do l=1,3
1411 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1412 cgrad              enddo
1413 cgrad            enddo
1414 C
1415 C 12/1/95, revised on 5/20/97
1416 C
1417 C Calculate the contact function. The ith column of the array JCONT will
1418 C contain the numbers of atoms that make contacts with the atom I (of numbers
1419 C greater than I). The arrays FACONT and GACONT will contain the values of
1420 C the contact function and its derivative.
1421 C
1422 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1423 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1424 C Uncomment next line, if the correlation interactions are contact function only
1425             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1426               rij=dsqrt(rij)
1427               sigij=sigma(itypi,itypj)
1428               r0ij=rs0(itypi,itypj)
1429 C
1430 C Check whether the SC's are not too far to make a contact.
1431 C
1432               rcut=1.5d0*r0ij
1433               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1434 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1435 C
1436               if (fcont.gt.0.0D0) then
1437 C If the SC-SC distance if close to sigma, apply spline.
1438 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1439 cAdam &             fcont1,fprimcont1)
1440 cAdam           fcont1=1.0d0-fcont1
1441 cAdam           if (fcont1.gt.0.0d0) then
1442 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1443 cAdam             fcont=fcont*fcont1
1444 cAdam           endif
1445 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1446 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1447 cga             do k=1,3
1448 cga               gg(k)=gg(k)*eps0ij
1449 cga             enddo
1450 cga             eps0ij=-evdwij*eps0ij
1451 C Uncomment for AL's type of SC correlation interactions.
1452 cadam           eps0ij=-evdwij
1453                 num_conti=num_conti+1
1454                 jcont(num_conti,i)=j
1455                 facont(num_conti,i)=fcont*eps0ij
1456                 fprimcont=eps0ij*fprimcont/rij
1457                 fcont=expon*fcont
1458 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1459 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1460 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1461 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1462                 gacont(1,num_conti,i)=-fprimcont*xj
1463                 gacont(2,num_conti,i)=-fprimcont*yj
1464                 gacont(3,num_conti,i)=-fprimcont*zj
1465 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1466 cd              write (iout,'(2i3,3f10.5)')
1467 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1468               endif
1469             endif
1470           enddo      ! j
1471         enddo        ! iint
1472 C Change 12/1/95
1473         num_cont(i)=num_conti
1474       enddo          ! i
1475       do i=1,nct
1476         do j=1,3
1477           gvdwc(j,i)=expon*gvdwc(j,i)
1478           gvdwx(j,i)=expon*gvdwx(j,i)
1479         enddo
1480       enddo
1481 C******************************************************************************
1482 C
1483 C                              N O T E !!!
1484 C
1485 C To save time, the factor of EXPON has been extracted from ALL components
1486 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1487 C use!
1488 C
1489 C******************************************************************************
1490       return
1491       end
1492 C-----------------------------------------------------------------------------
1493       subroutine eljk(evdw)
1494 C
1495 C This subroutine calculates the interaction energy of nonbonded side chains
1496 C assuming the LJK potential of interaction.
1497 C
1498       implicit real*8 (a-h,o-z)
1499       include 'DIMENSIONS'
1500       include 'COMMON.GEO'
1501       include 'COMMON.VAR'
1502       include 'COMMON.LOCAL'
1503       include 'COMMON.CHAIN'
1504       include 'COMMON.DERIV'
1505       include 'COMMON.INTERACT'
1506       include 'COMMON.IOUNITS'
1507       include 'COMMON.NAMES'
1508       dimension gg(3)
1509       logical scheck
1510 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1511       evdw=0.0D0
1512       do i=iatsc_s,iatsc_e
1513         itypi=iabs(itype(i))
1514         if (itypi.eq.ntyp1) cycle
1515         itypi1=iabs(itype(i+1))
1516         xi=c(1,nres+i)
1517         yi=c(2,nres+i)
1518         zi=c(3,nres+i)
1519 C
1520 C Calculate SC interaction energy.
1521 C
1522         do iint=1,nint_gr(i)
1523           do j=istart(i,iint),iend(i,iint)
1524             itypj=iabs(itype(j))
1525             if (itypj.eq.ntyp1) cycle
1526             xj=c(1,nres+j)-xi
1527             yj=c(2,nres+j)-yi
1528             zj=c(3,nres+j)-zi
1529             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1530             fac_augm=rrij**expon
1531             e_augm=augm(itypi,itypj)*fac_augm
1532             r_inv_ij=dsqrt(rrij)
1533             rij=1.0D0/r_inv_ij
1534             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1535             fac=r_shift_inv**expon
1536 C have you changed here?
1537             e1=fac*fac*aa
1538             e2=fac*bb
1539             evdwij=e_augm+e1+e2
1540 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1541 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1542 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1543 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1544 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1545 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1546 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1547             evdw=evdw+evdwij
1548 C
1549 C Calculate the components of the gradient in DC and X
1550 C
1551             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1552             gg(1)=xj*fac
1553             gg(2)=yj*fac
1554             gg(3)=zj*fac
1555             do k=1,3
1556               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1557               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1558               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1559               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1560             enddo
1561 cgrad            do k=i,j-1
1562 cgrad              do l=1,3
1563 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1564 cgrad              enddo
1565 cgrad            enddo
1566           enddo      ! j
1567         enddo        ! iint
1568       enddo          ! i
1569       do i=1,nct
1570         do j=1,3
1571           gvdwc(j,i)=expon*gvdwc(j,i)
1572           gvdwx(j,i)=expon*gvdwx(j,i)
1573         enddo
1574       enddo
1575       return
1576       end
1577 C-----------------------------------------------------------------------------
1578       subroutine ebp(evdw)
1579 C
1580 C This subroutine calculates the interaction energy of nonbonded side chains
1581 C assuming the Berne-Pechukas potential of interaction.
1582 C
1583       implicit real*8 (a-h,o-z)
1584       include 'DIMENSIONS'
1585       include 'COMMON.GEO'
1586       include 'COMMON.VAR'
1587       include 'COMMON.LOCAL'
1588       include 'COMMON.CHAIN'
1589       include 'COMMON.DERIV'
1590       include 'COMMON.NAMES'
1591       include 'COMMON.INTERACT'
1592       include 'COMMON.IOUNITS'
1593       include 'COMMON.CALC'
1594       common /srutu/ icall
1595 c     double precision rrsave(maxdim)
1596       logical lprn
1597       evdw=0.0D0
1598 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1599       evdw=0.0D0
1600 c     if (icall.eq.0) then
1601 c       lprn=.true.
1602 c     else
1603         lprn=.false.
1604 c     endif
1605       ind=0
1606       do i=iatsc_s,iatsc_e
1607         itypi=iabs(itype(i))
1608         if (itypi.eq.ntyp1) cycle
1609         itypi1=iabs(itype(i+1))
1610         xi=c(1,nres+i)
1611         yi=c(2,nres+i)
1612         zi=c(3,nres+i)
1613         dxi=dc_norm(1,nres+i)
1614         dyi=dc_norm(2,nres+i)
1615         dzi=dc_norm(3,nres+i)
1616 c        dsci_inv=dsc_inv(itypi)
1617         dsci_inv=vbld_inv(i+nres)
1618 C
1619 C Calculate SC interaction energy.
1620 C
1621         do iint=1,nint_gr(i)
1622           do j=istart(i,iint),iend(i,iint)
1623             ind=ind+1
1624             itypj=iabs(itype(j))
1625             if (itypj.eq.ntyp1) cycle
1626 c            dscj_inv=dsc_inv(itypj)
1627             dscj_inv=vbld_inv(j+nres)
1628             chi1=chi(itypi,itypj)
1629             chi2=chi(itypj,itypi)
1630             chi12=chi1*chi2
1631             chip1=chip(itypi)
1632             chip2=chip(itypj)
1633             chip12=chip1*chip2
1634             alf1=alp(itypi)
1635             alf2=alp(itypj)
1636             alf12=0.5D0*(alf1+alf2)
1637 C For diagnostics only!!!
1638 c           chi1=0.0D0
1639 c           chi2=0.0D0
1640 c           chi12=0.0D0
1641 c           chip1=0.0D0
1642 c           chip2=0.0D0
1643 c           chip12=0.0D0
1644 c           alf1=0.0D0
1645 c           alf2=0.0D0
1646 c           alf12=0.0D0
1647             xj=c(1,nres+j)-xi
1648             yj=c(2,nres+j)-yi
1649             zj=c(3,nres+j)-zi
1650             dxj=dc_norm(1,nres+j)
1651             dyj=dc_norm(2,nres+j)
1652             dzj=dc_norm(3,nres+j)
1653             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1654 cd          if (icall.eq.0) then
1655 cd            rrsave(ind)=rrij
1656 cd          else
1657 cd            rrij=rrsave(ind)
1658 cd          endif
1659             rij=dsqrt(rrij)
1660 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1661             call sc_angular
1662 C Calculate whole angle-dependent part of epsilon and contributions
1663 C to its derivatives
1664 C have you changed here?
1665             fac=(rrij*sigsq)**expon2
1666             e1=fac*fac*aa
1667             e2=fac*bb
1668             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1669             eps2der=evdwij*eps3rt
1670             eps3der=evdwij*eps2rt
1671             evdwij=evdwij*eps2rt*eps3rt
1672             evdw=evdw+evdwij
1673             if (lprn) then
1674             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1675             epsi=bb**2/aa
1676 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1677 cd     &        restyp(itypi),i,restyp(itypj),j,
1678 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1679 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1680 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1681 cd     &        evdwij
1682             endif
1683 C Calculate gradient components.
1684             e1=e1*eps1*eps2rt**2*eps3rt**2
1685             fac=-expon*(e1+evdwij)
1686             sigder=fac/sigsq
1687             fac=rrij*fac
1688 C Calculate radial part of the gradient
1689             gg(1)=xj*fac
1690             gg(2)=yj*fac
1691             gg(3)=zj*fac
1692 C Calculate the angular part of the gradient and sum add the contributions
1693 C to the appropriate components of the Cartesian gradient.
1694             call sc_grad
1695           enddo      ! j
1696         enddo        ! iint
1697       enddo          ! i
1698 c     stop
1699       return
1700       end
1701 C-----------------------------------------------------------------------------
1702       subroutine egb(evdw)
1703 C
1704 C This subroutine calculates the interaction energy of nonbonded side chains
1705 C assuming the Gay-Berne potential of interaction.
1706 C
1707       implicit real*8 (a-h,o-z)
1708       include 'DIMENSIONS'
1709       include 'COMMON.GEO'
1710       include 'COMMON.VAR'
1711       include 'COMMON.LOCAL'
1712       include 'COMMON.CHAIN'
1713       include 'COMMON.DERIV'
1714       include 'COMMON.NAMES'
1715       include 'COMMON.INTERACT'
1716       include 'COMMON.IOUNITS'
1717       include 'COMMON.CALC'
1718       include 'COMMON.CONTROL'
1719       include 'COMMON.SPLITELE'
1720       include 'COMMON.SBRIDGE'
1721       logical lprn
1722       integer xshift,yshift,zshift
1723
1724       evdw=0.0D0
1725 ccccc      energy_dec=.false.
1726 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1727       evdw=0.0D0
1728       lprn=.false.
1729 c     if (icall.eq.0) lprn=.false.
1730       ind=0
1731 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1732 C we have the original box)
1733 C      do xshift=-1,1
1734 C      do yshift=-1,1
1735 C      do zshift=-1,1
1736       do i=iatsc_s,iatsc_e
1737         itypi=iabs(itype(i))
1738         if (itypi.eq.ntyp1) cycle
1739         itypi1=iabs(itype(i+1))
1740         xi=c(1,nres+i)
1741         yi=c(2,nres+i)
1742         zi=c(3,nres+i)
1743 C Return atom into box, boxxsize is size of box in x dimension
1744 c  134   continue
1745 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1746 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1747 C Condition for being inside the proper box
1748 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1749 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1750 c        go to 134
1751 c        endif
1752 c  135   continue
1753 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1754 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1755 C Condition for being inside the proper box
1756 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1757 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1758 c        go to 135
1759 c        endif
1760 c  136   continue
1761 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1762 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1763 C Condition for being inside the proper box
1764 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1765 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1766 c        go to 136
1767 c        endif
1768           xi=mod(xi,boxxsize)
1769           if (xi.lt.0) xi=xi+boxxsize
1770           yi=mod(yi,boxysize)
1771           if (yi.lt.0) yi=yi+boxysize
1772           zi=mod(zi,boxzsize)
1773           if (zi.lt.0) zi=zi+boxzsize
1774 C define scaling factor for lipids
1775
1776 C        if (positi.le.0) positi=positi+boxzsize
1777 C        print *,i
1778 C first for peptide groups
1779 c for each residue check if it is in lipid or lipid water border area
1780        if ((zi.gt.bordlipbot)
1781      &.and.(zi.lt.bordliptop)) then
1782 C the energy transfer exist
1783         if (zi.lt.buflipbot) then
1784 C what fraction I am in
1785          fracinbuf=1.0d0-
1786      &        ((zi-bordlipbot)/lipbufthick)
1787 C lipbufthick is thickenes of lipid buffore
1788          sslipi=sscalelip(fracinbuf)
1789          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1790         elseif (zi.gt.bufliptop) then
1791          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1792          sslipi=sscalelip(fracinbuf)
1793          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1794         else
1795          sslipi=1.0d0
1796          ssgradlipi=0.0
1797         endif
1798        else
1799          sslipi=0.0d0
1800          ssgradlipi=0.0
1801        endif
1802
1803 C          xi=xi+xshift*boxxsize
1804 C          yi=yi+yshift*boxysize
1805 C          zi=zi+zshift*boxzsize
1806
1807         dxi=dc_norm(1,nres+i)
1808         dyi=dc_norm(2,nres+i)
1809         dzi=dc_norm(3,nres+i)
1810 c        dsci_inv=dsc_inv(itypi)
1811         dsci_inv=vbld_inv(i+nres)
1812 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1813 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1814 C
1815 C Calculate SC interaction energy.
1816 C
1817         do iint=1,nint_gr(i)
1818           do j=istart(i,iint),iend(i,iint)
1819             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1820
1821 c              write(iout,*) "PRZED ZWYKLE", evdwij
1822               call dyn_ssbond_ene(i,j,evdwij)
1823 c              write(iout,*) "PO ZWYKLE", evdwij
1824
1825               evdw=evdw+evdwij
1826               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1827      &                        'evdw',i,j,evdwij,' ss'
1828 C triple bond artifac removal
1829              do k=j+1,iend(i,iint)
1830 C search over all next residues
1831               if (dyn_ss_mask(k)) then
1832 C check if they are cysteins
1833 C              write(iout,*) 'k=',k
1834
1835 c              write(iout,*) "PRZED TRI", evdwij
1836                evdwij_przed_tri=evdwij
1837               call triple_ssbond_ene(i,j,k,evdwij)
1838 c               if(evdwij_przed_tri.ne.evdwij) then
1839 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1840 c               endif
1841
1842 c              write(iout,*) "PO TRI", evdwij
1843 C call the energy function that removes the artifical triple disulfide
1844 C bond the soubroutine is located in ssMD.F
1845               evdw=evdw+evdwij
1846               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1847      &                        'evdw',i,j,evdwij,'tss'
1848               endif!dyn_ss_mask(k)
1849              enddo! k
1850             ELSE
1851             ind=ind+1
1852             itypj=iabs(itype(j))
1853             if (itypj.eq.ntyp1) cycle
1854 c            dscj_inv=dsc_inv(itypj)
1855             dscj_inv=vbld_inv(j+nres)
1856 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1857 c     &       1.0d0/vbld(j+nres)
1858 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1859             sig0ij=sigma(itypi,itypj)
1860             chi1=chi(itypi,itypj)
1861             chi2=chi(itypj,itypi)
1862             chi12=chi1*chi2
1863             chip1=chip(itypi)
1864             chip2=chip(itypj)
1865             chip12=chip1*chip2
1866             alf1=alp(itypi)
1867             alf2=alp(itypj)
1868             alf12=0.5D0*(alf1+alf2)
1869 C For diagnostics only!!!
1870 c           chi1=0.0D0
1871 c           chi2=0.0D0
1872 c           chi12=0.0D0
1873 c           chip1=0.0D0
1874 c           chip2=0.0D0
1875 c           chip12=0.0D0
1876 c           alf1=0.0D0
1877 c           alf2=0.0D0
1878 c           alf12=0.0D0
1879             xj=c(1,nres+j)
1880             yj=c(2,nres+j)
1881             zj=c(3,nres+j)
1882 C Return atom J into box the original box
1883 c  137   continue
1884 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1885 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1886 C Condition for being inside the proper box
1887 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1888 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1889 c        go to 137
1890 c        endif
1891 c  138   continue
1892 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1893 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1894 C Condition for being inside the proper box
1895 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1896 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1897 c        go to 138
1898 c        endif
1899 c  139   continue
1900 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1901 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1902 C Condition for being inside the proper box
1903 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1904 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1905 c        go to 139
1906 c        endif
1907           xj=mod(xj,boxxsize)
1908           if (xj.lt.0) xj=xj+boxxsize
1909           yj=mod(yj,boxysize)
1910           if (yj.lt.0) yj=yj+boxysize
1911           zj=mod(zj,boxzsize)
1912           if (zj.lt.0) zj=zj+boxzsize
1913        if ((zj.gt.bordlipbot)
1914      &.and.(zj.lt.bordliptop)) then
1915 C the energy transfer exist
1916         if (zj.lt.buflipbot) then
1917 C what fraction I am in
1918          fracinbuf=1.0d0-
1919      &        ((zj-bordlipbot)/lipbufthick)
1920 C lipbufthick is thickenes of lipid buffore
1921          sslipj=sscalelip(fracinbuf)
1922          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1923         elseif (zj.gt.bufliptop) then
1924          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1925          sslipj=sscalelip(fracinbuf)
1926          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1927         else
1928          sslipj=1.0d0
1929          ssgradlipj=0.0
1930         endif
1931        else
1932          sslipj=0.0d0
1933          ssgradlipj=0.0
1934        endif
1935       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1936      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1937       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1940 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1941 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1942 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1943 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1944       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1945       xj_safe=xj
1946       yj_safe=yj
1947       zj_safe=zj
1948       subchap=0
1949       do xshift=-1,1
1950       do yshift=-1,1
1951       do zshift=-1,1
1952           xj=xj_safe+xshift*boxxsize
1953           yj=yj_safe+yshift*boxysize
1954           zj=zj_safe+zshift*boxzsize
1955           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1956           if(dist_temp.lt.dist_init) then
1957             dist_init=dist_temp
1958             xj_temp=xj
1959             yj_temp=yj
1960             zj_temp=zj
1961             subchap=1
1962           endif
1963        enddo
1964        enddo
1965        enddo
1966        if (subchap.eq.1) then
1967           xj=xj_temp-xi
1968           yj=yj_temp-yi
1969           zj=zj_temp-zi
1970        else
1971           xj=xj_safe-xi
1972           yj=yj_safe-yi
1973           zj=zj_safe-zi
1974        endif
1975             dxj=dc_norm(1,nres+j)
1976             dyj=dc_norm(2,nres+j)
1977             dzj=dc_norm(3,nres+j)
1978 C            xj=xj-xi
1979 C            yj=yj-yi
1980 C            zj=zj-zi
1981 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1982 c            write (iout,*) "j",j," dc_norm",
1983 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1984             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1985             rij=dsqrt(rrij)
1986             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1987             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1988
1989 c            write (iout,'(a7,4f8.3)')
1990 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1991             if (sss.gt.0.0d0) then
1992 C Calculate angle-dependent terms of energy and contributions to their
1993 C derivatives.
1994             call sc_angular
1995             sigsq=1.0D0/sigsq
1996             sig=sig0ij*dsqrt(sigsq)
1997             rij_shift=1.0D0/rij-sig+sig0ij
1998 c for diagnostics; uncomment
1999 c            rij_shift=1.2*sig0ij
2000 C I hate to put IF's in the loops, but here don't have another choice!!!!
2001             if (rij_shift.le.0.0D0) then
2002               evdw=1.0D20
2003 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2004 cd     &        restyp(itypi),i,restyp(itypj),j,
2005 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2006               return
2007             endif
2008             sigder=-sig*sigsq
2009 c---------------------------------------------------------------
2010             rij_shift=1.0D0/rij_shift
2011             fac=rij_shift**expon
2012 C here to start with
2013 C            if (c(i,3).gt.
2014             faclip=fac
2015             e1=fac*fac*aa
2016             e2=fac*bb
2017             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2018             eps2der=evdwij*eps3rt
2019             eps3der=evdwij*eps2rt
2020 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2021 C     &((sslipi+sslipj)/2.0d0+
2022 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2023 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2024 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2025             evdwij=evdwij*eps2rt*eps3rt
2026             evdw=evdw+evdwij*sss
2027             if (lprn) then
2028             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2029             epsi=bb**2/aa
2030             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2031      &        restyp(itypi),i,restyp(itypj),j,
2032      &        epsi,sigm,chi1,chi2,chip1,chip2,
2033      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2034      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2035      &        evdwij
2036             endif
2037
2038             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2039      &                        'evdw',i,j,evdwij
2040
2041 C Calculate gradient components.
2042             e1=e1*eps1*eps2rt**2*eps3rt**2
2043             fac=-expon*(e1+evdwij)*rij_shift
2044             sigder=fac*sigder
2045             fac=rij*fac
2046 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2047 c     &      evdwij,fac,sigma(itypi,itypj),expon
2048             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2049 c            fac=0.0d0
2050 C Calculate the radial part of the gradient
2051             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2052      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2053      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2054      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2055             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2056             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2057 C            gg_lipi(3)=0.0d0
2058 C            gg_lipj(3)=0.0d0
2059             gg(1)=xj*fac
2060             gg(2)=yj*fac
2061             gg(3)=zj*fac
2062 C Calculate angular part of the gradient.
2063             call sc_grad
2064             endif
2065             ENDIF    ! dyn_ss
2066           enddo      ! j
2067         enddo        ! iint
2068       enddo          ! i
2069 C      enddo          ! zshift
2070 C      enddo          ! yshift
2071 C      enddo          ! xshift
2072 c      write (iout,*) "Number of loop steps in EGB:",ind
2073 cccc      energy_dec=.false.
2074       return
2075       end
2076 C-----------------------------------------------------------------------------
2077       subroutine egbv(evdw)
2078 C
2079 C This subroutine calculates the interaction energy of nonbonded side chains
2080 C assuming the Gay-Berne-Vorobjev potential of interaction.
2081 C
2082       implicit real*8 (a-h,o-z)
2083       include 'DIMENSIONS'
2084       include 'COMMON.GEO'
2085       include 'COMMON.VAR'
2086       include 'COMMON.LOCAL'
2087       include 'COMMON.CHAIN'
2088       include 'COMMON.DERIV'
2089       include 'COMMON.NAMES'
2090       include 'COMMON.INTERACT'
2091       include 'COMMON.IOUNITS'
2092       include 'COMMON.CALC'
2093       common /srutu/ icall
2094       logical lprn
2095       evdw=0.0D0
2096 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2097       evdw=0.0D0
2098       lprn=.false.
2099 c     if (icall.eq.0) lprn=.true.
2100       ind=0
2101       do i=iatsc_s,iatsc_e
2102         itypi=iabs(itype(i))
2103         if (itypi.eq.ntyp1) cycle
2104         itypi1=iabs(itype(i+1))
2105         xi=c(1,nres+i)
2106         yi=c(2,nres+i)
2107         zi=c(3,nres+i)
2108           xi=mod(xi,boxxsize)
2109           if (xi.lt.0) xi=xi+boxxsize
2110           yi=mod(yi,boxysize)
2111           if (yi.lt.0) yi=yi+boxysize
2112           zi=mod(zi,boxzsize)
2113           if (zi.lt.0) zi=zi+boxzsize
2114 C define scaling factor for lipids
2115
2116 C        if (positi.le.0) positi=positi+boxzsize
2117 C        print *,i
2118 C first for peptide groups
2119 c for each residue check if it is in lipid or lipid water border area
2120        if ((zi.gt.bordlipbot)
2121      &.and.(zi.lt.bordliptop)) then
2122 C the energy transfer exist
2123         if (zi.lt.buflipbot) then
2124 C what fraction I am in
2125          fracinbuf=1.0d0-
2126      &        ((zi-bordlipbot)/lipbufthick)
2127 C lipbufthick is thickenes of lipid buffore
2128          sslipi=sscalelip(fracinbuf)
2129          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2130         elseif (zi.gt.bufliptop) then
2131          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2132          sslipi=sscalelip(fracinbuf)
2133          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2134         else
2135          sslipi=1.0d0
2136          ssgradlipi=0.0
2137         endif
2138        else
2139          sslipi=0.0d0
2140          ssgradlipi=0.0
2141        endif
2142
2143         dxi=dc_norm(1,nres+i)
2144         dyi=dc_norm(2,nres+i)
2145         dzi=dc_norm(3,nres+i)
2146 c        dsci_inv=dsc_inv(itypi)
2147         dsci_inv=vbld_inv(i+nres)
2148 C
2149 C Calculate SC interaction energy.
2150 C
2151         do iint=1,nint_gr(i)
2152           do j=istart(i,iint),iend(i,iint)
2153             ind=ind+1
2154             itypj=iabs(itype(j))
2155             if (itypj.eq.ntyp1) cycle
2156 c            dscj_inv=dsc_inv(itypj)
2157             dscj_inv=vbld_inv(j+nres)
2158             sig0ij=sigma(itypi,itypj)
2159             r0ij=r0(itypi,itypj)
2160             chi1=chi(itypi,itypj)
2161             chi2=chi(itypj,itypi)
2162             chi12=chi1*chi2
2163             chip1=chip(itypi)
2164             chip2=chip(itypj)
2165             chip12=chip1*chip2
2166             alf1=alp(itypi)
2167             alf2=alp(itypj)
2168             alf12=0.5D0*(alf1+alf2)
2169 C For diagnostics only!!!
2170 c           chi1=0.0D0
2171 c           chi2=0.0D0
2172 c           chi12=0.0D0
2173 c           chip1=0.0D0
2174 c           chip2=0.0D0
2175 c           chip12=0.0D0
2176 c           alf1=0.0D0
2177 c           alf2=0.0D0
2178 c           alf12=0.0D0
2179 C            xj=c(1,nres+j)-xi
2180 C            yj=c(2,nres+j)-yi
2181 C            zj=c(3,nres+j)-zi
2182           xj=mod(xj,boxxsize)
2183           if (xj.lt.0) xj=xj+boxxsize
2184           yj=mod(yj,boxysize)
2185           if (yj.lt.0) yj=yj+boxysize
2186           zj=mod(zj,boxzsize)
2187           if (zj.lt.0) zj=zj+boxzsize
2188        if ((zj.gt.bordlipbot)
2189      &.and.(zj.lt.bordliptop)) then
2190 C the energy transfer exist
2191         if (zj.lt.buflipbot) then
2192 C what fraction I am in
2193          fracinbuf=1.0d0-
2194      &        ((zj-bordlipbot)/lipbufthick)
2195 C lipbufthick is thickenes of lipid buffore
2196          sslipj=sscalelip(fracinbuf)
2197          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2198         elseif (zj.gt.bufliptop) then
2199          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2200          sslipj=sscalelip(fracinbuf)
2201          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2202         else
2203          sslipj=1.0d0
2204          ssgradlipj=0.0
2205         endif
2206        else
2207          sslipj=0.0d0
2208          ssgradlipj=0.0
2209        endif
2210       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2211      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2212       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2213      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2214 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2215 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2216 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2217       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2218       xj_safe=xj
2219       yj_safe=yj
2220       zj_safe=zj
2221       subchap=0
2222       do xshift=-1,1
2223       do yshift=-1,1
2224       do zshift=-1,1
2225           xj=xj_safe+xshift*boxxsize
2226           yj=yj_safe+yshift*boxysize
2227           zj=zj_safe+zshift*boxzsize
2228           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2229           if(dist_temp.lt.dist_init) then
2230             dist_init=dist_temp
2231             xj_temp=xj
2232             yj_temp=yj
2233             zj_temp=zj
2234             subchap=1
2235           endif
2236        enddo
2237        enddo
2238        enddo
2239        if (subchap.eq.1) then
2240           xj=xj_temp-xi
2241           yj=yj_temp-yi
2242           zj=zj_temp-zi
2243        else
2244           xj=xj_safe-xi
2245           yj=yj_safe-yi
2246           zj=zj_safe-zi
2247        endif
2248             dxj=dc_norm(1,nres+j)
2249             dyj=dc_norm(2,nres+j)
2250             dzj=dc_norm(3,nres+j)
2251             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2252             rij=dsqrt(rrij)
2253 C Calculate angle-dependent terms of energy and contributions to their
2254 C derivatives.
2255             call sc_angular
2256             sigsq=1.0D0/sigsq
2257             sig=sig0ij*dsqrt(sigsq)
2258             rij_shift=1.0D0/rij-sig+r0ij
2259 C I hate to put IF's in the loops, but here don't have another choice!!!!
2260             if (rij_shift.le.0.0D0) then
2261               evdw=1.0D20
2262               return
2263             endif
2264             sigder=-sig*sigsq
2265 c---------------------------------------------------------------
2266             rij_shift=1.0D0/rij_shift
2267             fac=rij_shift**expon
2268             e1=fac*fac*aa
2269             e2=fac*bb
2270             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2271             eps2der=evdwij*eps3rt
2272             eps3der=evdwij*eps2rt
2273             fac_augm=rrij**expon
2274             e_augm=augm(itypi,itypj)*fac_augm
2275             evdwij=evdwij*eps2rt*eps3rt
2276             evdw=evdw+evdwij+e_augm
2277             if (lprn) then
2278             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2279             epsi=bb**2/aa
2280             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2281      &        restyp(itypi),i,restyp(itypj),j,
2282      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2283      &        chi1,chi2,chip1,chip2,
2284      &        eps1,eps2rt**2,eps3rt**2,
2285      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2286      &        evdwij+e_augm
2287             endif
2288 C Calculate gradient components.
2289             e1=e1*eps1*eps2rt**2*eps3rt**2
2290             fac=-expon*(e1+evdwij)*rij_shift
2291             sigder=fac*sigder
2292             fac=rij*fac-2*expon*rrij*e_augm
2293             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2294 C Calculate the radial part of the gradient
2295             gg(1)=xj*fac
2296             gg(2)=yj*fac
2297             gg(3)=zj*fac
2298 C Calculate angular part of the gradient.
2299             call sc_grad
2300           enddo      ! j
2301         enddo        ! iint
2302       enddo          ! i
2303       end
2304 C-----------------------------------------------------------------------------
2305       subroutine sc_angular
2306 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2307 C om12. Called by ebp, egb, and egbv.
2308       implicit none
2309       include 'COMMON.CALC'
2310       include 'COMMON.IOUNITS'
2311       erij(1)=xj*rij
2312       erij(2)=yj*rij
2313       erij(3)=zj*rij
2314       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2315       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2316       om12=dxi*dxj+dyi*dyj+dzi*dzj
2317       chiom12=chi12*om12
2318 C Calculate eps1(om12) and its derivative in om12
2319       faceps1=1.0D0-om12*chiom12
2320       faceps1_inv=1.0D0/faceps1
2321       eps1=dsqrt(faceps1_inv)
2322 C Following variable is eps1*deps1/dom12
2323       eps1_om12=faceps1_inv*chiom12
2324 c diagnostics only
2325 c      faceps1_inv=om12
2326 c      eps1=om12
2327 c      eps1_om12=1.0d0
2328 c      write (iout,*) "om12",om12," eps1",eps1
2329 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2330 C and om12.
2331       om1om2=om1*om2
2332       chiom1=chi1*om1
2333       chiom2=chi2*om2
2334       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2335       sigsq=1.0D0-facsig*faceps1_inv
2336       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2337       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2338       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2339 c diagnostics only
2340 c      sigsq=1.0d0
2341 c      sigsq_om1=0.0d0
2342 c      sigsq_om2=0.0d0
2343 c      sigsq_om12=0.0d0
2344 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2345 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2346 c     &    " eps1",eps1
2347 C Calculate eps2 and its derivatives in om1, om2, and om12.
2348       chipom1=chip1*om1
2349       chipom2=chip2*om2
2350       chipom12=chip12*om12
2351       facp=1.0D0-om12*chipom12
2352       facp_inv=1.0D0/facp
2353       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2354 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2355 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2356 C Following variable is the square root of eps2
2357       eps2rt=1.0D0-facp1*facp_inv
2358 C Following three variables are the derivatives of the square root of eps
2359 C in om1, om2, and om12.
2360       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2361       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2362       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2363 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2364       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2365 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2366 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2367 c     &  " eps2rt_om12",eps2rt_om12
2368 C Calculate whole angle-dependent part of epsilon and contributions
2369 C to its derivatives
2370       return
2371       end
2372 C----------------------------------------------------------------------------
2373       subroutine sc_grad
2374       implicit real*8 (a-h,o-z)
2375       include 'DIMENSIONS'
2376       include 'COMMON.CHAIN'
2377       include 'COMMON.DERIV'
2378       include 'COMMON.CALC'
2379       include 'COMMON.IOUNITS'
2380       double precision dcosom1(3),dcosom2(3)
2381 cc      print *,'sss=',sss
2382       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2383       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2384       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2385      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2386 c diagnostics only
2387 c      eom1=0.0d0
2388 c      eom2=0.0d0
2389 c      eom12=evdwij*eps1_om12
2390 c end diagnostics
2391 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2392 c     &  " sigder",sigder
2393 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2394 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2395       do k=1,3
2396         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2397         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2398       enddo
2399       do k=1,3
2400         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2401       enddo
2402 c      write (iout,*) "gg",(gg(k),k=1,3)
2403       do k=1,3
2404         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2405      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2406      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2407         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2408      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2409      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2410 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2411 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2412 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2413 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2414       enddo
2415 C
2416 C Calculate the components of the gradient in DC and X
2417 C
2418 cgrad      do k=i,j-1
2419 cgrad        do l=1,3
2420 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2421 cgrad        enddo
2422 cgrad      enddo
2423       do l=1,3
2424         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2425         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2426       enddo
2427       return
2428       end
2429 C-----------------------------------------------------------------------
2430       subroutine e_softsphere(evdw)
2431 C
2432 C This subroutine calculates the interaction energy of nonbonded side chains
2433 C assuming the LJ potential of interaction.
2434 C
2435       implicit real*8 (a-h,o-z)
2436       include 'DIMENSIONS'
2437       parameter (accur=1.0d-10)
2438       include 'COMMON.GEO'
2439       include 'COMMON.VAR'
2440       include 'COMMON.LOCAL'
2441       include 'COMMON.CHAIN'
2442       include 'COMMON.DERIV'
2443       include 'COMMON.INTERACT'
2444       include 'COMMON.TORSION'
2445       include 'COMMON.SBRIDGE'
2446       include 'COMMON.NAMES'
2447       include 'COMMON.IOUNITS'
2448       include 'COMMON.CONTACTS'
2449       dimension gg(3)
2450 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2451       evdw=0.0D0
2452       do i=iatsc_s,iatsc_e
2453         itypi=iabs(itype(i))
2454         if (itypi.eq.ntyp1) cycle
2455         itypi1=iabs(itype(i+1))
2456         xi=c(1,nres+i)
2457         yi=c(2,nres+i)
2458         zi=c(3,nres+i)
2459 C
2460 C Calculate SC interaction energy.
2461 C
2462         do iint=1,nint_gr(i)
2463 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2464 cd   &                  'iend=',iend(i,iint)
2465           do j=istart(i,iint),iend(i,iint)
2466             itypj=iabs(itype(j))
2467             if (itypj.eq.ntyp1) cycle
2468             xj=c(1,nres+j)-xi
2469             yj=c(2,nres+j)-yi
2470             zj=c(3,nres+j)-zi
2471             rij=xj*xj+yj*yj+zj*zj
2472 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2473             r0ij=r0(itypi,itypj)
2474             r0ijsq=r0ij*r0ij
2475 c            print *,i,j,r0ij,dsqrt(rij)
2476             if (rij.lt.r0ijsq) then
2477               evdwij=0.25d0*(rij-r0ijsq)**2
2478               fac=rij-r0ijsq
2479             else
2480               evdwij=0.0d0
2481               fac=0.0d0
2482             endif
2483             evdw=evdw+evdwij
2484 C
2485 C Calculate the components of the gradient in DC and X
2486 C
2487             gg(1)=xj*fac
2488             gg(2)=yj*fac
2489             gg(3)=zj*fac
2490             do k=1,3
2491               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2492               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2493               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2494               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2495             enddo
2496 cgrad            do k=i,j-1
2497 cgrad              do l=1,3
2498 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2499 cgrad              enddo
2500 cgrad            enddo
2501           enddo ! j
2502         enddo ! iint
2503       enddo ! i
2504       return
2505       end
2506 C--------------------------------------------------------------------------
2507       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2508      &              eello_turn4)
2509 C
2510 C Soft-sphere potential of p-p interaction
2511 C
2512       implicit real*8 (a-h,o-z)
2513       include 'DIMENSIONS'
2514       include 'COMMON.CONTROL'
2515       include 'COMMON.IOUNITS'
2516       include 'COMMON.GEO'
2517       include 'COMMON.VAR'
2518       include 'COMMON.LOCAL'
2519       include 'COMMON.CHAIN'
2520       include 'COMMON.DERIV'
2521       include 'COMMON.INTERACT'
2522       include 'COMMON.CONTACTS'
2523       include 'COMMON.TORSION'
2524       include 'COMMON.VECTORS'
2525       include 'COMMON.FFIELD'
2526       dimension ggg(3)
2527 C      write(iout,*) 'In EELEC_soft_sphere'
2528       ees=0.0D0
2529       evdw1=0.0D0
2530       eel_loc=0.0d0
2531       eello_turn3=0.0d0
2532       eello_turn4=0.0d0
2533       ind=0
2534       do i=iatel_s,iatel_e
2535         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2536         dxi=dc(1,i)
2537         dyi=dc(2,i)
2538         dzi=dc(3,i)
2539         xmedi=c(1,i)+0.5d0*dxi
2540         ymedi=c(2,i)+0.5d0*dyi
2541         zmedi=c(3,i)+0.5d0*dzi
2542           xmedi=mod(xmedi,boxxsize)
2543           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2544           ymedi=mod(ymedi,boxysize)
2545           if (ymedi.lt.0) ymedi=ymedi+boxysize
2546           zmedi=mod(zmedi,boxzsize)
2547           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2548         num_conti=0
2549 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2550         do j=ielstart(i),ielend(i)
2551           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2552           ind=ind+1
2553           iteli=itel(i)
2554           itelj=itel(j)
2555           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2556           r0ij=rpp(iteli,itelj)
2557           r0ijsq=r0ij*r0ij
2558           dxj=dc(1,j)
2559           dyj=dc(2,j)
2560           dzj=dc(3,j)
2561           xj=c(1,j)+0.5D0*dxj
2562           yj=c(2,j)+0.5D0*dyj
2563           zj=c(3,j)+0.5D0*dzj
2564           xj=mod(xj,boxxsize)
2565           if (xj.lt.0) xj=xj+boxxsize
2566           yj=mod(yj,boxysize)
2567           if (yj.lt.0) yj=yj+boxysize
2568           zj=mod(zj,boxzsize)
2569           if (zj.lt.0) zj=zj+boxzsize
2570       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2571       xj_safe=xj
2572       yj_safe=yj
2573       zj_safe=zj
2574       isubchap=0
2575       do xshift=-1,1
2576       do yshift=-1,1
2577       do zshift=-1,1
2578           xj=xj_safe+xshift*boxxsize
2579           yj=yj_safe+yshift*boxysize
2580           zj=zj_safe+zshift*boxzsize
2581           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2582           if(dist_temp.lt.dist_init) then
2583             dist_init=dist_temp
2584             xj_temp=xj
2585             yj_temp=yj
2586             zj_temp=zj
2587             isubchap=1
2588           endif
2589        enddo
2590        enddo
2591        enddo
2592        if (isubchap.eq.1) then
2593           xj=xj_temp-xmedi
2594           yj=yj_temp-ymedi
2595           zj=zj_temp-zmedi
2596        else
2597           xj=xj_safe-xmedi
2598           yj=yj_safe-ymedi
2599           zj=zj_safe-zmedi
2600        endif
2601           rij=xj*xj+yj*yj+zj*zj
2602             sss=sscale(sqrt(rij))
2603             sssgrad=sscagrad(sqrt(rij))
2604           if (rij.lt.r0ijsq) then
2605             evdw1ij=0.25d0*(rij-r0ijsq)**2
2606             fac=rij-r0ijsq
2607           else
2608             evdw1ij=0.0d0
2609             fac=0.0d0
2610           endif
2611           evdw1=evdw1+evdw1ij*sss
2612 C
2613 C Calculate contributions to the Cartesian gradient.
2614 C
2615           ggg(1)=fac*xj*sssgrad
2616           ggg(2)=fac*yj*sssgrad
2617           ggg(3)=fac*zj*sssgrad
2618           do k=1,3
2619             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2620             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2621           enddo
2622 *
2623 * Loop over residues i+1 thru j-1.
2624 *
2625 cgrad          do k=i+1,j-1
2626 cgrad            do l=1,3
2627 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2628 cgrad            enddo
2629 cgrad          enddo
2630         enddo ! j
2631       enddo   ! i
2632 cgrad      do i=nnt,nct-1
2633 cgrad        do k=1,3
2634 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2635 cgrad        enddo
2636 cgrad        do j=i+1,nct-1
2637 cgrad          do k=1,3
2638 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2639 cgrad          enddo
2640 cgrad        enddo
2641 cgrad      enddo
2642       return
2643       end
2644 c------------------------------------------------------------------------------
2645       subroutine vec_and_deriv
2646       implicit real*8 (a-h,o-z)
2647       include 'DIMENSIONS'
2648 #ifdef MPI
2649       include 'mpif.h'
2650 #endif
2651       include 'COMMON.IOUNITS'
2652       include 'COMMON.GEO'
2653       include 'COMMON.VAR'
2654       include 'COMMON.LOCAL'
2655       include 'COMMON.CHAIN'
2656       include 'COMMON.VECTORS'
2657       include 'COMMON.SETUP'
2658       include 'COMMON.TIME1'
2659       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2660 C Compute the local reference systems. For reference system (i), the
2661 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2662 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2663 #ifdef PARVEC
2664       do i=ivec_start,ivec_end
2665 #else
2666       do i=1,nres-1
2667 #endif
2668           if (i.eq.nres-1) then
2669 C Case of the last full residue
2670 C Compute the Z-axis
2671             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2672             costh=dcos(pi-theta(nres))
2673             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2674             do k=1,3
2675               uz(k,i)=fac*uz(k,i)
2676             enddo
2677 C Compute the derivatives of uz
2678             uzder(1,1,1)= 0.0d0
2679             uzder(2,1,1)=-dc_norm(3,i-1)
2680             uzder(3,1,1)= dc_norm(2,i-1)
2681             uzder(1,2,1)= dc_norm(3,i-1)
2682             uzder(2,2,1)= 0.0d0
2683             uzder(3,2,1)=-dc_norm(1,i-1)
2684             uzder(1,3,1)=-dc_norm(2,i-1)
2685             uzder(2,3,1)= dc_norm(1,i-1)
2686             uzder(3,3,1)= 0.0d0
2687             uzder(1,1,2)= 0.0d0
2688             uzder(2,1,2)= dc_norm(3,i)
2689             uzder(3,1,2)=-dc_norm(2,i)
2690             uzder(1,2,2)=-dc_norm(3,i)
2691             uzder(2,2,2)= 0.0d0
2692             uzder(3,2,2)= dc_norm(1,i)
2693             uzder(1,3,2)= dc_norm(2,i)
2694             uzder(2,3,2)=-dc_norm(1,i)
2695             uzder(3,3,2)= 0.0d0
2696 C Compute the Y-axis
2697             facy=fac
2698             do k=1,3
2699               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2700             enddo
2701 C Compute the derivatives of uy
2702             do j=1,3
2703               do k=1,3
2704                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2705      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2706                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2707               enddo
2708               uyder(j,j,1)=uyder(j,j,1)-costh
2709               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2710             enddo
2711             do j=1,2
2712               do k=1,3
2713                 do l=1,3
2714                   uygrad(l,k,j,i)=uyder(l,k,j)
2715                   uzgrad(l,k,j,i)=uzder(l,k,j)
2716                 enddo
2717               enddo
2718             enddo
2719             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2720             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2721             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2722             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2723           else
2724 C Other residues
2725 C Compute the Z-axis
2726             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2727             costh=dcos(pi-theta(i+2))
2728             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2729             do k=1,3
2730               uz(k,i)=fac*uz(k,i)
2731             enddo
2732 C Compute the derivatives of uz
2733             uzder(1,1,1)= 0.0d0
2734             uzder(2,1,1)=-dc_norm(3,i+1)
2735             uzder(3,1,1)= dc_norm(2,i+1)
2736             uzder(1,2,1)= dc_norm(3,i+1)
2737             uzder(2,2,1)= 0.0d0
2738             uzder(3,2,1)=-dc_norm(1,i+1)
2739             uzder(1,3,1)=-dc_norm(2,i+1)
2740             uzder(2,3,1)= dc_norm(1,i+1)
2741             uzder(3,3,1)= 0.0d0
2742             uzder(1,1,2)= 0.0d0
2743             uzder(2,1,2)= dc_norm(3,i)
2744             uzder(3,1,2)=-dc_norm(2,i)
2745             uzder(1,2,2)=-dc_norm(3,i)
2746             uzder(2,2,2)= 0.0d0
2747             uzder(3,2,2)= dc_norm(1,i)
2748             uzder(1,3,2)= dc_norm(2,i)
2749             uzder(2,3,2)=-dc_norm(1,i)
2750             uzder(3,3,2)= 0.0d0
2751 C Compute the Y-axis
2752             facy=fac
2753             do k=1,3
2754               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2755             enddo
2756 C Compute the derivatives of uy
2757             do j=1,3
2758               do k=1,3
2759                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2760      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2761                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2762               enddo
2763               uyder(j,j,1)=uyder(j,j,1)-costh
2764               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2765             enddo
2766             do j=1,2
2767               do k=1,3
2768                 do l=1,3
2769                   uygrad(l,k,j,i)=uyder(l,k,j)
2770                   uzgrad(l,k,j,i)=uzder(l,k,j)
2771                 enddo
2772               enddo
2773             enddo
2774             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2775             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2776             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2777             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2778           endif
2779       enddo
2780       do i=1,nres-1
2781         vbld_inv_temp(1)=vbld_inv(i+1)
2782         if (i.lt.nres-1) then
2783           vbld_inv_temp(2)=vbld_inv(i+2)
2784           else
2785           vbld_inv_temp(2)=vbld_inv(i)
2786           endif
2787         do j=1,2
2788           do k=1,3
2789             do l=1,3
2790               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2791               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2792             enddo
2793           enddo
2794         enddo
2795       enddo
2796 #if defined(PARVEC) && defined(MPI)
2797       if (nfgtasks1.gt.1) then
2798         time00=MPI_Wtime()
2799 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2800 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2801 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2802         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2803      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2804      &   FG_COMM1,IERR)
2805         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2806      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2807      &   FG_COMM1,IERR)
2808         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2809      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2810      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2811         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2812      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2813      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2814         time_gather=time_gather+MPI_Wtime()-time00
2815       endif
2816 c      if (fg_rank.eq.0) then
2817 c        write (iout,*) "Arrays UY and UZ"
2818 c        do i=1,nres-1
2819 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2820 c     &     (uz(k,i),k=1,3)
2821 c        enddo
2822 c      endif
2823 #endif
2824       return
2825       end
2826 C-----------------------------------------------------------------------------
2827       subroutine check_vecgrad
2828       implicit real*8 (a-h,o-z)
2829       include 'DIMENSIONS'
2830       include 'COMMON.IOUNITS'
2831       include 'COMMON.GEO'
2832       include 'COMMON.VAR'
2833       include 'COMMON.LOCAL'
2834       include 'COMMON.CHAIN'
2835       include 'COMMON.VECTORS'
2836       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2837       dimension uyt(3,maxres),uzt(3,maxres)
2838       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2839       double precision delta /1.0d-7/
2840       call vec_and_deriv
2841 cd      do i=1,nres
2842 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2843 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2844 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2845 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2846 cd     &     (dc_norm(if90,i),if90=1,3)
2847 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2848 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2849 cd          write(iout,'(a)')
2850 cd      enddo
2851       do i=1,nres
2852         do j=1,2
2853           do k=1,3
2854             do l=1,3
2855               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2856               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2857             enddo
2858           enddo
2859         enddo
2860       enddo
2861       call vec_and_deriv
2862       do i=1,nres
2863         do j=1,3
2864           uyt(j,i)=uy(j,i)
2865           uzt(j,i)=uz(j,i)
2866         enddo
2867       enddo
2868       do i=1,nres
2869 cd        write (iout,*) 'i=',i
2870         do k=1,3
2871           erij(k)=dc_norm(k,i)
2872         enddo
2873         do j=1,3
2874           do k=1,3
2875             dc_norm(k,i)=erij(k)
2876           enddo
2877           dc_norm(j,i)=dc_norm(j,i)+delta
2878 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2879 c          do k=1,3
2880 c            dc_norm(k,i)=dc_norm(k,i)/fac
2881 c          enddo
2882 c          write (iout,*) (dc_norm(k,i),k=1,3)
2883 c          write (iout,*) (erij(k),k=1,3)
2884           call vec_and_deriv
2885           do k=1,3
2886             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2887             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2888             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2889             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2890           enddo
2891 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2892 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2893 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2894         enddo
2895         do k=1,3
2896           dc_norm(k,i)=erij(k)
2897         enddo
2898 cd        do k=1,3
2899 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2900 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2901 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2902 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2903 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2904 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2905 cd          write (iout,'(a)')
2906 cd        enddo
2907       enddo
2908       return
2909       end
2910 C--------------------------------------------------------------------------
2911       subroutine set_matrices
2912       implicit real*8 (a-h,o-z)
2913       include 'DIMENSIONS'
2914 #ifdef MPI
2915       include "mpif.h"
2916       include "COMMON.SETUP"
2917       integer IERR
2918       integer status(MPI_STATUS_SIZE)
2919 #endif
2920       include 'COMMON.IOUNITS'
2921       include 'COMMON.GEO'
2922       include 'COMMON.VAR'
2923       include 'COMMON.LOCAL'
2924       include 'COMMON.CHAIN'
2925       include 'COMMON.DERIV'
2926       include 'COMMON.INTERACT'
2927       include 'COMMON.CONTACTS'
2928       include 'COMMON.TORSION'
2929       include 'COMMON.VECTORS'
2930       include 'COMMON.FFIELD'
2931       double precision auxvec(2),auxmat(2,2)
2932 C
2933 C Compute the virtual-bond-torsional-angle dependent quantities needed
2934 C to calculate the el-loc multibody terms of various order.
2935 C
2936 c      write(iout,*) 'nphi=',nphi,nres
2937 #ifdef PARMAT
2938       do i=ivec_start+2,ivec_end+2
2939 #else
2940       do i=3,nres+1
2941 #endif
2942 #ifdef NEWCORR
2943         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2944           iti = itype2loc(itype(i-2))
2945         else
2946           iti=nloctyp
2947         endif
2948 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2949         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2950           iti1 = itype2loc(itype(i-1))
2951         else
2952           iti1=nloctyp
2953         endif
2954 c        write(iout,*),i
2955         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2956      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2957      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2958         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2959      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2960      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2961 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2962 c     &*(cos(theta(i)/2.0)
2963         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2964      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2965      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2966 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2967 c     &*(cos(theta(i)/2.0)
2968         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2969      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2970      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2971 c        if (ggb1(1,i).eq.0.0d0) then
2972 c        write(iout,*) 'i=',i,ggb1(1,i),
2973 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2974 c     &bnew1(2,1,iti)*cos(theta(i)),
2975 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2976 c        endif
2977         b1(2,i-2)=bnew1(1,2,iti)
2978         gtb1(2,i-2)=0.0
2979         b2(2,i-2)=bnew2(1,2,iti)
2980         gtb2(2,i-2)=0.0
2981         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2982         EE(1,2,i-2)=eeold(1,2,iti)
2983         EE(2,1,i-2)=eeold(2,1,iti)
2984         EE(2,2,i-2)=eeold(2,2,iti)
2985         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2986         gtEE(1,2,i-2)=0.0d0
2987         gtEE(2,2,i-2)=0.0d0
2988         gtEE(2,1,i-2)=0.0d0
2989 c        EE(2,2,iti)=0.0d0
2990 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2991 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2992 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2993 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2994        b1tilde(1,i-2)=b1(1,i-2)
2995        b1tilde(2,i-2)=-b1(2,i-2)
2996        b2tilde(1,i-2)=b2(1,i-2)
2997        b2tilde(2,i-2)=-b2(2,i-2)
2998 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2999 c       write(iout,*)  'b1=',b1(1,i-2)
3000 c       write (iout,*) 'theta=', theta(i-1)
3001        enddo
3002 #else
3003         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3004           iti = itype2loc(itype(i-2))
3005         else
3006           iti=nloctyp
3007         endif
3008 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3009         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3010           iti1 = itype2loc(itype(i-1))
3011         else
3012           iti1=nloctyp
3013         endif
3014         b1(1,i-2)=b(3,iti)
3015         b1(2,i-2)=b(5,iti)
3016         b2(1,i-2)=b(2,iti)
3017         b2(2,i-2)=b(4,iti)
3018        b1tilde(1,i-2)=b1(1,i-2)
3019        b1tilde(2,i-2)=-b1(2,i-2)
3020        b2tilde(1,i-2)=b2(1,i-2)
3021        b2tilde(2,i-2)=-b2(2,i-2)
3022         EE(1,2,i-2)=eeold(1,2,iti)
3023         EE(2,1,i-2)=eeold(2,1,iti)
3024         EE(2,2,i-2)=eeold(2,2,iti)
3025         EE(1,1,i-2)=eeold(1,1,iti)
3026       enddo
3027 #endif
3028 #ifdef PARMAT
3029       do i=ivec_start+2,ivec_end+2
3030 #else
3031       do i=3,nres+1
3032 #endif
3033         if (i .lt. nres+1) then
3034           sin1=dsin(phi(i))
3035           cos1=dcos(phi(i))
3036           sintab(i-2)=sin1
3037           costab(i-2)=cos1
3038           obrot(1,i-2)=cos1
3039           obrot(2,i-2)=sin1
3040           sin2=dsin(2*phi(i))
3041           cos2=dcos(2*phi(i))
3042           sintab2(i-2)=sin2
3043           costab2(i-2)=cos2
3044           obrot2(1,i-2)=cos2
3045           obrot2(2,i-2)=sin2
3046           Ug(1,1,i-2)=-cos1
3047           Ug(1,2,i-2)=-sin1
3048           Ug(2,1,i-2)=-sin1
3049           Ug(2,2,i-2)= cos1
3050           Ug2(1,1,i-2)=-cos2
3051           Ug2(1,2,i-2)=-sin2
3052           Ug2(2,1,i-2)=-sin2
3053           Ug2(2,2,i-2)= cos2
3054         else
3055           costab(i-2)=1.0d0
3056           sintab(i-2)=0.0d0
3057           obrot(1,i-2)=1.0d0
3058           obrot(2,i-2)=0.0d0
3059           obrot2(1,i-2)=0.0d0
3060           obrot2(2,i-2)=0.0d0
3061           Ug(1,1,i-2)=1.0d0
3062           Ug(1,2,i-2)=0.0d0
3063           Ug(2,1,i-2)=0.0d0
3064           Ug(2,2,i-2)=1.0d0
3065           Ug2(1,1,i-2)=0.0d0
3066           Ug2(1,2,i-2)=0.0d0
3067           Ug2(2,1,i-2)=0.0d0
3068           Ug2(2,2,i-2)=0.0d0
3069         endif
3070         if (i .gt. 3 .and. i .lt. nres+1) then
3071           obrot_der(1,i-2)=-sin1
3072           obrot_der(2,i-2)= cos1
3073           Ugder(1,1,i-2)= sin1
3074           Ugder(1,2,i-2)=-cos1
3075           Ugder(2,1,i-2)=-cos1
3076           Ugder(2,2,i-2)=-sin1
3077           dwacos2=cos2+cos2
3078           dwasin2=sin2+sin2
3079           obrot2_der(1,i-2)=-dwasin2
3080           obrot2_der(2,i-2)= dwacos2
3081           Ug2der(1,1,i-2)= dwasin2
3082           Ug2der(1,2,i-2)=-dwacos2
3083           Ug2der(2,1,i-2)=-dwacos2
3084           Ug2der(2,2,i-2)=-dwasin2
3085         else
3086           obrot_der(1,i-2)=0.0d0
3087           obrot_der(2,i-2)=0.0d0
3088           Ugder(1,1,i-2)=0.0d0
3089           Ugder(1,2,i-2)=0.0d0
3090           Ugder(2,1,i-2)=0.0d0
3091           Ugder(2,2,i-2)=0.0d0
3092           obrot2_der(1,i-2)=0.0d0
3093           obrot2_der(2,i-2)=0.0d0
3094           Ug2der(1,1,i-2)=0.0d0
3095           Ug2der(1,2,i-2)=0.0d0
3096           Ug2der(2,1,i-2)=0.0d0
3097           Ug2der(2,2,i-2)=0.0d0
3098         endif
3099 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3100         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3101           iti = itype2loc(itype(i-2))
3102         else
3103           iti=nloctyp
3104         endif
3105 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3106         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3107           iti1 = itype2loc(itype(i-1))
3108         else
3109           iti1=nloctyp
3110         endif
3111 cd        write (iout,*) '*******i',i,' iti1',iti
3112 cd        write (iout,*) 'b1',b1(:,iti)
3113 cd        write (iout,*) 'b2',b2(:,iti)
3114 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3115 c        if (i .gt. iatel_s+2) then
3116         if (i .gt. nnt+2) then
3117           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3118 #ifdef NEWCORR
3119           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3120 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3121 #endif
3122 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3123 c     &    EE(1,2,iti),EE(2,2,i)
3124           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3125           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3126 c          write(iout,*) "Macierz EUG",
3127 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3128 c     &    eug(2,2,i-2)
3129           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3130      &    then
3131           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3132           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3133           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3134           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3135           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3136           endif
3137         else
3138           do k=1,2
3139             Ub2(k,i-2)=0.0d0
3140             Ctobr(k,i-2)=0.0d0
3141             Dtobr2(k,i-2)=0.0d0
3142             do l=1,2
3143               EUg(l,k,i-2)=0.0d0
3144               CUg(l,k,i-2)=0.0d0
3145               DUg(l,k,i-2)=0.0d0
3146               DtUg2(l,k,i-2)=0.0d0
3147             enddo
3148           enddo
3149         endif
3150         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3151         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3152         do k=1,2
3153           muder(k,i-2)=Ub2der(k,i-2)
3154         enddo
3155 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3156         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3157           if (itype(i-1).le.ntyp) then
3158             iti1 = itype2loc(itype(i-1))
3159           else
3160             iti1=nloctyp
3161           endif
3162         else
3163           iti1=nloctyp
3164         endif
3165         do k=1,2
3166           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3167         enddo
3168 #ifdef MUOUT
3169         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3170      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3171      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3172      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3173      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3174      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3175 #endif
3176 cd        write (iout,*) 'mu1',mu1(:,i-2)
3177 cd        write (iout,*) 'mu2',mu2(:,i-2)
3178         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3179      &  then
3180         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3181         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3182         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3183         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3184         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3185 C Vectors and matrices dependent on a single virtual-bond dihedral.
3186         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3187         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3188         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3189         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3190         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3191         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3192         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3193         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3194         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3195         endif
3196       enddo
3197 C Matrices dependent on two consecutive virtual-bond dihedrals.
3198 C The order of matrices is from left to right.
3199       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3200      &then
3201 c      do i=max0(ivec_start,2),ivec_end
3202       do i=2,nres-1
3203         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3204         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3205         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3206         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3207         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3208         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3209         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3210         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3211       enddo
3212       endif
3213 #if defined(MPI) && defined(PARMAT)
3214 #ifdef DEBUG
3215 c      if (fg_rank.eq.0) then
3216         write (iout,*) "Arrays UG and UGDER before GATHER"
3217         do i=1,nres-1
3218           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3219      &     ((ug(l,k,i),l=1,2),k=1,2),
3220      &     ((ugder(l,k,i),l=1,2),k=1,2)
3221         enddo
3222         write (iout,*) "Arrays UG2 and UG2DER"
3223         do i=1,nres-1
3224           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3225      &     ((ug2(l,k,i),l=1,2),k=1,2),
3226      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3227         enddo
3228         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3229         do i=1,nres-1
3230           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3231      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3232      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3233         enddo
3234         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3235         do i=1,nres-1
3236           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3237      &     costab(i),sintab(i),costab2(i),sintab2(i)
3238         enddo
3239         write (iout,*) "Array MUDER"
3240         do i=1,nres-1
3241           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3242         enddo
3243 c      endif
3244 #endif
3245       if (nfgtasks.gt.1) then
3246         time00=MPI_Wtime()
3247 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3248 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3249 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3250 #ifdef MATGATHER
3251         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3253      &   FG_COMM1,IERR)
3254         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3259      &   FG_COMM1,IERR)
3260         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3261      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3262      &   FG_COMM1,IERR)
3263         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3264      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3267      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3268      &   FG_COMM1,IERR)
3269         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3270      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3271      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3272         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3273      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3274      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3275         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3276      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3277      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3278         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3279      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3280      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3281         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3282      &  then
3283         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3284      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3285      &   FG_COMM1,IERR)
3286         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3287      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3290      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3291      &   FG_COMM1,IERR)
3292        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3293      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3297      &   FG_COMM1,IERR)
3298         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3299      &   ivec_count(fg_rank1),
3300      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3301      &   FG_COMM1,IERR)
3302         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3303      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3304      &   FG_COMM1,IERR)
3305         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3306      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3307      &   FG_COMM1,IERR)
3308         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3309      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3310      &   FG_COMM1,IERR)
3311         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3312      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3313      &   FG_COMM1,IERR)
3314         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3315      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3316      &   FG_COMM1,IERR)
3317         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3318      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3319      &   FG_COMM1,IERR)
3320         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3321      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3322      &   FG_COMM1,IERR)
3323         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3324      &   ivec_count(fg_rank1),
3325      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3326      &   FG_COMM1,IERR)
3327         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3328      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3329      &   FG_COMM1,IERR)
3330        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3331      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3332      &   FG_COMM1,IERR)
3333         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3334      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3335      &   FG_COMM1,IERR)
3336        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3337      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3338      &   FG_COMM1,IERR)
3339         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3340      &   ivec_count(fg_rank1),
3341      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3342      &   FG_COMM1,IERR)
3343         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3344      &   ivec_count(fg_rank1),
3345      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3346      &   FG_COMM1,IERR)
3347         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3348      &   ivec_count(fg_rank1),
3349      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3350      &   MPI_MAT2,FG_COMM1,IERR)
3351         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3352      &   ivec_count(fg_rank1),
3353      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3354      &   MPI_MAT2,FG_COMM1,IERR)
3355         endif
3356 #else
3357 c Passes matrix info through the ring
3358       isend=fg_rank1
3359       irecv=fg_rank1-1
3360       if (irecv.lt.0) irecv=nfgtasks1-1
3361       iprev=irecv
3362       inext=fg_rank1+1
3363       if (inext.ge.nfgtasks1) inext=0
3364       do i=1,nfgtasks1-1
3365 c        write (iout,*) "isend",isend," irecv",irecv
3366 c        call flush(iout)
3367         lensend=lentyp(isend)
3368         lenrecv=lentyp(irecv)
3369 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3370 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3371 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3372 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3373 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3374 c        write (iout,*) "Gather ROTAT1"
3375 c        call flush(iout)
3376 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3377 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3378 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3379 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3380 c        write (iout,*) "Gather ROTAT2"
3381 c        call flush(iout)
3382         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3383      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3384      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3385      &   iprev,4400+irecv,FG_COMM,status,IERR)
3386 c        write (iout,*) "Gather ROTAT_OLD"
3387 c        call flush(iout)
3388         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3389      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3390      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3391      &   iprev,5500+irecv,FG_COMM,status,IERR)
3392 c        write (iout,*) "Gather PRECOMP11"
3393 c        call flush(iout)
3394         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3395      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3396      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3397      &   iprev,6600+irecv,FG_COMM,status,IERR)
3398 c        write (iout,*) "Gather PRECOMP12"
3399 c        call flush(iout)
3400         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3401      &  then
3402         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3403      &   MPI_ROTAT2(lensend),inext,7700+isend,
3404      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3405      &   iprev,7700+irecv,FG_COMM,status,IERR)
3406 c        write (iout,*) "Gather PRECOMP21"
3407 c        call flush(iout)
3408         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3409      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3410      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3411      &   iprev,8800+irecv,FG_COMM,status,IERR)
3412 c        write (iout,*) "Gather PRECOMP22"
3413 c        call flush(iout)
3414         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3415      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3416      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3417      &   MPI_PRECOMP23(lenrecv),
3418      &   iprev,9900+irecv,FG_COMM,status,IERR)
3419 c        write (iout,*) "Gather PRECOMP23"
3420 c        call flush(iout)
3421         endif
3422         isend=irecv
3423         irecv=irecv-1
3424         if (irecv.lt.0) irecv=nfgtasks1-1
3425       enddo
3426 #endif
3427         time_gather=time_gather+MPI_Wtime()-time00
3428       endif
3429 #ifdef DEBUG
3430 c      if (fg_rank.eq.0) then
3431         write (iout,*) "Arrays UG and UGDER"
3432         do i=1,nres-1
3433           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3434      &     ((ug(l,k,i),l=1,2),k=1,2),
3435      &     ((ugder(l,k,i),l=1,2),k=1,2)
3436         enddo
3437         write (iout,*) "Arrays UG2 and UG2DER"
3438         do i=1,nres-1
3439           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3440      &     ((ug2(l,k,i),l=1,2),k=1,2),
3441      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3442         enddo
3443         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3444         do i=1,nres-1
3445           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3446      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3447      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3448         enddo
3449         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3450         do i=1,nres-1
3451           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3452      &     costab(i),sintab(i),costab2(i),sintab2(i)
3453         enddo
3454         write (iout,*) "Array MUDER"
3455         do i=1,nres-1
3456           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3457         enddo
3458 c      endif
3459 #endif
3460 #endif
3461 cd      do i=1,nres
3462 cd        iti = itype2loc(itype(i))
3463 cd        write (iout,*) i
3464 cd        do j=1,2
3465 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3466 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3467 cd        enddo
3468 cd      enddo
3469       return
3470       end
3471 C--------------------------------------------------------------------------
3472       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3473 C
3474 C This subroutine calculates the average interaction energy and its gradient
3475 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3476 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3477 C The potential depends both on the distance of peptide-group centers and on
3478 C the orientation of the CA-CA virtual bonds.
3479 C
3480       implicit real*8 (a-h,o-z)
3481 #ifdef MPI
3482       include 'mpif.h'
3483 #endif
3484       include 'DIMENSIONS'
3485       include 'COMMON.CONTROL'
3486       include 'COMMON.SETUP'
3487       include 'COMMON.IOUNITS'
3488       include 'COMMON.GEO'
3489       include 'COMMON.VAR'
3490       include 'COMMON.LOCAL'
3491       include 'COMMON.CHAIN'
3492       include 'COMMON.DERIV'
3493       include 'COMMON.INTERACT'
3494       include 'COMMON.CONTACTS'
3495       include 'COMMON.TORSION'
3496       include 'COMMON.VECTORS'
3497       include 'COMMON.FFIELD'
3498       include 'COMMON.TIME1'
3499       include 'COMMON.SPLITELE'
3500       include 'COMMON.SHIELD'
3501       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3502      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3503       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3504      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3505       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3506      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3507      &    num_conti,j1,j2
3508 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3509 #ifdef MOMENT
3510       double precision scal_el /1.0d0/
3511 #else
3512       double precision scal_el /0.5d0/
3513 #endif
3514 C 12/13/98
3515 C 13-go grudnia roku pamietnego...
3516       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3517      &                   0.0d0,1.0d0,0.0d0,
3518      &                   0.0d0,0.0d0,1.0d0/
3519 cd      write(iout,*) 'In EELEC'
3520 cd      do i=1,nloctyp
3521 cd        write(iout,*) 'Type',i
3522 cd        write(iout,*) 'B1',B1(:,i)
3523 cd        write(iout,*) 'B2',B2(:,i)
3524 cd        write(iout,*) 'CC',CC(:,:,i)
3525 cd        write(iout,*) 'DD',DD(:,:,i)
3526 cd        write(iout,*) 'EE',EE(:,:,i)
3527 cd      enddo
3528 cd      call check_vecgrad
3529 cd      stop
3530       if (icheckgrad.eq.1) then
3531         do i=1,nres-1
3532           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3533           do k=1,3
3534             dc_norm(k,i)=dc(k,i)*fac
3535           enddo
3536 c          write (iout,*) 'i',i,' fac',fac
3537         enddo
3538       endif
3539       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3540      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3541      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3542 c        call vec_and_deriv
3543 #ifdef TIMING
3544         time01=MPI_Wtime()
3545 #endif
3546         call set_matrices
3547 #ifdef TIMING
3548         time_mat=time_mat+MPI_Wtime()-time01
3549 #endif
3550       endif
3551 cd      do i=1,nres-1
3552 cd        write (iout,*) 'i=',i
3553 cd        do k=1,3
3554 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3555 cd        enddo
3556 cd        do k=1,3
3557 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3558 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3559 cd        enddo
3560 cd      enddo
3561       t_eelecij=0.0d0
3562       ees=0.0D0
3563       evdw1=0.0D0
3564       eel_loc=0.0d0
3565       eello_turn3=0.0d0
3566       eello_turn4=0.0d0
3567       ind=0
3568       do i=1,nres
3569         num_cont_hb(i)=0
3570       enddo
3571 cd      print '(a)','Enter EELEC'
3572 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3573       do i=1,nres
3574         gel_loc_loc(i)=0.0d0
3575         gcorr_loc(i)=0.0d0
3576       enddo
3577 c
3578 c
3579 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3580 C
3581 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3582 C
3583 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3584       do i=iturn3_start,iturn3_end
3585 c        if (i.le.1) cycle
3586 C        write(iout,*) "tu jest i",i
3587         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3588 C changes suggested by Ana to avoid out of bounds
3589 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3590 c     & .or.((i+4).gt.nres)
3591 c     & .or.((i-1).le.0)
3592 C end of changes by Ana
3593      &  .or. itype(i+2).eq.ntyp1
3594      &  .or. itype(i+3).eq.ntyp1) cycle
3595 C Adam: Instructions below will switch off existing interactions
3596 c        if(i.gt.1)then
3597 c          if(itype(i-1).eq.ntyp1)cycle
3598 c        end if
3599 c        if(i.LT.nres-3)then
3600 c          if (itype(i+4).eq.ntyp1) cycle
3601 c        end if
3602         dxi=dc(1,i)
3603         dyi=dc(2,i)
3604         dzi=dc(3,i)
3605         dx_normi=dc_norm(1,i)
3606         dy_normi=dc_norm(2,i)
3607         dz_normi=dc_norm(3,i)
3608         xmedi=c(1,i)+0.5d0*dxi
3609         ymedi=c(2,i)+0.5d0*dyi
3610         zmedi=c(3,i)+0.5d0*dzi
3611           xmedi=mod(xmedi,boxxsize)
3612           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3613           ymedi=mod(ymedi,boxysize)
3614           if (ymedi.lt.0) ymedi=ymedi+boxysize
3615           zmedi=mod(zmedi,boxzsize)
3616           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3617           zmedi2=mod(zmedi,boxzsize)
3618           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3619        if ((zmedi2.gt.bordlipbot)
3620      &.and.(zmedi2.lt.bordliptop)) then
3621 C the energy transfer exist
3622         if (zmedi2.lt.buflipbot) then
3623 C what fraction I am in
3624          fracinbuf=1.0d0-
3625      &        ((zmedi2-bordlipbot)/lipbufthick)
3626 C lipbufthick is thickenes of lipid buffore
3627          sslipi=sscalelip(fracinbuf)
3628          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3629         elseif (zmedi2.gt.bufliptop) then
3630          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3631          sslipi=sscalelip(fracinbuf)
3632          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3633         else
3634          sslipi=1.0d0
3635          ssgradlipi=0.0d0
3636         endif
3637        else
3638          sslipi=0.0d0
3639          ssgradlipi=0.0d0
3640        endif
3641         num_conti=0
3642         call eelecij(i,i+2,ees,evdw1,eel_loc)
3643         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3644         num_cont_hb(i)=num_conti
3645       enddo
3646       do i=iturn4_start,iturn4_end
3647         if (i.lt.1) cycle
3648         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3649 C changes suggested by Ana to avoid out of bounds
3650 c     & .or.((i+5).gt.nres)
3651 c     & .or.((i-1).le.0)
3652 C end of changes suggested by Ana
3653      &    .or. itype(i+3).eq.ntyp1
3654      &    .or. itype(i+4).eq.ntyp1
3655 c     &    .or. itype(i+5).eq.ntyp1
3656 c     &    .or. itype(i).eq.ntyp1
3657 c     &    .or. itype(i-1).eq.ntyp1
3658      &                             ) cycle
3659         dxi=dc(1,i)
3660         dyi=dc(2,i)
3661         dzi=dc(3,i)
3662         dx_normi=dc_norm(1,i)
3663         dy_normi=dc_norm(2,i)
3664         dz_normi=dc_norm(3,i)
3665         xmedi=c(1,i)+0.5d0*dxi
3666         ymedi=c(2,i)+0.5d0*dyi
3667         zmedi=c(3,i)+0.5d0*dzi
3668 C Return atom into box, boxxsize is size of box in x dimension
3669 c  194   continue
3670 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3671 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3672 C Condition for being inside the proper box
3673 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3674 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3675 c        go to 194
3676 c        endif
3677 c  195   continue
3678 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3679 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3680 C Condition for being inside the proper box
3681 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3682 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3683 c        go to 195
3684 c        endif
3685 c  196   continue
3686 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3687 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3688 C Condition for being inside the proper box
3689 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3690 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3691 c        go to 196
3692 c        endif
3693           xmedi=mod(xmedi,boxxsize)
3694           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3695           ymedi=mod(ymedi,boxysize)
3696           if (ymedi.lt.0) ymedi=ymedi+boxysize
3697           zmedi=mod(zmedi,boxzsize)
3698           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3699           zmedi2=mod(zmedi,boxzsize)
3700           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3701        if ((zmedi2.gt.bordlipbot)
3702      &.and.(zmedi2.lt.bordliptop)) then
3703 C the energy transfer exist
3704         if (zmedi2.lt.buflipbot) then
3705 C what fraction I am in
3706          fracinbuf=1.0d0-
3707      &        ((zmedi2-bordlipbot)/lipbufthick)
3708 C lipbufthick is thickenes of lipid buffore
3709          sslipi=sscalelip(fracinbuf)
3710          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3711         elseif (zmedi2.gt.bufliptop) then
3712          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3713          sslipi=sscalelip(fracinbuf)
3714          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3715         else
3716          sslipi=1.0d0
3717          ssgradlipi=0.0
3718         endif
3719        else
3720          sslipi=0.0d0
3721          ssgradlipi=0.0
3722        endif
3723         num_conti=num_cont_hb(i)
3724 c        write(iout,*) "JESTEM W PETLI"
3725         call eelecij(i,i+3,ees,evdw1,eel_loc)
3726         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3727      &   call eturn4(i,eello_turn4)
3728         num_cont_hb(i)=num_conti
3729       enddo   ! i
3730 C Loop over all neighbouring boxes
3731 C      do xshift=-1,1
3732 C      do yshift=-1,1
3733 C      do zshift=-1,1
3734 c
3735 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3736 c
3737 CTU KURWA
3738       do i=iatel_s,iatel_e
3739 C        do i=75,75
3740 c        if (i.le.1) cycle
3741         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3742 C changes suggested by Ana to avoid out of bounds
3743 c     & .or.((i+2).gt.nres)
3744 c     & .or.((i-1).le.0)
3745 C end of changes by Ana
3746 c     &  .or. itype(i+2).eq.ntyp1
3747 c     &  .or. itype(i-1).eq.ntyp1
3748      &                ) cycle
3749         dxi=dc(1,i)
3750         dyi=dc(2,i)
3751         dzi=dc(3,i)
3752         dx_normi=dc_norm(1,i)
3753         dy_normi=dc_norm(2,i)
3754         dz_normi=dc_norm(3,i)
3755         xmedi=c(1,i)+0.5d0*dxi
3756         ymedi=c(2,i)+0.5d0*dyi
3757         zmedi=c(3,i)+0.5d0*dzi
3758           xmedi=mod(xmedi,boxxsize)
3759           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3760           ymedi=mod(ymedi,boxysize)
3761           if (ymedi.lt.0) ymedi=ymedi+boxysize
3762           zmedi=mod(zmedi,boxzsize)
3763           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3764        if ((zmedi.gt.bordlipbot)
3765      &.and.(zmedi.lt.bordliptop)) then
3766 C the energy transfer exist
3767         if (zmedi.lt.buflipbot) then
3768 C what fraction I am in
3769          fracinbuf=1.0d0-
3770      &        ((zmedi-bordlipbot)/lipbufthick)
3771 C lipbufthick is thickenes of lipid buffore
3772          sslipi=sscalelip(fracinbuf)
3773          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3774         elseif (zmedi.gt.bufliptop) then
3775          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3776          sslipi=sscalelip(fracinbuf)
3777          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3778         else
3779          sslipi=1.0d0
3780          ssgradlipi=0.0
3781         endif
3782        else
3783          sslipi=0.0d0
3784          ssgradlipi=0.0
3785        endif
3786 C         print *,sslipi,"TU?!"
3787 C          xmedi=xmedi+xshift*boxxsize
3788 C          ymedi=ymedi+yshift*boxysize
3789 C          zmedi=zmedi+zshift*boxzsize
3790
3791 C Return tom into box, boxxsize is size of box in x dimension
3792 c  164   continue
3793 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3794 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3795 C Condition for being inside the proper box
3796 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3797 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3798 c        go to 164
3799 c        endif
3800 c  165   continue
3801 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3802 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3803 C Condition for being inside the proper box
3804 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3805 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3806 c        go to 165
3807 c        endif
3808 c  166   continue
3809 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3810 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3811 cC Condition for being inside the proper box
3812 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3813 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3814 c        go to 166
3815 c        endif
3816
3817 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3818         num_conti=num_cont_hb(i)
3819 C I TU KURWA
3820         do j=ielstart(i),ielend(i)
3821 C          do j=16,17
3822 C          write (iout,*) i,j
3823 C         if (j.le.1) cycle
3824           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3825 C changes suggested by Ana to avoid out of bounds
3826 c     & .or.((j+2).gt.nres)
3827 c     & .or.((j-1).le.0)
3828 C end of changes by Ana
3829 c     & .or.itype(j+2).eq.ntyp1
3830 c     & .or.itype(j-1).eq.ntyp1
3831      &) cycle
3832           call eelecij(i,j,ees,evdw1,eel_loc)
3833         enddo ! j
3834         num_cont_hb(i)=num_conti
3835       enddo   ! i
3836 C     enddo   ! zshift
3837 C      enddo   ! yshift
3838 C      enddo   ! xshift
3839
3840 c      write (iout,*) "Number of loop steps in EELEC:",ind
3841 cd      do i=1,nres
3842 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3843 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3844 cd      enddo
3845 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3846 ccc      eel_loc=eel_loc+eello_turn3
3847 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3848       return
3849       end
3850 C-------------------------------------------------------------------------------
3851       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3852       implicit real*8 (a-h,o-z)
3853       include 'DIMENSIONS'
3854 #ifdef MPI
3855       include "mpif.h"
3856 #endif
3857       include 'COMMON.CONTROL'
3858       include 'COMMON.IOUNITS'
3859       include 'COMMON.GEO'
3860       include 'COMMON.VAR'
3861       include 'COMMON.LOCAL'
3862       include 'COMMON.CHAIN'
3863       include 'COMMON.DERIV'
3864       include 'COMMON.INTERACT'
3865       include 'COMMON.CONTACTS'
3866       include 'COMMON.TORSION'
3867       include 'COMMON.VECTORS'
3868       include 'COMMON.FFIELD'
3869       include 'COMMON.TIME1'
3870       include 'COMMON.SPLITELE'
3871       include 'COMMON.SHIELD'
3872       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3873      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3874       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3875      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3876      &    gmuij2(4),gmuji2(4)
3877       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3878      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3879      &    num_conti,j1,j2
3880 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3881 #ifdef MOMENT
3882       double precision scal_el /1.0d0/
3883 #else
3884       double precision scal_el /0.5d0/
3885 #endif
3886 C 12/13/98
3887 C 13-go grudnia roku pamietnego...
3888       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3889      &                   0.0d0,1.0d0,0.0d0,
3890      &                   0.0d0,0.0d0,1.0d0/
3891        integer xshift,yshift,zshift
3892 c          time00=MPI_Wtime()
3893 cd      write (iout,*) "eelecij",i,j
3894 c          ind=ind+1
3895           iteli=itel(i)
3896           itelj=itel(j)
3897           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3898           aaa=app(iteli,itelj)
3899           bbb=bpp(iteli,itelj)
3900           ael6i=ael6(iteli,itelj)
3901           ael3i=ael3(iteli,itelj)
3902           dxj=dc(1,j)
3903           dyj=dc(2,j)
3904           dzj=dc(3,j)
3905           dx_normj=dc_norm(1,j)
3906           dy_normj=dc_norm(2,j)
3907           dz_normj=dc_norm(3,j)
3908 C          xj=c(1,j)+0.5D0*dxj-xmedi
3909 C          yj=c(2,j)+0.5D0*dyj-ymedi
3910 C          zj=c(3,j)+0.5D0*dzj-zmedi
3911           xj=c(1,j)+0.5D0*dxj
3912           yj=c(2,j)+0.5D0*dyj
3913           zj=c(3,j)+0.5D0*dzj
3914           xj=mod(xj,boxxsize)
3915           if (xj.lt.0) xj=xj+boxxsize
3916           yj=mod(yj,boxysize)
3917           if (yj.lt.0) yj=yj+boxysize
3918           zj=mod(zj,boxzsize)
3919           if (zj.lt.0) zj=zj+boxzsize
3920           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3921        if ((zj.gt.bordlipbot)
3922      &.and.(zj.lt.bordliptop)) then
3923 C the energy transfer exist
3924         if (zj.lt.buflipbot) then
3925 C what fraction I am in
3926          fracinbuf=1.0d0-
3927      &        ((zj-bordlipbot)/lipbufthick)
3928 C lipbufthick is thickenes of lipid buffore
3929          sslipj=sscalelip(fracinbuf)
3930          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3931         elseif (zj.gt.bufliptop) then
3932          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3933          sslipj=sscalelip(fracinbuf)
3934          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3935         else
3936          sslipj=1.0d0
3937          ssgradlipj=0.0
3938         endif
3939        else
3940          sslipj=0.0d0
3941          ssgradlipj=0.0
3942        endif
3943       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3944       xj_safe=xj
3945       yj_safe=yj
3946       zj_safe=zj
3947       isubchap=0
3948       do xshift=-1,1
3949       do yshift=-1,1
3950       do zshift=-1,1
3951           xj=xj_safe+xshift*boxxsize
3952           yj=yj_safe+yshift*boxysize
3953           zj=zj_safe+zshift*boxzsize
3954           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3955           if(dist_temp.lt.dist_init) then
3956             dist_init=dist_temp
3957             xj_temp=xj
3958             yj_temp=yj
3959             zj_temp=zj
3960             isubchap=1
3961           endif
3962        enddo
3963        enddo
3964        enddo
3965        if (isubchap.eq.1) then
3966           xj=xj_temp-xmedi
3967           yj=yj_temp-ymedi
3968           zj=zj_temp-zmedi
3969        else
3970           xj=xj_safe-xmedi
3971           yj=yj_safe-ymedi
3972           zj=zj_safe-zmedi
3973        endif
3974 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3975 c  174   continue
3976 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3977 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3978 C Condition for being inside the proper box
3979 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3980 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3981 c        go to 174
3982 c        endif
3983 c  175   continue
3984 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3985 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3986 C Condition for being inside the proper box
3987 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3988 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3989 c        go to 175
3990 c        endif
3991 c  176   continue
3992 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3993 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3994 C Condition for being inside the proper box
3995 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3996 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3997 c        go to 176
3998 c        endif
3999 C        endif !endPBC condintion
4000 C        xj=xj-xmedi
4001 C        yj=yj-ymedi
4002 C        zj=zj-zmedi
4003           rij=xj*xj+yj*yj+zj*zj
4004
4005             sss=sscale(sqrt(rij))
4006             sssgrad=sscagrad(sqrt(rij))
4007 c            if (sss.gt.0.0d0) then
4008           rrmij=1.0D0/rij
4009           rij=dsqrt(rij)
4010           rmij=1.0D0/rij
4011           r3ij=rrmij*rmij
4012           r6ij=r3ij*r3ij
4013           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4014           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4015           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4016           fac=cosa-3.0D0*cosb*cosg
4017           ev1=aaa*r6ij*r6ij
4018 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4019           if (j.eq.i+2) ev1=scal_el*ev1
4020           ev2=bbb*r6ij
4021           fac3=ael6i*r6ij
4022           fac4=ael3i*r3ij
4023           evdwij=(ev1+ev2)
4024           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4025           el2=fac4*fac
4026 C MARYSIA
4027 C          eesij=(el1+el2)
4028 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4029           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4030           if (shield_mode.gt.0) then
4031 C          fac_shield(i)=0.4
4032 C          fac_shield(j)=0.6
4033           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4034           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4035           eesij=(el1+el2)
4036           ees=ees+eesij
4037 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
4038 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4039           else
4040           fac_shield(i)=1.0
4041           fac_shield(j)=1.0
4042           eesij=(el1+el2)
4043           ees=ees+eesij
4044      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4045 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4046           endif
4047           evdw1=evdw1+evdwij*sss
4048      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4049 C          print *,sslipi,sslipj,lipscale**2,
4050 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4051 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4052 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4053 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4054 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4055
4056           if (energy_dec) then
4057               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4058      &'evdw1',i,j,evdwij
4059      &,iteli,itelj,aaa,evdw1
4060               write (iout,*) sss
4061               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4062      &fac_shield(i),fac_shield(j)
4063           endif
4064
4065 C
4066 C Calculate contributions to the Cartesian gradient.
4067 C
4068 #ifdef SPLITELE
4069           facvdw=-6*rrmij*(ev1+evdwij)*sss
4070      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4071           facel=-3*rrmij*(el1+eesij)
4072      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4073           fac1=fac
4074           erij(1)=xj*rmij
4075           erij(2)=yj*rmij
4076           erij(3)=zj*rmij
4077
4078 *
4079 * Radial derivatives. First process both termini of the fragment (i,j)
4080 *
4081           ggg(1)=facel*xj
4082           ggg(2)=facel*yj
4083           ggg(3)=facel*zj
4084           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4085      &  (shield_mode.gt.0)) then
4086 C          print *,i,j
4087           do ilist=1,ishield_list(i)
4088            iresshield=shield_list(ilist,i)
4089            do k=1,3
4090            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4091      &      *2.0
4092            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4093      &              rlocshield
4094      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4095             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4096 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4097 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4098 C             if (iresshield.gt.i) then
4099 C               do ishi=i+1,iresshield-1
4100 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4101 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4102 C
4103 C              enddo
4104 C             else
4105 C               do ishi=iresshield,i
4106 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4107 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4108 C
4109 C               enddo
4110 C              endif
4111            enddo
4112           enddo
4113           do ilist=1,ishield_list(j)
4114            iresshield=shield_list(ilist,j)
4115            do k=1,3
4116            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4117      &     *2.0
4118            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4119      &              rlocshield
4120      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4121            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4122
4123 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4124 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4125 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4126 C             if (iresshield.gt.j) then
4127 C               do ishi=j+1,iresshield-1
4128 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4129 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4130 C
4131 C               enddo
4132 C            else
4133 C               do ishi=iresshield,j
4134 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4135 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4136 C               enddo
4137 C              endif
4138            enddo
4139           enddo
4140
4141           do k=1,3
4142             gshieldc(k,i)=gshieldc(k,i)+
4143      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4144             gshieldc(k,j)=gshieldc(k,j)+
4145      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4146             gshieldc(k,i-1)=gshieldc(k,i-1)+
4147      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4148             gshieldc(k,j-1)=gshieldc(k,j-1)+
4149      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4150
4151            enddo
4152            endif
4153 c          do k=1,3
4154 c            ghalf=0.5D0*ggg(k)
4155 c            gelc(k,i)=gelc(k,i)+ghalf
4156 c            gelc(k,j)=gelc(k,j)+ghalf
4157 c          enddo
4158 c 9/28/08 AL Gradient compotents will be summed only at the end
4159 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4160           do k=1,3
4161             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4162 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4163             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4164 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4165 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4166 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4167 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4168 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4169           enddo
4170 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4171 C Lipidic part for lipscale
4172             gelc_long(3,j)=gelc_long(3,j)+
4173      &     ssgradlipj*eesij/2.0d0*lipscale**2
4174
4175             gelc_long(3,i)=gelc_long(3,i)+
4176      &     ssgradlipi*eesij/2.0d0*lipscale**2
4177
4178 *
4179 * Loop over residues i+1 thru j-1.
4180 *
4181 cgrad          do k=i+1,j-1
4182 cgrad            do l=1,3
4183 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4184 cgrad            enddo
4185 cgrad          enddo
4186           if (sss.gt.0.0) then
4187           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4188      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4189
4190           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4191      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4192
4193           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4194      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4195           else
4196           ggg(1)=0.0
4197           ggg(2)=0.0
4198           ggg(3)=0.0
4199           endif
4200 c          do k=1,3
4201 c            ghalf=0.5D0*ggg(k)
4202 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4203 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4204 c          enddo
4205 c 9/28/08 AL Gradient compotents will be summed only at the end
4206           do k=1,3
4207             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4208             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4209           enddo
4210 C Lipidic part for scaling weight
4211            gvdwpp(3,j)=gvdwpp(3,j)+
4212      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4213            gvdwpp(3,i)=gvdwpp(3,i)+
4214      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4215
4216 *
4217 * Loop over residues i+1 thru j-1.
4218 *
4219 cgrad          do k=i+1,j-1
4220 cgrad            do l=1,3
4221 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4222 cgrad            enddo
4223 cgrad          enddo
4224 #else
4225 C MARYSIA
4226           facvdw=(ev1+evdwij)*sss
4227      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4228           facel=(el1+eesij)
4229           fac1=fac
4230           fac=-3*rrmij*(facvdw+facvdw+facel)
4231           erij(1)=xj*rmij
4232           erij(2)=yj*rmij
4233           erij(3)=zj*rmij
4234 *
4235 * Radial derivatives. First process both termini of the fragment (i,j)
4236 *
4237           ggg(1)=fac*xj
4238 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4239           ggg(2)=fac*yj
4240 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4241           ggg(3)=fac*zj
4242 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4243 c          do k=1,3
4244 c            ghalf=0.5D0*ggg(k)
4245 c            gelc(k,i)=gelc(k,i)+ghalf
4246 c            gelc(k,j)=gelc(k,j)+ghalf
4247 c          enddo
4248 c 9/28/08 AL Gradient compotents will be summed only at the end
4249           do k=1,3
4250             gelc_long(k,j)=gelc(k,j)+ggg(k)
4251             gelc_long(k,i)=gelc(k,i)-ggg(k)
4252           enddo
4253 *
4254 * Loop over residues i+1 thru j-1.
4255 *
4256 cgrad          do k=i+1,j-1
4257 cgrad            do l=1,3
4258 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4259 cgrad            enddo
4260 cgrad          enddo
4261 c 9/28/08 AL Gradient compotents will be summed only at the end
4262           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4263      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4264
4265           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4266      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4267
4268           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4269      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4270           do k=1,3
4271             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4272             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4273           enddo
4274            gvdwpp(3,j)=gvdwpp(3,j)+
4275      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4276            gvdwpp(3,i)=gvdwpp(3,i)+
4277      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4278
4279 #endif
4280 *
4281 * Angular part
4282 *
4283           ecosa=2.0D0*fac3*fac1+fac4
4284           fac4=-3.0D0*fac4
4285           fac3=-6.0D0*fac3
4286           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4287           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4288           do k=1,3
4289             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4290             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4291           enddo
4292 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4293 cd   &          (dcosg(k),k=1,3)
4294           do k=1,3
4295             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4296      &      fac_shield(i)**2*fac_shield(j)**2
4297      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4298           enddo
4299 c          do k=1,3
4300 c            ghalf=0.5D0*ggg(k)
4301 c            gelc(k,i)=gelc(k,i)+ghalf
4302 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4303 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4304 c            gelc(k,j)=gelc(k,j)+ghalf
4305 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4306 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4307 c          enddo
4308 cgrad          do k=i+1,j-1
4309 cgrad            do l=1,3
4310 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4311 cgrad            enddo
4312 cgrad          enddo
4313 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4314           do k=1,3
4315             gelc(k,i)=gelc(k,i)
4316      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4317      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4318      &           *fac_shield(i)**2*fac_shield(j)**2
4319      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4320             gelc(k,j)=gelc(k,j)
4321      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4322      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4323      &           *fac_shield(i)**2*fac_shield(j)**2
4324      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4325             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4326             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4327           enddo
4328 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4329
4330 C MARYSIA
4331 c          endif !sscale
4332           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4333      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4334      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4335 C
4336 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4337 C   energy of a peptide unit is assumed in the form of a second-order
4338 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4339 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4340 C   are computed for EVERY pair of non-contiguous peptide groups.
4341 C
4342
4343           if (j.lt.nres-1) then
4344             j1=j+1
4345             j2=j-1
4346           else
4347             j1=j-1
4348             j2=j-2
4349           endif
4350           kkk=0
4351           lll=0
4352           do k=1,2
4353             do l=1,2
4354               kkk=kkk+1
4355               muij(kkk)=mu(k,i)*mu(l,j)
4356 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4357 #ifdef NEWCORR
4358              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4359 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4360              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4361              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4362 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4363              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4364 #endif
4365             enddo
4366           enddo
4367 cd         write (iout,*) 'EELEC: i',i,' j',j
4368 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4369 cd          write(iout,*) 'muij',muij
4370           ury=scalar(uy(1,i),erij)
4371           urz=scalar(uz(1,i),erij)
4372           vry=scalar(uy(1,j),erij)
4373           vrz=scalar(uz(1,j),erij)
4374           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4375           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4376           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4377           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4378           fac=dsqrt(-ael6i)*r3ij
4379           a22=a22*fac
4380           a23=a23*fac
4381           a32=a32*fac
4382           a33=a33*fac
4383 cd          write (iout,'(4i5,4f10.5)')
4384 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4385 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4386 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4387 cd     &      uy(:,j),uz(:,j)
4388 cd          write (iout,'(4f10.5)')
4389 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4390 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4391 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4392 cd           write (iout,'(9f10.5/)')
4393 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4394 C Derivatives of the elements of A in virtual-bond vectors
4395           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4396           do k=1,3
4397             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4398             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4399             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4400             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4401             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4402             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4403             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4404             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4405             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4406             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4407             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4408             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4409           enddo
4410 C Compute radial contributions to the gradient
4411           facr=-3.0d0*rrmij
4412           a22der=a22*facr
4413           a23der=a23*facr
4414           a32der=a32*facr
4415           a33der=a33*facr
4416           agg(1,1)=a22der*xj
4417           agg(2,1)=a22der*yj
4418           agg(3,1)=a22der*zj
4419           agg(1,2)=a23der*xj
4420           agg(2,2)=a23der*yj
4421           agg(3,2)=a23der*zj
4422           agg(1,3)=a32der*xj
4423           agg(2,3)=a32der*yj
4424           agg(3,3)=a32der*zj
4425           agg(1,4)=a33der*xj
4426           agg(2,4)=a33der*yj
4427           agg(3,4)=a33der*zj
4428 C Add the contributions coming from er
4429           fac3=-3.0d0*fac
4430           do k=1,3
4431             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4432             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4433             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4434             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4435           enddo
4436           do k=1,3
4437 C Derivatives in DC(i)
4438 cgrad            ghalf1=0.5d0*agg(k,1)
4439 cgrad            ghalf2=0.5d0*agg(k,2)
4440 cgrad            ghalf3=0.5d0*agg(k,3)
4441 cgrad            ghalf4=0.5d0*agg(k,4)
4442             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4443      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4444             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4445      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4446             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4447      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4448             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4449      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4450 C Derivatives in DC(i+1)
4451             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4452      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4453             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4454      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4455             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4456      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4457             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4458      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4459 C Derivatives in DC(j)
4460             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4461      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4462             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4463      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4464             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4465      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4466             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4467      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4468 C Derivatives in DC(j+1) or DC(nres-1)
4469             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4470      &      -3.0d0*vryg(k,3)*ury)
4471             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4472      &      -3.0d0*vrzg(k,3)*ury)
4473             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4474      &      -3.0d0*vryg(k,3)*urz)
4475             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4476      &      -3.0d0*vrzg(k,3)*urz)
4477 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4478 cgrad              do l=1,4
4479 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4480 cgrad              enddo
4481 cgrad            endif
4482           enddo
4483           acipa(1,1)=a22
4484           acipa(1,2)=a23
4485           acipa(2,1)=a32
4486           acipa(2,2)=a33
4487           a22=-a22
4488           a23=-a23
4489           do l=1,2
4490             do k=1,3
4491               agg(k,l)=-agg(k,l)
4492               aggi(k,l)=-aggi(k,l)
4493               aggi1(k,l)=-aggi1(k,l)
4494               aggj(k,l)=-aggj(k,l)
4495               aggj1(k,l)=-aggj1(k,l)
4496             enddo
4497           enddo
4498           if (j.lt.nres-1) then
4499             a22=-a22
4500             a32=-a32
4501             do l=1,3,2
4502               do k=1,3
4503                 agg(k,l)=-agg(k,l)
4504                 aggi(k,l)=-aggi(k,l)
4505                 aggi1(k,l)=-aggi1(k,l)
4506                 aggj(k,l)=-aggj(k,l)
4507                 aggj1(k,l)=-aggj1(k,l)
4508               enddo
4509             enddo
4510           else
4511             a22=-a22
4512             a23=-a23
4513             a32=-a32
4514             a33=-a33
4515             do l=1,4
4516               do k=1,3
4517                 agg(k,l)=-agg(k,l)
4518                 aggi(k,l)=-aggi(k,l)
4519                 aggi1(k,l)=-aggi1(k,l)
4520                 aggj(k,l)=-aggj(k,l)
4521                 aggj1(k,l)=-aggj1(k,l)
4522               enddo
4523             enddo
4524           endif
4525           ENDIF ! WCORR
4526           IF (wel_loc.gt.0.0d0) THEN
4527 C Contribution to the local-electrostatic energy coming from the i-j pair
4528           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4529      &     +a33*muij(4)
4530           if (shield_mode.eq.0) then
4531            fac_shield(i)=1.0
4532            fac_shield(j)=1.0
4533 C          else
4534 C           fac_shield(i)=0.4
4535 C           fac_shield(j)=0.6
4536           endif
4537           eel_loc_ij=eel_loc_ij
4538      &    *fac_shield(i)*fac_shield(j)
4539      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4540
4541 C Now derivative over eel_loc
4542           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4543      &  (shield_mode.gt.0)) then
4544 C          print *,i,j
4545
4546           do ilist=1,ishield_list(i)
4547            iresshield=shield_list(ilist,i)
4548            do k=1,3
4549            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4550      &                                          /fac_shield(i)
4551 C     &      *2.0
4552            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4553      &              rlocshield
4554      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4555             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4556      &      +rlocshield
4557            enddo
4558           enddo
4559           do ilist=1,ishield_list(j)
4560            iresshield=shield_list(ilist,j)
4561            do k=1,3
4562            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4563      &                                       /fac_shield(j)
4564 C     &     *2.0
4565            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4566      &              rlocshield
4567      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4568            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4569      &             +rlocshield
4570
4571            enddo
4572           enddo
4573
4574           do k=1,3
4575             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4576      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4577             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4578      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4579             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4580      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4581             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4582      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4583            enddo
4584            endif
4585
4586
4587 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4588 c     &                     ' eel_loc_ij',eel_loc_ij
4589 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4590 C Calculate patrial derivative for theta angle
4591 #ifdef NEWCORR
4592          geel_loc_ij=(a22*gmuij1(1)
4593      &     +a23*gmuij1(2)
4594      &     +a32*gmuij1(3)
4595      &     +a33*gmuij1(4))
4596      &    *fac_shield(i)*fac_shield(j)
4597      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4598
4599 c         write(iout,*) "derivative over thatai"
4600 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4601 c     &   a33*gmuij1(4)
4602          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4603      &      geel_loc_ij*wel_loc
4604 c         write(iout,*) "derivative over thatai-1"
4605 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4606 c     &   a33*gmuij2(4)
4607          geel_loc_ij=
4608      &     a22*gmuij2(1)
4609      &     +a23*gmuij2(2)
4610      &     +a32*gmuij2(3)
4611      &     +a33*gmuij2(4)
4612          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4613      &      geel_loc_ij*wel_loc
4614      &    *fac_shield(i)*fac_shield(j)
4615      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4616
4617
4618 c  Derivative over j residue
4619          geel_loc_ji=a22*gmuji1(1)
4620      &     +a23*gmuji1(2)
4621      &     +a32*gmuji1(3)
4622      &     +a33*gmuji1(4)
4623 c         write(iout,*) "derivative over thataj"
4624 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4625 c     &   a33*gmuji1(4)
4626
4627         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4628      &      geel_loc_ji*wel_loc
4629      &    *fac_shield(i)*fac_shield(j)
4630      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4631
4632          geel_loc_ji=
4633      &     +a22*gmuji2(1)
4634      &     +a23*gmuji2(2)
4635      &     +a32*gmuji2(3)
4636      &     +a33*gmuji2(4)
4637 c         write(iout,*) "derivative over thataj-1"
4638 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4639 c     &   a33*gmuji2(4)
4640          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4641      &      geel_loc_ji*wel_loc
4642      &    *fac_shield(i)*fac_shield(j)
4643      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4644
4645 #endif
4646 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4647
4648           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4649      &            'eelloc',i,j,eel_loc_ij
4650 c           if (eel_loc_ij.ne.0)
4651 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4652 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4653
4654           eel_loc=eel_loc+eel_loc_ij
4655 C Partial derivatives in virtual-bond dihedral angles gamma
4656           if (i.gt.1)
4657      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4658      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4659      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4660      &    *fac_shield(i)*fac_shield(j)
4661      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4662
4663           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4664      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4665      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4666      &    *fac_shield(i)*fac_shield(j)
4667      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4668
4669 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4670           do l=1,3
4671             ggg(l)=(agg(l,1)*muij(1)+
4672      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4673      &    *fac_shield(i)*fac_shield(j)
4674      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4675
4676             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4677             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4678 cgrad            ghalf=0.5d0*ggg(l)
4679 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4680 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4681           enddo
4682             gel_loc_long(3,j)=gel_loc_long(3,j)+
4683      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4684      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4685
4686             gel_loc_long(3,i)=gel_loc_long(3,i)+
4687      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4688      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4689
4690 cgrad          do k=i+1,j2
4691 cgrad            do l=1,3
4692 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4693 cgrad            enddo
4694 cgrad          enddo
4695 C Remaining derivatives of eello
4696           do l=1,3
4697             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4698      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4699      &    *fac_shield(i)*fac_shield(j)
4700      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4701
4702             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4703      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4704      &    *fac_shield(i)*fac_shield(j)
4705      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4706
4707             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4708      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4709      &    *fac_shield(i)*fac_shield(j)
4710      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4711
4712             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4713      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4714      &    *fac_shield(i)*fac_shield(j)
4715      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4716
4717           enddo
4718           ENDIF
4719 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4720 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4721           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4722      &       .and. num_conti.le.maxconts) then
4723 c            write (iout,*) i,j," entered corr"
4724 C
4725 C Calculate the contact function. The ith column of the array JCONT will
4726 C contain the numbers of atoms that make contacts with the atom I (of numbers
4727 C greater than I). The arrays FACONT and GACONT will contain the values of
4728 C the contact function and its derivative.
4729 c           r0ij=1.02D0*rpp(iteli,itelj)
4730 c           r0ij=1.11D0*rpp(iteli,itelj)
4731             r0ij=2.20D0*rpp(iteli,itelj)
4732 c           r0ij=1.55D0*rpp(iteli,itelj)
4733             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4734             if (fcont.gt.0.0D0) then
4735               num_conti=num_conti+1
4736               if (num_conti.gt.maxconts) then
4737                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4738      &                         ' will skip next contacts for this conf.'
4739               else
4740                 jcont_hb(num_conti,i)=j
4741 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4742 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4743                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4744      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4745 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4746 C  terms.
4747                 d_cont(num_conti,i)=rij
4748 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4749 C     --- Electrostatic-interaction matrix ---
4750                 a_chuj(1,1,num_conti,i)=a22
4751                 a_chuj(1,2,num_conti,i)=a23
4752                 a_chuj(2,1,num_conti,i)=a32
4753                 a_chuj(2,2,num_conti,i)=a33
4754 C     --- Gradient of rij
4755                 do kkk=1,3
4756                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4757                 enddo
4758                 kkll=0
4759                 do k=1,2
4760                   do l=1,2
4761                     kkll=kkll+1
4762                     do m=1,3
4763                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4764                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4765                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4766                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4767                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4768                     enddo
4769                   enddo
4770                 enddo
4771                 ENDIF
4772                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4773 C Calculate contact energies
4774                 cosa4=4.0D0*cosa
4775                 wij=cosa-3.0D0*cosb*cosg
4776                 cosbg1=cosb+cosg
4777                 cosbg2=cosb-cosg
4778 c               fac3=dsqrt(-ael6i)/r0ij**3
4779                 fac3=dsqrt(-ael6i)*r3ij
4780 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4781                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4782                 if (ees0tmp.gt.0) then
4783                   ees0pij=dsqrt(ees0tmp)
4784                 else
4785                   ees0pij=0
4786                 endif
4787 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4788                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4789                 if (ees0tmp.gt.0) then
4790                   ees0mij=dsqrt(ees0tmp)
4791                 else
4792                   ees0mij=0
4793                 endif
4794 c               ees0mij=0.0D0
4795                 if (shield_mode.eq.0) then
4796                 fac_shield(i)=1.0d0
4797                 fac_shield(j)=1.0d0
4798                 else
4799                 ees0plist(num_conti,i)=j
4800 C                fac_shield(i)=0.4d0
4801 C                fac_shield(j)=0.6d0
4802                 endif
4803                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4804      &          *fac_shield(i)*fac_shield(j)
4805                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4806      &          *fac_shield(i)*fac_shield(j)
4807 C Diagnostics. Comment out or remove after debugging!
4808 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4809 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4810 c               ees0m(num_conti,i)=0.0D0
4811 C End diagnostics.
4812 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4813 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4814 C Angular derivatives of the contact function
4815                 ees0pij1=fac3/ees0pij
4816                 ees0mij1=fac3/ees0mij
4817                 fac3p=-3.0D0*fac3*rrmij
4818                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4819                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4820 c               ees0mij1=0.0D0
4821                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4822                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4823                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4824                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4825                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4826                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4827                 ecosap=ecosa1+ecosa2
4828                 ecosbp=ecosb1+ecosb2
4829                 ecosgp=ecosg1+ecosg2
4830                 ecosam=ecosa1-ecosa2
4831                 ecosbm=ecosb1-ecosb2
4832                 ecosgm=ecosg1-ecosg2
4833 C Diagnostics
4834 c               ecosap=ecosa1
4835 c               ecosbp=ecosb1
4836 c               ecosgp=ecosg1
4837 c               ecosam=0.0D0
4838 c               ecosbm=0.0D0
4839 c               ecosgm=0.0D0
4840 C End diagnostics
4841                 facont_hb(num_conti,i)=fcont
4842                 fprimcont=fprimcont/rij
4843 cd              facont_hb(num_conti,i)=1.0D0
4844 C Following line is for diagnostics.
4845 cd              fprimcont=0.0D0
4846                 do k=1,3
4847                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4848                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4849                 enddo
4850                 do k=1,3
4851                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4852                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4853                 enddo
4854                 gggp(1)=gggp(1)+ees0pijp*xj
4855                 gggp(2)=gggp(2)+ees0pijp*yj
4856                 gggp(3)=gggp(3)+ees0pijp*zj
4857                 gggm(1)=gggm(1)+ees0mijp*xj
4858                 gggm(2)=gggm(2)+ees0mijp*yj
4859                 gggm(3)=gggm(3)+ees0mijp*zj
4860 C Derivatives due to the contact function
4861                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4862                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4863                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4864                 do k=1,3
4865 c
4866 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4867 c          following the change of gradient-summation algorithm.
4868 c
4869 cgrad                  ghalfp=0.5D0*gggp(k)
4870 cgrad                  ghalfm=0.5D0*gggm(k)
4871                   gacontp_hb1(k,num_conti,i)=!ghalfp
4872      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4873      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4874      &          *fac_shield(i)*fac_shield(j)
4875
4876                   gacontp_hb2(k,num_conti,i)=!ghalfp
4877      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4878      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4879      &          *fac_shield(i)*fac_shield(j)
4880
4881                   gacontp_hb3(k,num_conti,i)=gggp(k)
4882      &          *fac_shield(i)*fac_shield(j)
4883
4884                   gacontm_hb1(k,num_conti,i)=!ghalfm
4885      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4886      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4887      &          *fac_shield(i)*fac_shield(j)
4888
4889                   gacontm_hb2(k,num_conti,i)=!ghalfm
4890      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4891      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4892      &          *fac_shield(i)*fac_shield(j)
4893
4894                   gacontm_hb3(k,num_conti,i)=gggm(k)
4895      &          *fac_shield(i)*fac_shield(j)
4896
4897                 enddo
4898 C Diagnostics. Comment out or remove after debugging!
4899 cdiag           do k=1,3
4900 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4901 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4902 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4903 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4904 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4905 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4906 cdiag           enddo
4907               ENDIF ! wcorr
4908               endif  ! num_conti.le.maxconts
4909             endif  ! fcont.gt.0
4910           endif    ! j.gt.i+1
4911           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4912             do k=1,4
4913               do l=1,3
4914                 ghalf=0.5d0*agg(l,k)
4915                 aggi(l,k)=aggi(l,k)+ghalf
4916                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4917                 aggj(l,k)=aggj(l,k)+ghalf
4918               enddo
4919             enddo
4920             if (j.eq.nres-1 .and. i.lt.j-2) then
4921               do k=1,4
4922                 do l=1,3
4923                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4924                 enddo
4925               enddo
4926             endif
4927           endif
4928 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4929       return
4930       end
4931 C-----------------------------------------------------------------------------
4932       subroutine eturn3(i,eello_turn3)
4933 C Third- and fourth-order contributions from turns
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'COMMON.IOUNITS'
4937       include 'COMMON.GEO'
4938       include 'COMMON.VAR'
4939       include 'COMMON.LOCAL'
4940       include 'COMMON.CHAIN'
4941       include 'COMMON.DERIV'
4942       include 'COMMON.INTERACT'
4943       include 'COMMON.CONTACTS'
4944       include 'COMMON.TORSION'
4945       include 'COMMON.VECTORS'
4946       include 'COMMON.FFIELD'
4947       include 'COMMON.CONTROL'
4948       include 'COMMON.SHIELD'
4949       dimension ggg(3)
4950       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4951      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4952      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4953      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4954      &  auxgmat2(2,2),auxgmatt2(2,2)
4955       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4956      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4957       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4958      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4959      &    num_conti,j1,j2
4960       j=i+2
4961 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4962 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4963           zj=(c(3,j)+c(3,j+1))/2.0d0
4964 C          xj=mod(xj,boxxsize)
4965 C          if (xj.lt.0) xj=xj+boxxsize
4966 C          yj=mod(yj,boxysize)
4967 C          if (yj.lt.0) yj=yj+boxysize
4968           zj=mod(zj,boxzsize)
4969           if (zj.lt.0) zj=zj+boxzsize
4970           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4971        if ((zj.gt.bordlipbot)
4972      &.and.(zj.lt.bordliptop)) then
4973 C the energy transfer exist
4974         if (zj.lt.buflipbot) then
4975 C what fraction I am in
4976          fracinbuf=1.0d0-
4977      &        ((zj-bordlipbot)/lipbufthick)
4978 C lipbufthick is thickenes of lipid buffore
4979          sslipj=sscalelip(fracinbuf)
4980          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4981         elseif (zj.gt.bufliptop) then
4982          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4983          sslipj=sscalelip(fracinbuf)
4984          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4985         else
4986          sslipj=1.0d0
4987          ssgradlipj=0.0
4988         endif
4989        else
4990          sslipj=0.0d0
4991          ssgradlipj=0.0
4992        endif
4993 C      sslipj=0.0
4994 C      ssgradlipj=0.0d0
4995
4996 C      write (iout,*) "eturn3",i,j,j1,j2
4997       a_temp(1,1)=a22
4998       a_temp(1,2)=a23
4999       a_temp(2,1)=a32
5000       a_temp(2,2)=a33
5001 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5002 C
5003 C               Third-order contributions
5004 C
5005 C                 (i+2)o----(i+3)
5006 C                      | |
5007 C                      | |
5008 C                 (i+1)o----i
5009 C
5010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5011 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5012         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5013 c auxalary matices for theta gradient
5014 c auxalary matrix for i+1 and constant i+2
5015         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5016 c auxalary matrix for i+2 and constant i+1
5017         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5018         call transpose2(auxmat(1,1),auxmat1(1,1))
5019         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5020         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5021         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5022         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5023         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5024         if (shield_mode.eq.0) then
5025         fac_shield(i)=1.0d0
5026         fac_shield(j)=1.0d0
5027 C        else
5028 C        fac_shield(i)=0.4
5029 C        fac_shield(j)=0.6
5030         endif
5031 C         if (j.eq.78)
5032 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
5033         eello_turn3=eello_turn3+
5034 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5035      &0.5d0*(pizda(1,1)+pizda(2,2))
5036      &  *fac_shield(i)*fac_shield(j)
5037      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5038         eello_t3=
5039      &0.5d0*(pizda(1,1)+pizda(2,2))
5040      &  *fac_shield(i)*fac_shield(j)
5041 #ifdef NEWCORR
5042 C Derivatives in theta
5043         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5044      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5045      &   *fac_shield(i)*fac_shield(j)
5046      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5047
5048         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5049      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5050      &   *fac_shield(i)*fac_shield(j)
5051      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5052
5053 #endif
5054
5055 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5056 C Derivatives in shield mode
5057           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5058      &  (shield_mode.gt.0)) then
5059 C          print *,i,j
5060
5061           do ilist=1,ishield_list(i)
5062            iresshield=shield_list(ilist,i)
5063            do k=1,3
5064            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5065 C     &      *2.0
5066            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5067      &              rlocshield
5068      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5069             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5070      &      +rlocshield
5071            enddo
5072           enddo
5073           do ilist=1,ishield_list(j)
5074            iresshield=shield_list(ilist,j)
5075            do k=1,3
5076            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5077 C     &     *2.0
5078            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5079      &              rlocshield
5080      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5081            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5082      &             +rlocshield
5083
5084            enddo
5085           enddo
5086
5087           do k=1,3
5088             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5089      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5090             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5091      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5092             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5093      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5094             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5095      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5096            enddo
5097            endif
5098
5099 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5100 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5101 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5102 cd     &    ' eello_turn3_num',4*eello_turn3_num
5103 C Derivatives in gamma(i)
5104         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5105         call transpose2(auxmat2(1,1),auxmat3(1,1))
5106         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5107         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5108      &   *fac_shield(i)*fac_shield(j)
5109      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5110
5111 C Derivatives in gamma(i+1)
5112         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5113         call transpose2(auxmat2(1,1),auxmat3(1,1))
5114         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5115         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5116      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5117      &   *fac_shield(i)*fac_shield(j)
5118      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5119
5120 C Cartesian derivatives
5121         do l=1,3
5122 c            ghalf1=0.5d0*agg(l,1)
5123 c            ghalf2=0.5d0*agg(l,2)
5124 c            ghalf3=0.5d0*agg(l,3)
5125 c            ghalf4=0.5d0*agg(l,4)
5126           a_temp(1,1)=aggi(l,1)!+ghalf1
5127           a_temp(1,2)=aggi(l,2)!+ghalf2
5128           a_temp(2,1)=aggi(l,3)!+ghalf3
5129           a_temp(2,2)=aggi(l,4)!+ghalf4
5130           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5131           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5132      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5133      &   *fac_shield(i)*fac_shield(j)
5134      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5135
5136           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5137           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5138           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5139           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5140           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5141           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5142      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5143      &   *fac_shield(i)*fac_shield(j)
5144      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5145           a_temp(1,1)=aggj(l,1)!+ghalf1
5146           a_temp(1,2)=aggj(l,2)!+ghalf2
5147           a_temp(2,1)=aggj(l,3)!+ghalf3
5148           a_temp(2,2)=aggj(l,4)!+ghalf4
5149           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5150           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5151      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5152      &   *fac_shield(i)*fac_shield(j)
5153      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5154
5155           a_temp(1,1)=aggj1(l,1)
5156           a_temp(1,2)=aggj1(l,2)
5157           a_temp(2,1)=aggj1(l,3)
5158           a_temp(2,2)=aggj1(l,4)
5159           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5160           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5161      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5162      &   *fac_shield(i)*fac_shield(j)
5163      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5164         enddo
5165          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5166      &     ssgradlipi*eello_t3/4.0d0*lipscale
5167          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5168      &     ssgradlipj*eello_t3/4.0d0*lipscale
5169          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5170      &     ssgradlipi*eello_t3/4.0d0*lipscale
5171          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5172      &     ssgradlipj*eello_t3/4.0d0*lipscale
5173
5174 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5175       return
5176       end
5177 C-------------------------------------------------------------------------------
5178       subroutine eturn4(i,eello_turn4)
5179 C Third- and fourth-order contributions from turns
5180       implicit real*8 (a-h,o-z)
5181       include 'DIMENSIONS'
5182       include 'COMMON.IOUNITS'
5183       include 'COMMON.GEO'
5184       include 'COMMON.VAR'
5185       include 'COMMON.LOCAL'
5186       include 'COMMON.CHAIN'
5187       include 'COMMON.DERIV'
5188       include 'COMMON.INTERACT'
5189       include 'COMMON.CONTACTS'
5190       include 'COMMON.TORSION'
5191       include 'COMMON.VECTORS'
5192       include 'COMMON.FFIELD'
5193       include 'COMMON.CONTROL'
5194       include 'COMMON.SHIELD'
5195       dimension ggg(3)
5196       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5197      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5198      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5199      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5200      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5201      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5202      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5203       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5204      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5205       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5206      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5207      &    num_conti,j1,j2
5208       j=i+3
5209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5210 C
5211 C               Fourth-order contributions
5212 C
5213 C                 (i+3)o----(i+4)
5214 C                     /  |
5215 C               (i+2)o   |
5216 C                     \  |
5217 C                 (i+1)o----i
5218 C
5219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5220 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5221 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5222 c        write(iout,*)"WCHODZE W PROGRAM"
5223           zj=(c(3,j)+c(3,j+1))/2.0d0
5224 C          xj=mod(xj,boxxsize)
5225 C          if (xj.lt.0) xj=xj+boxxsize
5226 C          yj=mod(yj,boxysize)
5227 C          if (yj.lt.0) yj=yj+boxysize
5228           zj=mod(zj,boxzsize)
5229           if (zj.lt.0) zj=zj+boxzsize
5230 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5231        if ((zj.gt.bordlipbot)
5232      &.and.(zj.lt.bordliptop)) then
5233 C the energy transfer exist
5234         if (zj.lt.buflipbot) then
5235 C what fraction I am in
5236          fracinbuf=1.0d0-
5237      &        ((zj-bordlipbot)/lipbufthick)
5238 C lipbufthick is thickenes of lipid buffore
5239          sslipj=sscalelip(fracinbuf)
5240          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5241         elseif (zj.gt.bufliptop) then
5242          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5243          sslipj=sscalelip(fracinbuf)
5244          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5245         else
5246          sslipj=1.0d0
5247          ssgradlipj=0.0
5248         endif
5249        else
5250          sslipj=0.0d0
5251          ssgradlipj=0.0
5252        endif
5253
5254         a_temp(1,1)=a22
5255         a_temp(1,2)=a23
5256         a_temp(2,1)=a32
5257         a_temp(2,2)=a33
5258         iti1=itype2loc(itype(i+1))
5259         iti2=itype2loc(itype(i+2))
5260         iti3=itype2loc(itype(i+3))
5261 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5262         call transpose2(EUg(1,1,i+1),e1t(1,1))
5263         call transpose2(Eug(1,1,i+2),e2t(1,1))
5264         call transpose2(Eug(1,1,i+3),e3t(1,1))
5265 C Ematrix derivative in theta
5266         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5267         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5268         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5269         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5270 c       eta1 in derivative theta
5271         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5272         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5273 c       auxgvec is derivative of Ub2 so i+3 theta
5274         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5275 c       auxalary matrix of E i+1
5276         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5277 c        s1=0.0
5278 c        gs1=0.0
5279         s1=scalar2(b1(1,i+2),auxvec(1))
5280 c derivative of theta i+2 with constant i+3
5281         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5282 c derivative of theta i+2 with constant i+2
5283         gs32=scalar2(b1(1,i+2),auxgvec(1))
5284 c derivative of E matix in theta of i+1
5285         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5286
5287         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5288 c       ea31 in derivative theta
5289         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5290         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5291 c auxilary matrix auxgvec of Ub2 with constant E matirx
5292         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5293 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5294         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5295
5296 c        s2=0.0
5297 c        gs2=0.0
5298         s2=scalar2(b1(1,i+1),auxvec(1))
5299 c derivative of theta i+1 with constant i+3
5300         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5301 c derivative of theta i+2 with constant i+1
5302         gs21=scalar2(b1(1,i+1),auxgvec(1))
5303 c derivative of theta i+3 with constant i+1
5304         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5305 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5306 c     &  gtb1(1,i+1)
5307         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5308 c two derivatives over diffetent matrices
5309 c gtae3e2 is derivative over i+3
5310         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5311 c ae3gte2 is derivative over i+2
5312         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5313         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5314 c three possible derivative over theta E matices
5315 c i+1
5316         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5317 c i+2
5318         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5319 c i+3
5320         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5321         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5322
5323         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5324         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5325         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5326         if (shield_mode.eq.0) then
5327         fac_shield(i)=1.0
5328         fac_shield(j)=1.0
5329 C        else
5330 C        fac_shield(i)=0.6
5331 C        fac_shield(j)=0.4
5332         endif
5333         eello_turn4=eello_turn4-(s1+s2+s3)
5334      &  *fac_shield(i)*fac_shield(j)
5335      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5336
5337         eello_t4=-(s1+s2+s3)
5338      &  *fac_shield(i)*fac_shield(j)
5339 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5340         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5341      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5342 C Now derivative over shield:
5343           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5344      &  (shield_mode.gt.0)) then
5345 C          print *,i,j
5346
5347           do ilist=1,ishield_list(i)
5348            iresshield=shield_list(ilist,i)
5349            do k=1,3
5350            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5351 C     &      *2.0
5352            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5353      &              rlocshield
5354      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5355             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5356      &      +rlocshield
5357            enddo
5358           enddo
5359           do ilist=1,ishield_list(j)
5360            iresshield=shield_list(ilist,j)
5361            do k=1,3
5362            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5363 C     &     *2.0
5364            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5365      &              rlocshield
5366      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5367            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5368      &             +rlocshield
5369
5370            enddo
5371           enddo
5372
5373           do k=1,3
5374             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5375      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5376             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5377      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5378             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5379      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5380             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5381      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5382            enddo
5383            endif
5384
5385
5386
5387
5388
5389
5390 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5391 cd     &    ' eello_turn4_num',8*eello_turn4_num
5392 #ifdef NEWCORR
5393         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5394      &                  -(gs13+gsE13+gsEE1)*wturn4
5395      &  *fac_shield(i)*fac_shield(j)
5396      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5397
5398         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5399      &                    -(gs23+gs21+gsEE2)*wturn4
5400      &  *fac_shield(i)*fac_shield(j)
5401      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5402
5403         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5404      &                    -(gs32+gsE31+gsEE3)*wturn4
5405      &  *fac_shield(i)*fac_shield(j)
5406      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5407
5408 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5409 c     &   gs2
5410 #endif
5411         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5412      &      'eturn4',i,j,-(s1+s2+s3)
5413 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5414 c     &    ' eello_turn4_num',8*eello_turn4_num
5415 C Derivatives in gamma(i)
5416         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5417         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5418         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5419         s1=scalar2(b1(1,i+2),auxvec(1))
5420         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5421         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5422         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5423      &  *fac_shield(i)*fac_shield(j)
5424      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5425
5426 C Derivatives in gamma(i+1)
5427         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5428         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5429         s2=scalar2(b1(1,i+1),auxvec(1))
5430         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5431         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5432         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5433         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5434      &  *fac_shield(i)*fac_shield(j)
5435      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5436
5437 C Derivatives in gamma(i+2)
5438         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5439         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5440         s1=scalar2(b1(1,i+2),auxvec(1))
5441         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5442         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5443         s2=scalar2(b1(1,i+1),auxvec(1))
5444         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5445         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5446         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5447         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5448      &  *fac_shield(i)*fac_shield(j)
5449      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5450
5451 C Cartesian derivatives
5452 C Derivatives of this turn contributions in DC(i+2)
5453         if (j.lt.nres-1) then
5454           do l=1,3
5455             a_temp(1,1)=agg(l,1)
5456             a_temp(1,2)=agg(l,2)
5457             a_temp(2,1)=agg(l,3)
5458             a_temp(2,2)=agg(l,4)
5459             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5460             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5461             s1=scalar2(b1(1,i+2),auxvec(1))
5462             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5463             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5464             s2=scalar2(b1(1,i+1),auxvec(1))
5465             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5466             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5467             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5468             ggg(l)=-(s1+s2+s3)
5469             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5470      &  *fac_shield(i)*fac_shield(j)
5471      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5472
5473           enddo
5474         endif
5475 C Remaining derivatives of this turn contribution
5476         do l=1,3
5477           a_temp(1,1)=aggi(l,1)
5478           a_temp(1,2)=aggi(l,2)
5479           a_temp(2,1)=aggi(l,3)
5480           a_temp(2,2)=aggi(l,4)
5481           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5482           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5483           s1=scalar2(b1(1,i+2),auxvec(1))
5484           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5485           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5486           s2=scalar2(b1(1,i+1),auxvec(1))
5487           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5488           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5489           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5490           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5491      &  *fac_shield(i)*fac_shield(j)
5492      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5493
5494           a_temp(1,1)=aggi1(l,1)
5495           a_temp(1,2)=aggi1(l,2)
5496           a_temp(2,1)=aggi1(l,3)
5497           a_temp(2,2)=aggi1(l,4)
5498           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5499           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5500           s1=scalar2(b1(1,i+2),auxvec(1))
5501           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5502           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5503           s2=scalar2(b1(1,i+1),auxvec(1))
5504           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5505           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5506           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5507           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5508      &  *fac_shield(i)*fac_shield(j)
5509      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5510
5511           a_temp(1,1)=aggj(l,1)
5512           a_temp(1,2)=aggj(l,2)
5513           a_temp(2,1)=aggj(l,3)
5514           a_temp(2,2)=aggj(l,4)
5515           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5516           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5517           s1=scalar2(b1(1,i+2),auxvec(1))
5518           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5519           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5520           s2=scalar2(b1(1,i+1),auxvec(1))
5521           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5522           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5523           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5524           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5525      &  *fac_shield(i)*fac_shield(j)
5526      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5527
5528           a_temp(1,1)=aggj1(l,1)
5529           a_temp(1,2)=aggj1(l,2)
5530           a_temp(2,1)=aggj1(l,3)
5531           a_temp(2,2)=aggj1(l,4)
5532           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5533           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5534           s1=scalar2(b1(1,i+2),auxvec(1))
5535           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5536           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5537           s2=scalar2(b1(1,i+1),auxvec(1))
5538           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5539           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5540           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5541 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5542           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5543      &  *fac_shield(i)*fac_shield(j)
5544      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5545         enddo
5546          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5547      &     ssgradlipi*eello_t4/4.0d0*lipscale
5548          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5549      &     ssgradlipj*eello_t4/4.0d0*lipscale
5550          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5551      &     ssgradlipi*eello_t4/4.0d0*lipscale
5552          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5553      &     ssgradlipj*eello_t4/4.0d0*lipscale
5554       return
5555       end
5556 C-----------------------------------------------------------------------------
5557       subroutine vecpr(u,v,w)
5558       implicit real*8(a-h,o-z)
5559       dimension u(3),v(3),w(3)
5560       w(1)=u(2)*v(3)-u(3)*v(2)
5561       w(2)=-u(1)*v(3)+u(3)*v(1)
5562       w(3)=u(1)*v(2)-u(2)*v(1)
5563       return
5564       end
5565 C-----------------------------------------------------------------------------
5566       subroutine unormderiv(u,ugrad,unorm,ungrad)
5567 C This subroutine computes the derivatives of a normalized vector u, given
5568 C the derivatives computed without normalization conditions, ugrad. Returns
5569 C ungrad.
5570       implicit none
5571       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5572       double precision vec(3)
5573       double precision scalar
5574       integer i,j
5575 c      write (2,*) 'ugrad',ugrad
5576 c      write (2,*) 'u',u
5577       do i=1,3
5578         vec(i)=scalar(ugrad(1,i),u(1))
5579       enddo
5580 c      write (2,*) 'vec',vec
5581       do i=1,3
5582         do j=1,3
5583           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5584         enddo
5585       enddo
5586 c      write (2,*) 'ungrad',ungrad
5587       return
5588       end
5589 C-----------------------------------------------------------------------------
5590       subroutine escp_soft_sphere(evdw2,evdw2_14)
5591 C
5592 C This subroutine calculates the excluded-volume interaction energy between
5593 C peptide-group centers and side chains and its gradient in virtual-bond and
5594 C side-chain vectors.
5595 C
5596       implicit real*8 (a-h,o-z)
5597       include 'DIMENSIONS'
5598       include 'COMMON.GEO'
5599       include 'COMMON.VAR'
5600       include 'COMMON.LOCAL'
5601       include 'COMMON.CHAIN'
5602       include 'COMMON.DERIV'
5603       include 'COMMON.INTERACT'
5604       include 'COMMON.FFIELD'
5605       include 'COMMON.IOUNITS'
5606       include 'COMMON.CONTROL'
5607       dimension ggg(3)
5608       evdw2=0.0D0
5609       evdw2_14=0.0d0
5610       r0_scp=4.5d0
5611 cd    print '(a)','Enter ESCP'
5612 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5613 C      do xshift=-1,1
5614 C      do yshift=-1,1
5615 C      do zshift=-1,1
5616       do i=iatscp_s,iatscp_e
5617         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5618         iteli=itel(i)
5619         xi=0.5D0*(c(1,i)+c(1,i+1))
5620         yi=0.5D0*(c(2,i)+c(2,i+1))
5621         zi=0.5D0*(c(3,i)+c(3,i+1))
5622 C Return atom into box, boxxsize is size of box in x dimension
5623 c  134   continue
5624 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5625 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5626 C Condition for being inside the proper box
5627 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5628 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5629 c        go to 134
5630 c        endif
5631 c  135   continue
5632 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5633 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5634 C Condition for being inside the proper box
5635 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5636 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5637 c        go to 135
5638 c c       endif
5639 c  136   continue
5640 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5641 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5642 cC Condition for being inside the proper box
5643 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5644 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5645 c        go to 136
5646 c        endif
5647           xi=mod(xi,boxxsize)
5648           if (xi.lt.0) xi=xi+boxxsize
5649           yi=mod(yi,boxysize)
5650           if (yi.lt.0) yi=yi+boxysize
5651           zi=mod(zi,boxzsize)
5652           if (zi.lt.0) zi=zi+boxzsize
5653 C          xi=xi+xshift*boxxsize
5654 C          yi=yi+yshift*boxysize
5655 C          zi=zi+zshift*boxzsize
5656         do iint=1,nscp_gr(i)
5657
5658         do j=iscpstart(i,iint),iscpend(i,iint)
5659           if (itype(j).eq.ntyp1) cycle
5660           itypj=iabs(itype(j))
5661 C Uncomment following three lines for SC-p interactions
5662 c         xj=c(1,nres+j)-xi
5663 c         yj=c(2,nres+j)-yi
5664 c         zj=c(3,nres+j)-zi
5665 C Uncomment following three lines for Ca-p interactions
5666           xj=c(1,j)
5667           yj=c(2,j)
5668           zj=c(3,j)
5669 c  174   continue
5670 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5671 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5672 C Condition for being inside the proper box
5673 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5674 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5675 c        go to 174
5676 c        endif
5677 c  175   continue
5678 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5679 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5680 cC Condition for being inside the proper box
5681 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5682 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5683 c        go to 175
5684 c        endif
5685 c  176   continue
5686 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5687 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5688 C Condition for being inside the proper box
5689 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5690 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5691 c        go to 176
5692           xj=mod(xj,boxxsize)
5693           if (xj.lt.0) xj=xj+boxxsize
5694           yj=mod(yj,boxysize)
5695           if (yj.lt.0) yj=yj+boxysize
5696           zj=mod(zj,boxzsize)
5697           if (zj.lt.0) zj=zj+boxzsize
5698       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5699       xj_safe=xj
5700       yj_safe=yj
5701       zj_safe=zj
5702       subchap=0
5703       do xshift=-1,1
5704       do yshift=-1,1
5705       do zshift=-1,1
5706           xj=xj_safe+xshift*boxxsize
5707           yj=yj_safe+yshift*boxysize
5708           zj=zj_safe+zshift*boxzsize
5709           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5710           if(dist_temp.lt.dist_init) then
5711             dist_init=dist_temp
5712             xj_temp=xj
5713             yj_temp=yj
5714             zj_temp=zj
5715             subchap=1
5716           endif
5717        enddo
5718        enddo
5719        enddo
5720        if (subchap.eq.1) then
5721           xj=xj_temp-xi
5722           yj=yj_temp-yi
5723           zj=zj_temp-zi
5724        else
5725           xj=xj_safe-xi
5726           yj=yj_safe-yi
5727           zj=zj_safe-zi
5728        endif
5729 c c       endif
5730 C          xj=xj-xi
5731 C          yj=yj-yi
5732 C          zj=zj-zi
5733           rij=xj*xj+yj*yj+zj*zj
5734
5735           r0ij=r0_scp
5736           r0ijsq=r0ij*r0ij
5737           if (rij.lt.r0ijsq) then
5738             evdwij=0.25d0*(rij-r0ijsq)**2
5739             fac=rij-r0ijsq
5740           else
5741             evdwij=0.0d0
5742             fac=0.0d0
5743           endif
5744           evdw2=evdw2+evdwij
5745 C
5746 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5747 C
5748           ggg(1)=xj*fac
5749           ggg(2)=yj*fac
5750           ggg(3)=zj*fac
5751 cgrad          if (j.lt.i) then
5752 cd          write (iout,*) 'j<i'
5753 C Uncomment following three lines for SC-p interactions
5754 c           do k=1,3
5755 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5756 c           enddo
5757 cgrad          else
5758 cd          write (iout,*) 'j>i'
5759 cgrad            do k=1,3
5760 cgrad              ggg(k)=-ggg(k)
5761 C Uncomment following line for SC-p interactions
5762 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5763 cgrad            enddo
5764 cgrad          endif
5765 cgrad          do k=1,3
5766 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5767 cgrad          enddo
5768 cgrad          kstart=min0(i+1,j)
5769 cgrad          kend=max0(i-1,j-1)
5770 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5771 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5772 cgrad          do k=kstart,kend
5773 cgrad            do l=1,3
5774 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5775 cgrad            enddo
5776 cgrad          enddo
5777           do k=1,3
5778             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5779             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5780           enddo
5781         enddo
5782
5783         enddo ! iint
5784       enddo ! i
5785 C      enddo !zshift
5786 C      enddo !yshift
5787 C      enddo !xshift
5788       return
5789       end
5790 C-----------------------------------------------------------------------------
5791       subroutine escp(evdw2,evdw2_14)
5792 C
5793 C This subroutine calculates the excluded-volume interaction energy between
5794 C peptide-group centers and side chains and its gradient in virtual-bond and
5795 C side-chain vectors.
5796 C
5797       implicit real*8 (a-h,o-z)
5798       include 'DIMENSIONS'
5799       include 'COMMON.GEO'
5800       include 'COMMON.VAR'
5801       include 'COMMON.LOCAL'
5802       include 'COMMON.CHAIN'
5803       include 'COMMON.DERIV'
5804       include 'COMMON.INTERACT'
5805       include 'COMMON.FFIELD'
5806       include 'COMMON.IOUNITS'
5807       include 'COMMON.CONTROL'
5808       include 'COMMON.SPLITELE'
5809       dimension ggg(3)
5810       evdw2=0.0D0
5811       evdw2_14=0.0d0
5812 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5813 cd    print '(a)','Enter ESCP'
5814 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5815 C      do xshift=-1,1
5816 C      do yshift=-1,1
5817 C      do zshift=-1,1
5818       do i=iatscp_s,iatscp_e
5819         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5820         iteli=itel(i)
5821         xi=0.5D0*(c(1,i)+c(1,i+1))
5822         yi=0.5D0*(c(2,i)+c(2,i+1))
5823         zi=0.5D0*(c(3,i)+c(3,i+1))
5824           xi=mod(xi,boxxsize)
5825           if (xi.lt.0) xi=xi+boxxsize
5826           yi=mod(yi,boxysize)
5827           if (yi.lt.0) yi=yi+boxysize
5828           zi=mod(zi,boxzsize)
5829           if (zi.lt.0) zi=zi+boxzsize
5830 c          xi=xi+xshift*boxxsize
5831 c          yi=yi+yshift*boxysize
5832 c          zi=zi+zshift*boxzsize
5833 c        print *,xi,yi,zi,'polozenie i'
5834 C Return atom into box, boxxsize is size of box in x dimension
5835 c  134   continue
5836 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5837 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5838 C Condition for being inside the proper box
5839 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5840 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5841 c        go to 134
5842 c        endif
5843 c  135   continue
5844 c          print *,xi,boxxsize,"pierwszy"
5845
5846 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5847 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5848 C Condition for being inside the proper box
5849 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5850 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5851 c        go to 135
5852 c        endif
5853 c  136   continue
5854 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5855 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5856 C Condition for being inside the proper box
5857 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5858 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5859 c        go to 136
5860 c        endif
5861         do iint=1,nscp_gr(i)
5862
5863         do j=iscpstart(i,iint),iscpend(i,iint)
5864           itypj=iabs(itype(j))
5865           if (itypj.eq.ntyp1) cycle
5866 C Uncomment following three lines for SC-p interactions
5867 c         xj=c(1,nres+j)-xi
5868 c         yj=c(2,nres+j)-yi
5869 c         zj=c(3,nres+j)-zi
5870 C Uncomment following three lines for Ca-p interactions
5871           xj=c(1,j)
5872           yj=c(2,j)
5873           zj=c(3,j)
5874           xj=mod(xj,boxxsize)
5875           if (xj.lt.0) xj=xj+boxxsize
5876           yj=mod(yj,boxysize)
5877           if (yj.lt.0) yj=yj+boxysize
5878           zj=mod(zj,boxzsize)
5879           if (zj.lt.0) zj=zj+boxzsize
5880 c  174   continue
5881 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5882 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5883 C Condition for being inside the proper box
5884 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5885 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5886 c        go to 174
5887 c        endif
5888 c  175   continue
5889 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5890 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5891 cC Condition for being inside the proper box
5892 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5893 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5894 c        go to 175
5895 c        endif
5896 c  176   continue
5897 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5898 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5899 C Condition for being inside the proper box
5900 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5901 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5902 c        go to 176
5903 c        endif
5904 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5905       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5906       xj_safe=xj
5907       yj_safe=yj
5908       zj_safe=zj
5909       subchap=0
5910       do xshift=-1,1
5911       do yshift=-1,1
5912       do zshift=-1,1
5913           xj=xj_safe+xshift*boxxsize
5914           yj=yj_safe+yshift*boxysize
5915           zj=zj_safe+zshift*boxzsize
5916           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5917           if(dist_temp.lt.dist_init) then
5918             dist_init=dist_temp
5919             xj_temp=xj
5920             yj_temp=yj
5921             zj_temp=zj
5922             subchap=1
5923           endif
5924        enddo
5925        enddo
5926        enddo
5927        if (subchap.eq.1) then
5928           xj=xj_temp-xi
5929           yj=yj_temp-yi
5930           zj=zj_temp-zi
5931        else
5932           xj=xj_safe-xi
5933           yj=yj_safe-yi
5934           zj=zj_safe-zi
5935        endif
5936 c          print *,xj,yj,zj,'polozenie j'
5937           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5938 c          print *,rrij
5939           sss=sscale(1.0d0/(dsqrt(rrij)))
5940 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5941 c          if (sss.eq.0) print *,'czasem jest OK'
5942           if (sss.le.0.0d0) cycle
5943           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5944           fac=rrij**expon2
5945           e1=fac*fac*aad(itypj,iteli)
5946           e2=fac*bad(itypj,iteli)
5947           if (iabs(j-i) .le. 2) then
5948             e1=scal14*e1
5949             e2=scal14*e2
5950             evdw2_14=evdw2_14+(e1+e2)*sss
5951           endif
5952           evdwij=e1+e2
5953           evdw2=evdw2+evdwij*sss
5954           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5955      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5956      &       bad(itypj,iteli)
5957 C
5958 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5959 C
5960           fac=-(evdwij+e1)*rrij*sss
5961           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5962           ggg(1)=xj*fac
5963           ggg(2)=yj*fac
5964           ggg(3)=zj*fac
5965 cgrad          if (j.lt.i) then
5966 cd          write (iout,*) 'j<i'
5967 C Uncomment following three lines for SC-p interactions
5968 c           do k=1,3
5969 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5970 c           enddo
5971 cgrad          else
5972 cd          write (iout,*) 'j>i'
5973 cgrad            do k=1,3
5974 cgrad              ggg(k)=-ggg(k)
5975 C Uncomment following line for SC-p interactions
5976 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5977 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5978 cgrad            enddo
5979 cgrad          endif
5980 cgrad          do k=1,3
5981 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5982 cgrad          enddo
5983 cgrad          kstart=min0(i+1,j)
5984 cgrad          kend=max0(i-1,j-1)
5985 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5986 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5987 cgrad          do k=kstart,kend
5988 cgrad            do l=1,3
5989 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5990 cgrad            enddo
5991 cgrad          enddo
5992           do k=1,3
5993             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5994             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5995           enddo
5996 c        endif !endif for sscale cutoff
5997         enddo ! j
5998
5999         enddo ! iint
6000       enddo ! i
6001 c      enddo !zshift
6002 c      enddo !yshift
6003 c      enddo !xshift
6004       do i=1,nct
6005         do j=1,3
6006           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
6007           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
6008           gradx_scp(j,i)=expon*gradx_scp(j,i)
6009         enddo
6010       enddo
6011 C******************************************************************************
6012 C
6013 C                              N O T E !!!
6014 C
6015 C To save time the factor EXPON has been extracted from ALL components
6016 C of GVDWC and GRADX. Remember to multiply them by this factor before further
6017 C use!
6018 C
6019 C******************************************************************************
6020       return
6021       end
6022 C--------------------------------------------------------------------------
6023       subroutine edis(ehpb)
6024 C
6025 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6026 C
6027       implicit real*8 (a-h,o-z)
6028       include 'DIMENSIONS'
6029       include 'COMMON.SBRIDGE'
6030       include 'COMMON.CHAIN'
6031       include 'COMMON.DERIV'
6032       include 'COMMON.VAR'
6033       include 'COMMON.INTERACT'
6034       include 'COMMON.IOUNITS'
6035       include 'COMMON.CONTROL'
6036       dimension ggg(3)
6037       ehpb=0.0D0
6038       do i=1,3
6039        ggg(i)=0.0d0
6040       enddo
6041 C      write (iout,*) ,"link_end",link_end,constr_dist
6042 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6043 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
6044       if (link_end.eq.0) return
6045       do i=link_start,link_end
6046 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6047 C CA-CA distance used in regularization of structure.
6048         ii=ihpb(i)
6049         jj=jhpb(i)
6050 C iii and jjj point to the residues for which the distance is assigned.
6051         if (ii.gt.nres) then
6052           iii=ii-nres
6053           jjj=jj-nres
6054         else
6055           iii=ii
6056           jjj=jj
6057         endif
6058 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6059 c     &    dhpb(i),dhpb1(i),forcon(i)
6060 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6061 C    distance and angle dependent SS bond potential.
6062 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6063 C     & iabs(itype(jjj)).eq.1) then
6064 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6065 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6066         if (.not.dyn_ss .and. i.le.nss) then
6067 C 15/02/13 CC dynamic SSbond - additional check
6068          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6069      & iabs(itype(jjj)).eq.1) then
6070           call ssbond_ene(iii,jjj,eij)
6071           ehpb=ehpb+2*eij
6072          endif
6073 cd          write (iout,*) "eij",eij
6074 cd   &   ' waga=',waga,' fac=',fac
6075         else if (ii.gt.nres .and. jj.gt.nres) then
6076 c Restraints from contact prediction
6077           dd=dist(ii,jj)
6078           if (constr_dist.eq.11) then
6079             ehpb=ehpb+fordepth(i)**4.0d0
6080      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6081             fac=fordepth(i)**4.0d0
6082      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6083           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6084      &    ehpb,fordepth(i),dd
6085            else
6086           if (dhpb1(i).gt.0.0d0) then
6087             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6088             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6089 c            write (iout,*) "beta nmr",
6090 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6091           else
6092             dd=dist(ii,jj)
6093             rdis=dd-dhpb(i)
6094 C Get the force constant corresponding to this distance.
6095             waga=forcon(i)
6096 C Calculate the contribution to energy.
6097             ehpb=ehpb+waga*rdis*rdis
6098 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6099 C
6100 C Evaluate gradient.
6101 C
6102             fac=waga*rdis/dd
6103           endif
6104           endif
6105           do j=1,3
6106             ggg(j)=fac*(c(j,jj)-c(j,ii))
6107           enddo
6108           do j=1,3
6109             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6110             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6111           enddo
6112           do k=1,3
6113             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6114             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6115           enddo
6116         else
6117 C Calculate the distance between the two points and its difference from the
6118 C target distance.
6119           dd=dist(ii,jj)
6120           if (constr_dist.eq.11) then
6121             ehpb=ehpb+fordepth(i)**4.0d0
6122      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6123             fac=fordepth(i)**4.0d0
6124      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6125           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6126      &    ehpb,fordepth(i),dd
6127            else
6128           if (dhpb1(i).gt.0.0d0) then
6129             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6130             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6131 c            write (iout,*) "alph nmr",
6132 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6133           else
6134             rdis=dd-dhpb(i)
6135 C Get the force constant corresponding to this distance.
6136             waga=forcon(i)
6137 C Calculate the contribution to energy.
6138             ehpb=ehpb+waga*rdis*rdis
6139 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6140 C
6141 C Evaluate gradient.
6142 C
6143             fac=waga*rdis/dd
6144           endif
6145           endif
6146             do j=1,3
6147               ggg(j)=fac*(c(j,jj)-c(j,ii))
6148             enddo
6149 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6150 C If this is a SC-SC distance, we need to calculate the contributions to the
6151 C Cartesian gradient in the SC vectors (ghpbx).
6152           if (iii.lt.ii) then
6153           do j=1,3
6154             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6155             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6156           enddo
6157           endif
6158 cgrad        do j=iii,jjj-1
6159 cgrad          do k=1,3
6160 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6161 cgrad          enddo
6162 cgrad        enddo
6163           do k=1,3
6164             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6165             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6166           enddo
6167         endif
6168       enddo
6169       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6170       return
6171       end
6172 C--------------------------------------------------------------------------
6173       subroutine ssbond_ene(i,j,eij)
6174 C
6175 C Calculate the distance and angle dependent SS-bond potential energy
6176 C using a free-energy function derived based on RHF/6-31G** ab initio
6177 C calculations of diethyl disulfide.
6178 C
6179 C A. Liwo and U. Kozlowska, 11/24/03
6180 C
6181       implicit real*8 (a-h,o-z)
6182       include 'DIMENSIONS'
6183       include 'COMMON.SBRIDGE'
6184       include 'COMMON.CHAIN'
6185       include 'COMMON.DERIV'
6186       include 'COMMON.LOCAL'
6187       include 'COMMON.INTERACT'
6188       include 'COMMON.VAR'
6189       include 'COMMON.IOUNITS'
6190       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6191       itypi=iabs(itype(i))
6192       xi=c(1,nres+i)
6193       yi=c(2,nres+i)
6194       zi=c(3,nres+i)
6195       dxi=dc_norm(1,nres+i)
6196       dyi=dc_norm(2,nres+i)
6197       dzi=dc_norm(3,nres+i)
6198 c      dsci_inv=dsc_inv(itypi)
6199       dsci_inv=vbld_inv(nres+i)
6200       itypj=iabs(itype(j))
6201 c      dscj_inv=dsc_inv(itypj)
6202       dscj_inv=vbld_inv(nres+j)
6203       xj=c(1,nres+j)-xi
6204       yj=c(2,nres+j)-yi
6205       zj=c(3,nres+j)-zi
6206       dxj=dc_norm(1,nres+j)
6207       dyj=dc_norm(2,nres+j)
6208       dzj=dc_norm(3,nres+j)
6209       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6210       rij=dsqrt(rrij)
6211       erij(1)=xj*rij
6212       erij(2)=yj*rij
6213       erij(3)=zj*rij
6214       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6215       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6216       om12=dxi*dxj+dyi*dyj+dzi*dzj
6217       do k=1,3
6218         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6219         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6220       enddo
6221       rij=1.0d0/rij
6222       deltad=rij-d0cm
6223       deltat1=1.0d0-om1
6224       deltat2=1.0d0+om2
6225       deltat12=om2-om1+2.0d0
6226       cosphi=om12-om1*om2
6227       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6228      &  +akct*deltad*deltat12
6229      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6230 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6231 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6232 c     &  " deltat12",deltat12," eij",eij
6233       ed=2*akcm*deltad+akct*deltat12
6234       pom1=akct*deltad
6235       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6236       eom1=-2*akth*deltat1-pom1-om2*pom2
6237       eom2= 2*akth*deltat2+pom1-om1*pom2
6238       eom12=pom2
6239       do k=1,3
6240         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6241         ghpbx(k,i)=ghpbx(k,i)-ggk
6242      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6243      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6244         ghpbx(k,j)=ghpbx(k,j)+ggk
6245      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6246      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6247         ghpbc(k,i)=ghpbc(k,i)-ggk
6248         ghpbc(k,j)=ghpbc(k,j)+ggk
6249       enddo
6250 C
6251 C Calculate the components of the gradient in DC and X
6252 C
6253 cgrad      do k=i,j-1
6254 cgrad        do l=1,3
6255 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6256 cgrad        enddo
6257 cgrad      enddo
6258       return
6259       end
6260 C--------------------------------------------------------------------------
6261       subroutine ebond(estr)
6262 c
6263 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6264 c
6265       implicit real*8 (a-h,o-z)
6266       include 'DIMENSIONS'
6267       include 'COMMON.LOCAL'
6268       include 'COMMON.GEO'
6269       include 'COMMON.INTERACT'
6270       include 'COMMON.DERIV'
6271       include 'COMMON.VAR'
6272       include 'COMMON.CHAIN'
6273       include 'COMMON.IOUNITS'
6274       include 'COMMON.NAMES'
6275       include 'COMMON.FFIELD'
6276       include 'COMMON.CONTROL'
6277       include 'COMMON.SETUP'
6278       double precision u(3),ud(3)
6279       estr=0.0d0
6280       estr1=0.0d0
6281       do i=ibondp_start,ibondp_end
6282         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6283 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6284 c          do j=1,3
6285 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6286 c     &      *dc(j,i-1)/vbld(i)
6287 c          enddo
6288 c          if (energy_dec) write(iout,*)
6289 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6290 c        else
6291 C       Checking if it involves dummy (NH3+ or COO-) group
6292          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6293 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6294         diff = vbld(i)-vbldpDUM
6295         if (energy_dec) write(iout,*) "dum_bond",i,diff
6296          else
6297 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6298         diff = vbld(i)-vbldp0
6299          endif
6300         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6301      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6302         estr=estr+diff*diff
6303         do j=1,3
6304           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6305         enddo
6306 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6307 c        endif
6308       enddo
6309
6310       estr=0.5d0*AKP*estr+estr1
6311 c
6312 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6313 c
6314       do i=ibond_start,ibond_end
6315         iti=iabs(itype(i))
6316         if (iti.ne.10 .and. iti.ne.ntyp1) then
6317           nbi=nbondterm(iti)
6318           if (nbi.eq.1) then
6319             diff=vbld(i+nres)-vbldsc0(1,iti)
6320             if (energy_dec)  write (iout,*)
6321      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6322      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6323             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6324             do j=1,3
6325               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6326             enddo
6327           else
6328             do j=1,nbi
6329               diff=vbld(i+nres)-vbldsc0(j,iti)
6330               ud(j)=aksc(j,iti)*diff
6331               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6332             enddo
6333             uprod=u(1)
6334             do j=2,nbi
6335               uprod=uprod*u(j)
6336             enddo
6337             usum=0.0d0
6338             usumsqder=0.0d0
6339             do j=1,nbi
6340               uprod1=1.0d0
6341               uprod2=1.0d0
6342               do k=1,nbi
6343                 if (k.ne.j) then
6344                   uprod1=uprod1*u(k)
6345                   uprod2=uprod2*u(k)*u(k)
6346                 endif
6347               enddo
6348               usum=usum+uprod1
6349               usumsqder=usumsqder+ud(j)*uprod2
6350             enddo
6351             estr=estr+uprod/usum
6352             do j=1,3
6353              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6354             enddo
6355           endif
6356         endif
6357       enddo
6358       return
6359       end
6360 #ifdef CRYST_THETA
6361 C--------------------------------------------------------------------------
6362       subroutine ebend(etheta,ethetacnstr)
6363 C
6364 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6365 C angles gamma and its derivatives in consecutive thetas and gammas.
6366 C
6367       implicit real*8 (a-h,o-z)
6368       include 'DIMENSIONS'
6369       include 'COMMON.LOCAL'
6370       include 'COMMON.GEO'
6371       include 'COMMON.INTERACT'
6372       include 'COMMON.DERIV'
6373       include 'COMMON.VAR'
6374       include 'COMMON.CHAIN'
6375       include 'COMMON.IOUNITS'
6376       include 'COMMON.NAMES'
6377       include 'COMMON.FFIELD'
6378       include 'COMMON.CONTROL'
6379       include 'COMMON.TORCNSTR'
6380       common /calcthet/ term1,term2,termm,diffak,ratak,
6381      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6382      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6383       double precision y(2),z(2)
6384       delta=0.02d0*pi
6385 c      time11=dexp(-2*time)
6386 c      time12=1.0d0
6387       etheta=0.0D0
6388 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6389       do i=ithet_start,ithet_end
6390         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6391      &  .or.itype(i).eq.ntyp1) cycle
6392 C Zero the energy function and its derivative at 0 or pi.
6393         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6394         it=itype(i-1)
6395         ichir1=isign(1,itype(i-2))
6396         ichir2=isign(1,itype(i))
6397          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6398          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6399          if (itype(i-1).eq.10) then
6400           itype1=isign(10,itype(i-2))
6401           ichir11=isign(1,itype(i-2))
6402           ichir12=isign(1,itype(i-2))
6403           itype2=isign(10,itype(i))
6404           ichir21=isign(1,itype(i))
6405           ichir22=isign(1,itype(i))
6406          endif
6407
6408         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6409 #ifdef OSF
6410           phii=phi(i)
6411           if (phii.ne.phii) phii=150.0
6412 #else
6413           phii=phi(i)
6414 #endif
6415           y(1)=dcos(phii)
6416           y(2)=dsin(phii)
6417         else
6418           y(1)=0.0D0
6419           y(2)=0.0D0
6420         endif
6421         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6422 #ifdef OSF
6423           phii1=phi(i+1)
6424           if (phii1.ne.phii1) phii1=150.0
6425           phii1=pinorm(phii1)
6426           z(1)=cos(phii1)
6427 #else
6428           phii1=phi(i+1)
6429 #endif
6430           z(1)=dcos(phii1)
6431           z(2)=dsin(phii1)
6432         else
6433           z(1)=0.0D0
6434           z(2)=0.0D0
6435         endif
6436 C Calculate the "mean" value of theta from the part of the distribution
6437 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6438 C In following comments this theta will be referred to as t_c.
6439         thet_pred_mean=0.0d0
6440         do k=1,2
6441             athetk=athet(k,it,ichir1,ichir2)
6442             bthetk=bthet(k,it,ichir1,ichir2)
6443           if (it.eq.10) then
6444              athetk=athet(k,itype1,ichir11,ichir12)
6445              bthetk=bthet(k,itype2,ichir21,ichir22)
6446           endif
6447          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6448 c         write(iout,*) 'chuj tu', y(k),z(k)
6449         enddo
6450         dthett=thet_pred_mean*ssd
6451         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6452 C Derivatives of the "mean" values in gamma1 and gamma2.
6453         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6454      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6455          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6456      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6457          if (it.eq.10) then
6458       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6459      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6460         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6461      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6462          endif
6463         if (theta(i).gt.pi-delta) then
6464           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6465      &         E_tc0)
6466           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6467           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6468           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6469      &        E_theta)
6470           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6471      &        E_tc)
6472         else if (theta(i).lt.delta) then
6473           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6474           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6475           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6476      &        E_theta)
6477           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6478           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6479      &        E_tc)
6480         else
6481           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6482      &        E_theta,E_tc)
6483         endif
6484         etheta=etheta+ethetai
6485         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6486      &      'ebend',i,ethetai,theta(i),itype(i)
6487         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6488         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6489         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6490       enddo
6491       ethetacnstr=0.0d0
6492 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6493       do i=ithetaconstr_start,ithetaconstr_end
6494         itheta=itheta_constr(i)
6495         thetiii=theta(itheta)
6496         difi=pinorm(thetiii-theta_constr0(i))
6497         if (difi.gt.theta_drange(i)) then
6498           difi=difi-theta_drange(i)
6499           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6500           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6501      &    +for_thet_constr(i)*difi**3
6502         else if (difi.lt.-drange(i)) then
6503           difi=difi+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
6508           difi=0.0
6509         endif
6510        if (energy_dec) then
6511         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6512      &    i,itheta,rad2deg*thetiii,
6513      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6514      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6515      &    gloc(itheta+nphi-2,icg)
6516         endif
6517       enddo
6518
6519 C Ufff.... We've done all this!!!
6520       return
6521       end
6522 C---------------------------------------------------------------------------
6523       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6524      &     E_tc)
6525       implicit real*8 (a-h,o-z)
6526       include 'DIMENSIONS'
6527       include 'COMMON.LOCAL'
6528       include 'COMMON.IOUNITS'
6529       common /calcthet/ term1,term2,termm,diffak,ratak,
6530      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6531      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6532 C Calculate the contributions to both Gaussian lobes.
6533 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6534 C The "polynomial part" of the "standard deviation" of this part of
6535 C the distributioni.
6536 ccc        write (iout,*) thetai,thet_pred_mean
6537         sig=polthet(3,it)
6538         do j=2,0,-1
6539           sig=sig*thet_pred_mean+polthet(j,it)
6540         enddo
6541 C Derivative of the "interior part" of the "standard deviation of the"
6542 C gamma-dependent Gaussian lobe in t_c.
6543         sigtc=3*polthet(3,it)
6544         do j=2,1,-1
6545           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6546         enddo
6547         sigtc=sig*sigtc
6548 C Set the parameters of both Gaussian lobes of the distribution.
6549 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6550         fac=sig*sig+sigc0(it)
6551         sigcsq=fac+fac
6552         sigc=1.0D0/sigcsq
6553 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6554         sigsqtc=-4.0D0*sigcsq*sigtc
6555 c       print *,i,sig,sigtc,sigsqtc
6556 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6557         sigtc=-sigtc/(fac*fac)
6558 C Following variable is sigma(t_c)**(-2)
6559         sigcsq=sigcsq*sigcsq
6560         sig0i=sig0(it)
6561         sig0inv=1.0D0/sig0i**2
6562         delthec=thetai-thet_pred_mean
6563         delthe0=thetai-theta0i
6564         term1=-0.5D0*sigcsq*delthec*delthec
6565         term2=-0.5D0*sig0inv*delthe0*delthe0
6566 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6567 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6568 C NaNs in taking the logarithm. We extract the largest exponent which is added
6569 C to the energy (this being the log of the distribution) at the end of energy
6570 C term evaluation for this virtual-bond angle.
6571         if (term1.gt.term2) then
6572           termm=term1
6573           term2=dexp(term2-termm)
6574           term1=1.0d0
6575         else
6576           termm=term2
6577           term1=dexp(term1-termm)
6578           term2=1.0d0
6579         endif
6580 C The ratio between the gamma-independent and gamma-dependent lobes of
6581 C the distribution is a Gaussian function of thet_pred_mean too.
6582         diffak=gthet(2,it)-thet_pred_mean
6583         ratak=diffak/gthet(3,it)**2
6584         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6585 C Let's differentiate it in thet_pred_mean NOW.
6586         aktc=ak*ratak
6587 C Now put together the distribution terms to make complete distribution.
6588         termexp=term1+ak*term2
6589         termpre=sigc+ak*sig0i
6590 C Contribution of the bending energy from this theta is just the -log of
6591 C the sum of the contributions from the two lobes and the pre-exponential
6592 C factor. Simple enough, isn't it?
6593         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6594 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6595 C NOW the derivatives!!!
6596 C 6/6/97 Take into account the deformation.
6597         E_theta=(delthec*sigcsq*term1
6598      &       +ak*delthe0*sig0inv*term2)/termexp
6599         E_tc=((sigtc+aktc*sig0i)/termpre
6600      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6601      &       aktc*term2)/termexp)
6602       return
6603       end
6604 c-----------------------------------------------------------------------------
6605       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6606       implicit real*8 (a-h,o-z)
6607       include 'DIMENSIONS'
6608       include 'COMMON.LOCAL'
6609       include 'COMMON.IOUNITS'
6610       common /calcthet/ term1,term2,termm,diffak,ratak,
6611      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6612      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6613       delthec=thetai-thet_pred_mean
6614       delthe0=thetai-theta0i
6615 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6616       t3 = thetai-thet_pred_mean
6617       t6 = t3**2
6618       t9 = term1
6619       t12 = t3*sigcsq
6620       t14 = t12+t6*sigsqtc
6621       t16 = 1.0d0
6622       t21 = thetai-theta0i
6623       t23 = t21**2
6624       t26 = term2
6625       t27 = t21*t26
6626       t32 = termexp
6627       t40 = t32**2
6628       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6629      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6630      & *(-t12*t9-ak*sig0inv*t27)
6631       return
6632       end
6633 #else
6634 C--------------------------------------------------------------------------
6635       subroutine ebend(etheta,ethetacnstr)
6636 C
6637 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6638 C angles gamma and its derivatives in consecutive thetas and gammas.
6639 C ab initio-derived potentials from
6640 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6641 C
6642       implicit real*8 (a-h,o-z)
6643       include 'DIMENSIONS'
6644       include 'COMMON.LOCAL'
6645       include 'COMMON.GEO'
6646       include 'COMMON.INTERACT'
6647       include 'COMMON.DERIV'
6648       include 'COMMON.VAR'
6649       include 'COMMON.CHAIN'
6650       include 'COMMON.IOUNITS'
6651       include 'COMMON.NAMES'
6652       include 'COMMON.FFIELD'
6653       include 'COMMON.CONTROL'
6654       include 'COMMON.TORCNSTR'
6655       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6656      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6657      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6658      & sinph1ph2(maxdouble,maxdouble)
6659       logical lprn /.false./, lprn1 /.false./
6660       etheta=0.0D0
6661       do i=ithet_start,ithet_end
6662 c        print *,i,itype(i-1),itype(i),itype(i-2)
6663         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6664      &  .or.itype(i).eq.ntyp1) cycle
6665 C        print *,i,theta(i)
6666         if (iabs(itype(i+1)).eq.20) iblock=2
6667         if (iabs(itype(i+1)).ne.20) iblock=1
6668         dethetai=0.0d0
6669         dephii=0.0d0
6670         dephii1=0.0d0
6671         theti2=0.5d0*theta(i)
6672         ityp2=ithetyp((itype(i-1)))
6673         do k=1,nntheterm
6674           coskt(k)=dcos(k*theti2)
6675           sinkt(k)=dsin(k*theti2)
6676         enddo
6677 C        print *,ethetai
6678         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6679 #ifdef OSF
6680           phii=phi(i)
6681           if (phii.ne.phii) phii=150.0
6682 #else
6683           phii=phi(i)
6684 #endif
6685           ityp1=ithetyp((itype(i-2)))
6686 C propagation of chirality for glycine type
6687           do k=1,nsingle
6688             cosph1(k)=dcos(k*phii)
6689             sinph1(k)=dsin(k*phii)
6690           enddo
6691         else
6692           phii=0.0d0
6693           do k=1,nsingle
6694           ityp1=ithetyp((itype(i-2)))
6695             cosph1(k)=0.0d0
6696             sinph1(k)=0.0d0
6697           enddo
6698         endif
6699         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6700 #ifdef OSF
6701           phii1=phi(i+1)
6702           if (phii1.ne.phii1) phii1=150.0
6703           phii1=pinorm(phii1)
6704 #else
6705           phii1=phi(i+1)
6706 #endif
6707           ityp3=ithetyp((itype(i)))
6708           do k=1,nsingle
6709             cosph2(k)=dcos(k*phii1)
6710             sinph2(k)=dsin(k*phii1)
6711           enddo
6712         else
6713           phii1=0.0d0
6714           ityp3=ithetyp((itype(i)))
6715           do k=1,nsingle
6716             cosph2(k)=0.0d0
6717             sinph2(k)=0.0d0
6718           enddo
6719         endif
6720         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6721         do k=1,ndouble
6722           do l=1,k-1
6723             ccl=cosph1(l)*cosph2(k-l)
6724             ssl=sinph1(l)*sinph2(k-l)
6725             scl=sinph1(l)*cosph2(k-l)
6726             csl=cosph1(l)*sinph2(k-l)
6727             cosph1ph2(l,k)=ccl-ssl
6728             cosph1ph2(k,l)=ccl+ssl
6729             sinph1ph2(l,k)=scl+csl
6730             sinph1ph2(k,l)=scl-csl
6731           enddo
6732         enddo
6733         if (lprn) then
6734         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6735      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6736         write (iout,*) "coskt and sinkt"
6737         do k=1,nntheterm
6738           write (iout,*) k,coskt(k),sinkt(k)
6739         enddo
6740         endif
6741         do k=1,ntheterm
6742           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6743           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6744      &      *coskt(k)
6745           if (lprn)
6746      &    write (iout,*) "k",k,"
6747      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6748      &     " ethetai",ethetai
6749         enddo
6750         if (lprn) then
6751         write (iout,*) "cosph and sinph"
6752         do k=1,nsingle
6753           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6754         enddo
6755         write (iout,*) "cosph1ph2 and sinph2ph2"
6756         do k=2,ndouble
6757           do l=1,k-1
6758             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6759      &         sinph1ph2(l,k),sinph1ph2(k,l)
6760           enddo
6761         enddo
6762         write(iout,*) "ethetai",ethetai
6763         endif
6764 C       print *,ethetai
6765         do m=1,ntheterm2
6766           do k=1,nsingle
6767             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6768      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6769      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6770      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6771             ethetai=ethetai+sinkt(m)*aux
6772             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6773             dephii=dephii+k*sinkt(m)*(
6774      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6775      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6776             dephii1=dephii1+k*sinkt(m)*(
6777      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6778      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6779             if (lprn)
6780      &      write (iout,*) "m",m," k",k," bbthet",
6781      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6782      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6783      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6784      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6785 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6786           enddo
6787         enddo
6788 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6789 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6790 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6791 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6792         if (lprn)
6793      &  write(iout,*) "ethetai",ethetai
6794 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6795         do m=1,ntheterm3
6796           do k=2,ndouble
6797             do l=1,k-1
6798               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6799      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6800      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6801      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6802               ethetai=ethetai+sinkt(m)*aux
6803               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6804               dephii=dephii+l*sinkt(m)*(
6805      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6806      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6807      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6808      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6809               dephii1=dephii1+(k-l)*sinkt(m)*(
6810      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6811      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6812      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6813      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6814               if (lprn) then
6815               write (iout,*) "m",m," k",k," l",l," ffthet",
6816      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6820      &            " ethetai",ethetai
6821               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6822      &            cosph1ph2(k,l)*sinkt(m),
6823      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6824               endif
6825             enddo
6826           enddo
6827         enddo
6828 10      continue
6829 c        lprn1=.true.
6830 C        print *,ethetai
6831         if (lprn1)
6832      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6833      &   i,theta(i)*rad2deg,phii*rad2deg,
6834      &   phii1*rad2deg,ethetai
6835 c        lprn1=.false.
6836         etheta=etheta+ethetai
6837         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6838         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6839         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6840       enddo
6841 C now constrains
6842       ethetacnstr=0.0d0
6843 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6844       do i=ithetaconstr_start,ithetaconstr_end
6845         itheta=itheta_constr(i)
6846         thetiii=theta(itheta)
6847         difi=pinorm(thetiii-theta_constr0(i))
6848         if (difi.gt.theta_drange(i)) then
6849           difi=difi-theta_drange(i)
6850           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6851           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6852      &    +for_thet_constr(i)*difi**3
6853         else if (difi.lt.-drange(i)) then
6854           difi=difi+drange(i)
6855           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6856           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6857      &    +for_thet_constr(i)*difi**3
6858         else
6859           difi=0.0
6860         endif
6861        if (energy_dec) then
6862         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6863      &    i,itheta,rad2deg*thetiii,
6864      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6865      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6866      &    gloc(itheta+nphi-2,icg)
6867         endif
6868       enddo
6869
6870       return
6871       end
6872 #endif
6873 #ifdef CRYST_SC
6874 c-----------------------------------------------------------------------------
6875       subroutine esc(escloc)
6876 C Calculate the local energy of a side chain and its derivatives in the
6877 C corresponding virtual-bond valence angles THETA and the spherical angles
6878 C ALPHA and OMEGA.
6879       implicit real*8 (a-h,o-z)
6880       include 'DIMENSIONS'
6881       include 'COMMON.GEO'
6882       include 'COMMON.LOCAL'
6883       include 'COMMON.VAR'
6884       include 'COMMON.INTERACT'
6885       include 'COMMON.DERIV'
6886       include 'COMMON.CHAIN'
6887       include 'COMMON.IOUNITS'
6888       include 'COMMON.NAMES'
6889       include 'COMMON.FFIELD'
6890       include 'COMMON.CONTROL'
6891       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6892      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6893       common /sccalc/ time11,time12,time112,theti,it,nlobit
6894       delta=0.02d0*pi
6895       escloc=0.0D0
6896 c     write (iout,'(a)') 'ESC'
6897       do i=loc_start,loc_end
6898         it=itype(i)
6899         if (it.eq.ntyp1) cycle
6900         if (it.eq.10) goto 1
6901         nlobit=nlob(iabs(it))
6902 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6903 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6904         theti=theta(i+1)-pipol
6905         x(1)=dtan(theti)
6906         x(2)=alph(i)
6907         x(3)=omeg(i)
6908
6909         if (x(2).gt.pi-delta) then
6910           xtemp(1)=x(1)
6911           xtemp(2)=pi-delta
6912           xtemp(3)=x(3)
6913           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6914           xtemp(2)=pi
6915           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6916           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6917      &        escloci,dersc(2))
6918           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6919      &        ddersc0(1),dersc(1))
6920           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6921      &        ddersc0(3),dersc(3))
6922           xtemp(2)=pi-delta
6923           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6924           xtemp(2)=pi
6925           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6926           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6927      &            dersc0(2),esclocbi,dersc02)
6928           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6929      &            dersc12,dersc01)
6930           call splinthet(x(2),0.5d0*delta,ss,ssd)
6931           dersc0(1)=dersc01
6932           dersc0(2)=dersc02
6933           dersc0(3)=0.0d0
6934           do k=1,3
6935             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6936           enddo
6937           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6938 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6939 c    &             esclocbi,ss,ssd
6940           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6941 c         escloci=esclocbi
6942 c         write (iout,*) escloci
6943         else if (x(2).lt.delta) then
6944           xtemp(1)=x(1)
6945           xtemp(2)=delta
6946           xtemp(3)=x(3)
6947           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6948           xtemp(2)=0.0d0
6949           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6950           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6951      &        escloci,dersc(2))
6952           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6953      &        ddersc0(1),dersc(1))
6954           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6955      &        ddersc0(3),dersc(3))
6956           xtemp(2)=delta
6957           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6958           xtemp(2)=0.0d0
6959           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6960           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6961      &            dersc0(2),esclocbi,dersc02)
6962           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6963      &            dersc12,dersc01)
6964           dersc0(1)=dersc01
6965           dersc0(2)=dersc02
6966           dersc0(3)=0.0d0
6967           call splinthet(x(2),0.5d0*delta,ss,ssd)
6968           do k=1,3
6969             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6970           enddo
6971           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6972 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6973 c    &             esclocbi,ss,ssd
6974           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6975 c         write (iout,*) escloci
6976         else
6977           call enesc(x,escloci,dersc,ddummy,.false.)
6978         endif
6979
6980         escloc=escloc+escloci
6981         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6982      &     'escloc',i,escloci
6983 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6984
6985         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6986      &   wscloc*dersc(1)
6987         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6988         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6989     1   continue
6990       enddo
6991       return
6992       end
6993 C---------------------------------------------------------------------------
6994       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6995       implicit real*8 (a-h,o-z)
6996       include 'DIMENSIONS'
6997       include 'COMMON.GEO'
6998       include 'COMMON.LOCAL'
6999       include 'COMMON.IOUNITS'
7000       common /sccalc/ time11,time12,time112,theti,it,nlobit
7001       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7002       double precision contr(maxlob,-1:1)
7003       logical mixed
7004 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7005         escloc_i=0.0D0
7006         do j=1,3
7007           dersc(j)=0.0D0
7008           if (mixed) ddersc(j)=0.0d0
7009         enddo
7010         x3=x(3)
7011
7012 C Because of periodicity of the dependence of the SC energy in omega we have
7013 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7014 C To avoid underflows, first compute & store the exponents.
7015
7016         do iii=-1,1
7017
7018           x(3)=x3+iii*dwapi
7019
7020           do j=1,nlobit
7021             do k=1,3
7022               z(k)=x(k)-censc(k,j,it)
7023             enddo
7024             do k=1,3
7025               Axk=0.0D0
7026               do l=1,3
7027                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7028               enddo
7029               Ax(k,j,iii)=Axk
7030             enddo
7031             expfac=0.0D0
7032             do k=1,3
7033               expfac=expfac+Ax(k,j,iii)*z(k)
7034             enddo
7035             contr(j,iii)=expfac
7036           enddo ! j
7037
7038         enddo ! iii
7039
7040         x(3)=x3
7041 C As in the case of ebend, we want to avoid underflows in exponentiation and
7042 C subsequent NaNs and INFs in energy calculation.
7043 C Find the largest exponent
7044         emin=contr(1,-1)
7045         do iii=-1,1
7046           do j=1,nlobit
7047             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7048           enddo
7049         enddo
7050         emin=0.5D0*emin
7051 cd      print *,'it=',it,' emin=',emin
7052
7053 C Compute the contribution to SC energy and derivatives
7054         do iii=-1,1
7055
7056           do j=1,nlobit
7057 #ifdef OSF
7058             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7059             if(adexp.ne.adexp) adexp=1.0
7060             expfac=dexp(adexp)
7061 #else
7062             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7063 #endif
7064 cd          print *,'j=',j,' expfac=',expfac
7065             escloc_i=escloc_i+expfac
7066             do k=1,3
7067               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7068             enddo
7069             if (mixed) then
7070               do k=1,3,2
7071                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7072      &            +gaussc(k,2,j,it))*expfac
7073               enddo
7074             endif
7075           enddo
7076
7077         enddo ! iii
7078
7079         dersc(1)=dersc(1)/cos(theti)**2
7080         ddersc(1)=ddersc(1)/cos(theti)**2
7081         ddersc(3)=ddersc(3)
7082
7083         escloci=-(dlog(escloc_i)-emin)
7084         do j=1,3
7085           dersc(j)=dersc(j)/escloc_i
7086         enddo
7087         if (mixed) then
7088           do j=1,3,2
7089             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7090           enddo
7091         endif
7092       return
7093       end
7094 C------------------------------------------------------------------------------
7095       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7096       implicit real*8 (a-h,o-z)
7097       include 'DIMENSIONS'
7098       include 'COMMON.GEO'
7099       include 'COMMON.LOCAL'
7100       include 'COMMON.IOUNITS'
7101       common /sccalc/ time11,time12,time112,theti,it,nlobit
7102       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7103       double precision contr(maxlob)
7104       logical mixed
7105
7106       escloc_i=0.0D0
7107
7108       do j=1,3
7109         dersc(j)=0.0D0
7110       enddo
7111
7112       do j=1,nlobit
7113         do k=1,2
7114           z(k)=x(k)-censc(k,j,it)
7115         enddo
7116         z(3)=dwapi
7117         do k=1,3
7118           Axk=0.0D0
7119           do l=1,3
7120             Axk=Axk+gaussc(l,k,j,it)*z(l)
7121           enddo
7122           Ax(k,j)=Axk
7123         enddo
7124         expfac=0.0D0
7125         do k=1,3
7126           expfac=expfac+Ax(k,j)*z(k)
7127         enddo
7128         contr(j)=expfac
7129       enddo ! j
7130
7131 C As in the case of ebend, we want to avoid underflows in exponentiation and
7132 C subsequent NaNs and INFs in energy calculation.
7133 C Find the largest exponent
7134       emin=contr(1)
7135       do j=1,nlobit
7136         if (emin.gt.contr(j)) emin=contr(j)
7137       enddo
7138       emin=0.5D0*emin
7139
7140 C Compute the contribution to SC energy and derivatives
7141
7142       dersc12=0.0d0
7143       do j=1,nlobit
7144         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7145         escloc_i=escloc_i+expfac
7146         do k=1,2
7147           dersc(k)=dersc(k)+Ax(k,j)*expfac
7148         enddo
7149         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7150      &            +gaussc(1,2,j,it))*expfac
7151         dersc(3)=0.0d0
7152       enddo
7153
7154       dersc(1)=dersc(1)/cos(theti)**2
7155       dersc12=dersc12/cos(theti)**2
7156       escloci=-(dlog(escloc_i)-emin)
7157       do j=1,2
7158         dersc(j)=dersc(j)/escloc_i
7159       enddo
7160       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7161       return
7162       end
7163 #else
7164 c----------------------------------------------------------------------------------
7165       subroutine esc(escloc)
7166 C Calculate the local energy of a side chain and its derivatives in the
7167 C corresponding virtual-bond valence angles THETA and the spherical angles
7168 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7169 C added by Urszula Kozlowska. 07/11/2007
7170 C
7171       implicit real*8 (a-h,o-z)
7172       include 'DIMENSIONS'
7173       include 'COMMON.GEO'
7174       include 'COMMON.LOCAL'
7175       include 'COMMON.VAR'
7176       include 'COMMON.SCROT'
7177       include 'COMMON.INTERACT'
7178       include 'COMMON.DERIV'
7179       include 'COMMON.CHAIN'
7180       include 'COMMON.IOUNITS'
7181       include 'COMMON.NAMES'
7182       include 'COMMON.FFIELD'
7183       include 'COMMON.CONTROL'
7184       include 'COMMON.VECTORS'
7185       double precision x_prime(3),y_prime(3),z_prime(3)
7186      &    , sumene,dsc_i,dp2_i,x(65),
7187      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7188      &    de_dxx,de_dyy,de_dzz,de_dt
7189       double precision s1_t,s1_6_t,s2_t,s2_6_t
7190       double precision
7191      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7192      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7193      & dt_dCi(3),dt_dCi1(3)
7194       common /sccalc/ time11,time12,time112,theti,it,nlobit
7195       delta=0.02d0*pi
7196       escloc=0.0D0
7197       do i=loc_start,loc_end
7198         if (itype(i).eq.ntyp1) cycle
7199         costtab(i+1) =dcos(theta(i+1))
7200         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7201         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7202         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7203         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7204         cosfac=dsqrt(cosfac2)
7205         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7206         sinfac=dsqrt(sinfac2)
7207         it=iabs(itype(i))
7208         if (it.eq.10) goto 1
7209 c
7210 C  Compute the axes of tghe local cartesian coordinates system; store in
7211 c   x_prime, y_prime and z_prime
7212 c
7213         do j=1,3
7214           x_prime(j) = 0.00
7215           y_prime(j) = 0.00
7216           z_prime(j) = 0.00
7217         enddo
7218 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7219 C     &   dc_norm(3,i+nres)
7220         do j = 1,3
7221           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7222           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7223         enddo
7224         do j = 1,3
7225           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7226         enddo
7227 c       write (2,*) "i",i
7228 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7229 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7230 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7231 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7232 c      & " xy",scalar(x_prime(1),y_prime(1)),
7233 c      & " xz",scalar(x_prime(1),z_prime(1)),
7234 c      & " yy",scalar(y_prime(1),y_prime(1)),
7235 c      & " yz",scalar(y_prime(1),z_prime(1)),
7236 c      & " zz",scalar(z_prime(1),z_prime(1))
7237 c
7238 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7239 C to local coordinate system. Store in xx, yy, zz.
7240 c
7241         xx=0.0d0
7242         yy=0.0d0
7243         zz=0.0d0
7244         do j = 1,3
7245           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7246           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7247           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7248         enddo
7249
7250         xxtab(i)=xx
7251         yytab(i)=yy
7252         zztab(i)=zz
7253 C
7254 C Compute the energy of the ith side cbain
7255 C
7256 c        write (2,*) "xx",xx," yy",yy," zz",zz
7257         it=iabs(itype(i))
7258         do j = 1,65
7259           x(j) = sc_parmin(j,it)
7260         enddo
7261 #ifdef CHECK_COORD
7262 Cc diagnostics - remove later
7263         xx1 = dcos(alph(2))
7264         yy1 = dsin(alph(2))*dcos(omeg(2))
7265         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7266         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7267      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7268      &    xx1,yy1,zz1
7269 C,"  --- ", xx_w,yy_w,zz_w
7270 c end diagnostics
7271 #endif
7272         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7273      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7274      &   + x(10)*yy*zz
7275         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7276      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7277      & + x(20)*yy*zz
7278         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7279      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7280      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7281      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7282      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7283      &  +x(40)*xx*yy*zz
7284         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7285      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7286      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7287      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7288      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7289      &  +x(60)*xx*yy*zz
7290         dsc_i   = 0.743d0+x(61)
7291         dp2_i   = 1.9d0+x(62)
7292         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7293      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7294         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7295      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7296         s1=(1+x(63))/(0.1d0 + dscp1)
7297         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7298         s2=(1+x(65))/(0.1d0 + dscp2)
7299         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7300         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7301      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7302 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7303 c     &   sumene4,
7304 c     &   dscp1,dscp2,sumene
7305 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7306         escloc = escloc + sumene
7307 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7308 c     & ,zz,xx,yy
7309 c#define DEBUG
7310 #ifdef DEBUG
7311 C
7312 C This section to check the numerical derivatives of the energy of ith side
7313 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7314 C #define DEBUG in the code to turn it on.
7315 C
7316         write (2,*) "sumene               =",sumene
7317         aincr=1.0d-7
7318         xxsave=xx
7319         xx=xx+aincr
7320         write (2,*) xx,yy,zz
7321         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7322         de_dxx_num=(sumenep-sumene)/aincr
7323         xx=xxsave
7324         write (2,*) "xx+ sumene from enesc=",sumenep
7325         yysave=yy
7326         yy=yy+aincr
7327         write (2,*) xx,yy,zz
7328         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7329         de_dyy_num=(sumenep-sumene)/aincr
7330         yy=yysave
7331         write (2,*) "yy+ sumene from enesc=",sumenep
7332         zzsave=zz
7333         zz=zz+aincr
7334         write (2,*) xx,yy,zz
7335         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7336         de_dzz_num=(sumenep-sumene)/aincr
7337         zz=zzsave
7338         write (2,*) "zz+ sumene from enesc=",sumenep
7339         costsave=cost2tab(i+1)
7340         sintsave=sint2tab(i+1)
7341         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7342         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7344         de_dt_num=(sumenep-sumene)/aincr
7345         write (2,*) " t+ sumene from enesc=",sumenep
7346         cost2tab(i+1)=costsave
7347         sint2tab(i+1)=sintsave
7348 C End of diagnostics section.
7349 #endif
7350 C
7351 C Compute the gradient of esc
7352 C
7353 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7354         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7355         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7356         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7357         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7358         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7359         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7360         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7361         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7362         pom1=(sumene3*sint2tab(i+1)+sumene1)
7363      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7364         pom2=(sumene4*cost2tab(i+1)+sumene2)
7365      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7366         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7367         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7368      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7369      &  +x(40)*yy*zz
7370         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7371         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7372      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7373      &  +x(60)*yy*zz
7374         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7375      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7376      &        +(pom1+pom2)*pom_dx
7377 #ifdef DEBUG
7378         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7379 #endif
7380 C
7381         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7382         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7383      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7384      &  +x(40)*xx*zz
7385         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7386         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7387      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7388      &  +x(59)*zz**2 +x(60)*xx*zz
7389         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7390      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7391      &        +(pom1-pom2)*pom_dy
7392 #ifdef DEBUG
7393         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7394 #endif
7395 C
7396         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7397      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7398      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7399      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7400      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7401      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7402      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7403      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7404 #ifdef DEBUG
7405         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7406 #endif
7407 C
7408         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7409      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7410      &  +pom1*pom_dt1+pom2*pom_dt2
7411 #ifdef DEBUG
7412         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7413 #endif
7414 c#undef DEBUG
7415 c
7416 C
7417        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7418        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7419        cosfac2xx=cosfac2*xx
7420        sinfac2yy=sinfac2*yy
7421        do k = 1,3
7422          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7423      &      vbld_inv(i+1)
7424          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7425      &      vbld_inv(i)
7426          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7427          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7428 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7429 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7430 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7431 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7432          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7433          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7434          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7435          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7436          dZZ_Ci1(k)=0.0d0
7437          dZZ_Ci(k)=0.0d0
7438          do j=1,3
7439            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7440      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7441            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7442      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7443          enddo
7444
7445          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7446          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7447          dZZ_XYZ(k)=vbld_inv(i+nres)*
7448      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7449 c
7450          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7451          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7452        enddo
7453
7454        do k=1,3
7455          dXX_Ctab(k,i)=dXX_Ci(k)
7456          dXX_C1tab(k,i)=dXX_Ci1(k)
7457          dYY_Ctab(k,i)=dYY_Ci(k)
7458          dYY_C1tab(k,i)=dYY_Ci1(k)
7459          dZZ_Ctab(k,i)=dZZ_Ci(k)
7460          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7461          dXX_XYZtab(k,i)=dXX_XYZ(k)
7462          dYY_XYZtab(k,i)=dYY_XYZ(k)
7463          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7464        enddo
7465
7466        do k = 1,3
7467 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7468 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7469 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7470 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7471 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7472 c     &    dt_dci(k)
7473 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7474 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7475          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7476      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7477          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7478      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7479          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7480      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7481        enddo
7482 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7483 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7484
7485 C to check gradient call subroutine check_grad
7486
7487     1 continue
7488       enddo
7489       return
7490       end
7491 c------------------------------------------------------------------------------
7492       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7493       implicit none
7494       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7495      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7496       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7497      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7498      &   + x(10)*yy*zz
7499       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7500      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7501      & + x(20)*yy*zz
7502       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7503      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7504      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7505      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7506      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7507      &  +x(40)*xx*yy*zz
7508       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7509      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7510      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7511      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7512      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7513      &  +x(60)*xx*yy*zz
7514       dsc_i   = 0.743d0+x(61)
7515       dp2_i   = 1.9d0+x(62)
7516       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7517      &          *(xx*cost2+yy*sint2))
7518       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7519      &          *(xx*cost2-yy*sint2))
7520       s1=(1+x(63))/(0.1d0 + dscp1)
7521       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7522       s2=(1+x(65))/(0.1d0 + dscp2)
7523       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7524       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7525      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7526       enesc=sumene
7527       return
7528       end
7529 #endif
7530 c------------------------------------------------------------------------------
7531       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7532 C
7533 C This procedure calculates two-body contact function g(rij) and its derivative:
7534 C
7535 C           eps0ij                                     !       x < -1
7536 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7537 C            0                                         !       x > 1
7538 C
7539 C where x=(rij-r0ij)/delta
7540 C
7541 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7542 C
7543       implicit none
7544       double precision rij,r0ij,eps0ij,fcont,fprimcont
7545       double precision x,x2,x4,delta
7546 c     delta=0.02D0*r0ij
7547 c      delta=0.2D0*r0ij
7548       x=(rij-r0ij)/delta
7549       if (x.lt.-1.0D0) then
7550         fcont=eps0ij
7551         fprimcont=0.0D0
7552       else if (x.le.1.0D0) then
7553         x2=x*x
7554         x4=x2*x2
7555         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7556         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7557       else
7558         fcont=0.0D0
7559         fprimcont=0.0D0
7560       endif
7561       return
7562       end
7563 c------------------------------------------------------------------------------
7564       subroutine splinthet(theti,delta,ss,ssder)
7565       implicit real*8 (a-h,o-z)
7566       include 'DIMENSIONS'
7567       include 'COMMON.VAR'
7568       include 'COMMON.GEO'
7569       thetup=pi-delta
7570       thetlow=delta
7571       if (theti.gt.pipol) then
7572         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7573       else
7574         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7575         ssder=-ssder
7576       endif
7577       return
7578       end
7579 c------------------------------------------------------------------------------
7580       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7581       implicit none
7582       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7583       double precision ksi,ksi2,ksi3,a1,a2,a3
7584       a1=fprim0*delta/(f1-f0)
7585       a2=3.0d0-2.0d0*a1
7586       a3=a1-2.0d0
7587       ksi=(x-x0)/delta
7588       ksi2=ksi*ksi
7589       ksi3=ksi2*ksi
7590       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7591       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7592       return
7593       end
7594 c------------------------------------------------------------------------------
7595       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7596       implicit none
7597       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7598       double precision ksi,ksi2,ksi3,a1,a2,a3
7599       ksi=(x-x0)/delta
7600       ksi2=ksi*ksi
7601       ksi3=ksi2*ksi
7602       a1=fprim0x*delta
7603       a2=3*(f1x-f0x)-2*fprim0x*delta
7604       a3=fprim0x*delta-2*(f1x-f0x)
7605       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7606       return
7607       end
7608 C-----------------------------------------------------------------------------
7609 #ifdef CRYST_TOR
7610 C-----------------------------------------------------------------------------
7611       subroutine etor(etors,edihcnstr)
7612       implicit real*8 (a-h,o-z)
7613       include 'DIMENSIONS'
7614       include 'COMMON.VAR'
7615       include 'COMMON.GEO'
7616       include 'COMMON.LOCAL'
7617       include 'COMMON.TORSION'
7618       include 'COMMON.INTERACT'
7619       include 'COMMON.DERIV'
7620       include 'COMMON.CHAIN'
7621       include 'COMMON.NAMES'
7622       include 'COMMON.IOUNITS'
7623       include 'COMMON.FFIELD'
7624       include 'COMMON.TORCNSTR'
7625       include 'COMMON.CONTROL'
7626       logical lprn
7627 C Set lprn=.true. for debugging
7628       lprn=.false.
7629 c      lprn=.true.
7630       etors=0.0D0
7631       do i=iphi_start,iphi_end
7632       etors_ii=0.0D0
7633         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7634      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7635         itori=itortyp(itype(i-2))
7636         itori1=itortyp(itype(i-1))
7637         phii=phi(i)
7638         gloci=0.0D0
7639 C Proline-Proline pair is a special case...
7640         if (itori.eq.3 .and. itori1.eq.3) then
7641           if (phii.gt.-dwapi3) then
7642             cosphi=dcos(3*phii)
7643             fac=1.0D0/(1.0D0-cosphi)
7644             etorsi=v1(1,3,3)*fac
7645             etorsi=etorsi+etorsi
7646             etors=etors+etorsi-v1(1,3,3)
7647             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7648             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7649           endif
7650           do j=1,3
7651             v1ij=v1(j+1,itori,itori1)
7652             v2ij=v2(j+1,itori,itori1)
7653             cosphi=dcos(j*phii)
7654             sinphi=dsin(j*phii)
7655             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7656             if (energy_dec) etors_ii=etors_ii+
7657      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7658             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7659           enddo
7660         else
7661           do j=1,nterm_old
7662             v1ij=v1(j,itori,itori1)
7663             v2ij=v2(j,itori,itori1)
7664             cosphi=dcos(j*phii)
7665             sinphi=dsin(j*phii)
7666             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7667             if (energy_dec) etors_ii=etors_ii+
7668      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7669             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7670           enddo
7671         endif
7672         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7673              'etor',i,etors_ii
7674         if (lprn)
7675      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7676      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7677      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7678         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7679 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7680       enddo
7681 ! 6/20/98 - dihedral angle constraints
7682       edihcnstr=0.0d0
7683       do i=1,ndih_constr
7684         itori=idih_constr(i)
7685         phii=phi(itori)
7686         difi=phii-phi0(i)
7687         if (difi.gt.drange(i)) then
7688           difi=difi-drange(i)
7689           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7690           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7691         else if (difi.lt.-drange(i)) then
7692           difi=difi+drange(i)
7693           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7694           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7695         endif
7696 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7697 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7698       enddo
7699 !      write (iout,*) 'edihcnstr',edihcnstr
7700       return
7701       end
7702 c------------------------------------------------------------------------------
7703       subroutine etor_d(etors_d)
7704       etors_d=0.0d0
7705       return
7706       end
7707 c----------------------------------------------------------------------------
7708 #else
7709       subroutine etor(etors,edihcnstr)
7710       implicit real*8 (a-h,o-z)
7711       include 'DIMENSIONS'
7712       include 'COMMON.VAR'
7713       include 'COMMON.GEO'
7714       include 'COMMON.LOCAL'
7715       include 'COMMON.TORSION'
7716       include 'COMMON.INTERACT'
7717       include 'COMMON.DERIV'
7718       include 'COMMON.CHAIN'
7719       include 'COMMON.NAMES'
7720       include 'COMMON.IOUNITS'
7721       include 'COMMON.FFIELD'
7722       include 'COMMON.TORCNSTR'
7723       include 'COMMON.CONTROL'
7724       logical lprn
7725 C Set lprn=.true. for debugging
7726       lprn=.false.
7727 c     lprn=.true.
7728       etors=0.0D0
7729       do i=iphi_start,iphi_end
7730 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7731 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7732 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7733 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7734         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7735      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7736 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7737 C For introducing the NH3+ and COO- group please check the etor_d for reference
7738 C and guidance
7739         etors_ii=0.0D0
7740          if (iabs(itype(i)).eq.20) then
7741          iblock=2
7742          else
7743          iblock=1
7744          endif
7745         itori=itortyp(itype(i-2))
7746         itori1=itortyp(itype(i-1))
7747         phii=phi(i)
7748         gloci=0.0D0
7749 C Regular cosine and sine terms
7750         do j=1,nterm(itori,itori1,iblock)
7751           v1ij=v1(j,itori,itori1,iblock)
7752           v2ij=v2(j,itori,itori1,iblock)
7753           cosphi=dcos(j*phii)
7754           sinphi=dsin(j*phii)
7755           etors=etors+v1ij*cosphi+v2ij*sinphi
7756           if (energy_dec) etors_ii=etors_ii+
7757      &                v1ij*cosphi+v2ij*sinphi
7758           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7759         enddo
7760 C Lorentz terms
7761 C                         v1
7762 C  E = SUM ----------------------------------- - v1
7763 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7764 C
7765         cosphi=dcos(0.5d0*phii)
7766         sinphi=dsin(0.5d0*phii)
7767         do j=1,nlor(itori,itori1,iblock)
7768           vl1ij=vlor1(j,itori,itori1)
7769           vl2ij=vlor2(j,itori,itori1)
7770           vl3ij=vlor3(j,itori,itori1)
7771           pom=vl2ij*cosphi+vl3ij*sinphi
7772           pom1=1.0d0/(pom*pom+1.0d0)
7773           etors=etors+vl1ij*pom1
7774           if (energy_dec) etors_ii=etors_ii+
7775      &                vl1ij*pom1
7776           pom=-pom*pom1*pom1
7777           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7778         enddo
7779 C Subtract the constant term
7780         etors=etors-v0(itori,itori1,iblock)
7781           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7782      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7783         if (lprn)
7784      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7785      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7786      &  (v1(j,itori,itori1,iblock),j=1,6),
7787      &  (v2(j,itori,itori1,iblock),j=1,6)
7788         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7789 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7790       enddo
7791 ! 6/20/98 - dihedral angle constraints
7792       edihcnstr=0.0d0
7793 c      do i=1,ndih_constr
7794       do i=idihconstr_start,idihconstr_end
7795         itori=idih_constr(i)
7796         phii=phi(itori)
7797         difi=pinorm(phii-phi0(i))
7798         if (difi.gt.drange(i)) then
7799           difi=difi-drange(i)
7800           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7801           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7802         else if (difi.lt.-drange(i)) then
7803           difi=difi+drange(i)
7804           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7806         else
7807           difi=0.0
7808         endif
7809        if (energy_dec) then
7810         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7811      &    i,itori,rad2deg*phii,
7812      &    rad2deg*phi0(i),  rad2deg*drange(i),
7813      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7814         endif
7815       enddo
7816 cd       write (iout,*) 'edihcnstr',edihcnstr
7817       return
7818       end
7819 c----------------------------------------------------------------------------
7820       subroutine etor_d(etors_d)
7821 C 6/23/01 Compute double torsional energy
7822       implicit real*8 (a-h,o-z)
7823       include 'DIMENSIONS'
7824       include 'COMMON.VAR'
7825       include 'COMMON.GEO'
7826       include 'COMMON.LOCAL'
7827       include 'COMMON.TORSION'
7828       include 'COMMON.INTERACT'
7829       include 'COMMON.DERIV'
7830       include 'COMMON.CHAIN'
7831       include 'COMMON.NAMES'
7832       include 'COMMON.IOUNITS'
7833       include 'COMMON.FFIELD'
7834       include 'COMMON.TORCNSTR'
7835       logical lprn
7836 C Set lprn=.true. for debugging
7837       lprn=.false.
7838 c     lprn=.true.
7839       etors_d=0.0D0
7840 c      write(iout,*) "a tu??"
7841       do i=iphid_start,iphid_end
7842 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7843 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7844 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7845 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7846 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7847          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7848      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7849      &  (itype(i+1).eq.ntyp1)) cycle
7850 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7851         itori=itortyp(itype(i-2))
7852         itori1=itortyp(itype(i-1))
7853         itori2=itortyp(itype(i))
7854         phii=phi(i)
7855         phii1=phi(i+1)
7856         gloci1=0.0D0
7857         gloci2=0.0D0
7858         iblock=1
7859         if (iabs(itype(i+1)).eq.20) iblock=2
7860 C Iblock=2 Proline type
7861 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7862 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7863 C        if (itype(i+1).eq.ntyp1) iblock=3
7864 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7865 C IS or IS NOT need for this
7866 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7867 C        is (itype(i-3).eq.ntyp1) ntblock=2
7868 C        ntblock is N-terminal blocking group
7869
7870 C Regular cosine and sine terms
7871         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7872 C Example of changes for NH3+ blocking group
7873 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7874 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7875           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7876           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7877           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7878           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7879           cosphi1=dcos(j*phii)
7880           sinphi1=dsin(j*phii)
7881           cosphi2=dcos(j*phii1)
7882           sinphi2=dsin(j*phii1)
7883           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7884      &     v2cij*cosphi2+v2sij*sinphi2
7885           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7886           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7887         enddo
7888         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7889           do l=1,k-1
7890             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7891             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7892             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7893             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7894             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7895             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7896             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7897             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7898             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7899      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7900             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7901      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7902             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7903      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7904           enddo
7905         enddo
7906         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7907         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7908       enddo
7909       return
7910       end
7911 #endif
7912 C----------------------------------------------------------------------------------
7913 C The rigorous attempt to derive energy function
7914       subroutine etor_kcc(etors,edihcnstr)
7915       implicit real*8 (a-h,o-z)
7916       include 'DIMENSIONS'
7917       include 'COMMON.VAR'
7918       include 'COMMON.GEO'
7919       include 'COMMON.LOCAL'
7920       include 'COMMON.TORSION'
7921       include 'COMMON.INTERACT'
7922       include 'COMMON.DERIV'
7923       include 'COMMON.CHAIN'
7924       include 'COMMON.NAMES'
7925       include 'COMMON.IOUNITS'
7926       include 'COMMON.FFIELD'
7927       include 'COMMON.TORCNSTR'
7928       include 'COMMON.CONTROL'
7929       logical lprn
7930 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7931 C Set lprn=.true. for debugging
7932       lprn=.false.
7933 c     lprn=.true.
7934 C      print *,"wchodze kcc"
7935       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7936       if (tor_mode.ne.2) then
7937       etors=0.0D0
7938       endif
7939       do i=iphi_start,iphi_end
7940 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7941 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7942 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7943 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7944         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7945      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7946         itori=itortyp_kcc(itype(i-2))
7947         itori1=itortyp_kcc(itype(i-1))
7948         phii=phi(i)
7949         glocig=0.0D0
7950         glocit1=0.0d0
7951         glocit2=0.0d0
7952         sumnonchebyshev=0.0d0
7953         sumchebyshev=0.0d0
7954 C to avoid multiple devision by 2
7955 c        theti22=0.5d0*theta(i)
7956 C theta 12 is the theta_1 /2
7957 C theta 22 is theta_2 /2
7958 c        theti12=0.5d0*theta(i-1)
7959 C and appropriate sinus function
7960         sinthet1=dsin(theta(i-1))
7961         sinthet2=dsin(theta(i))
7962         costhet1=dcos(theta(i-1))
7963         costhet2=dcos(theta(i))
7964 c Cosines of halves thetas
7965         costheti12=0.5d0*(1.0d0+costhet1)
7966         costheti22=0.5d0*(1.0d0+costhet2)
7967 C to speed up lets store its mutliplication
7968         sint1t2=sinthet2*sinthet1
7969         sint1t2n=1.0d0
7970 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7971 C +d_n*sin(n*gamma)) *
7972 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7973 C we have two sum 1) Non-Chebyshev which is with n and gamma
7974         etori=0.0d0
7975         do j=1,nterm_kcc(itori,itori1)
7976
7977           nval=nterm_kcc_Tb(itori,itori1)
7978           v1ij=v1_kcc(j,itori,itori1)
7979           v2ij=v2_kcc(j,itori,itori1)
7980 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7981 C v1ij is c_n and d_n in euation above
7982           cosphi=dcos(j*phii)
7983           sinphi=dsin(j*phii)
7984           sint1t2n1=sint1t2n
7985           sint1t2n=sint1t2n*sint1t2
7986           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7987      &        costheti12)
7988           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7989      &        v11_chyb(1,j,itori,itori1),costheti12)
7990 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7991 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7992           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7993      &        costheti22)
7994           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7995      &        v21_chyb(1,j,itori,itori1),costheti22)
7996 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7997 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7998           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7999      &        costheti12)
8000           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8001      &        v12_chyb(1,j,itori,itori1),costheti12)
8002 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8003 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8004           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8005      &        costheti22)
8006           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8007      &        v22_chyb(1,j,itori,itori1),costheti22)
8008 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8009 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8010 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8011 C          if (energy_dec) etors_ii=etors_ii+
8012 C     &                v1ij*cosphi+v2ij*sinphi
8013 C glocig is the gradient local i site in gamma
8014           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8015           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8016           etori=etori+sint1t2n*(actval1+actval2)
8017           glocig=glocig+
8018      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8019      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8020 C now gradient over theta_1
8021           glocit1=glocit1+
8022      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8023      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8024           glocit2=glocit2+
8025      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8026      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8027
8028 C now the Czebyshev polinominal sum
8029 c        do k=1,nterm_kcc_Tb(itori,itori1)
8030 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
8031 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
8032 C         thybt1(k)=0.0
8033 C         thybt2(k)=0.0
8034 c        enddo
8035 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8036 C     &         gradtschebyshev
8037 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8038 C     &         dcos(theti22)**2),
8039 C     &         dsin(theti22)
8040
8041 C now overal sumation
8042 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8043         enddo ! j
8044         etors=etors+etori
8045 C derivative over gamma
8046         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8047 C derivative over theta1
8048         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8049 C now derivative over theta2
8050         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8051         if (lprn)
8052      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8053      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8054       enddo
8055 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8056 ! 6/20/98 - dihedral angle constraints
8057       if (tor_mode.ne.2) then
8058       edihcnstr=0.0d0
8059 c      do i=1,ndih_constr
8060       do i=idihconstr_start,idihconstr_end
8061         itori=idih_constr(i)
8062         phii=phi(itori)
8063         difi=pinorm(phii-phi0(i))
8064         if (difi.gt.drange(i)) then
8065           difi=difi-drange(i)
8066           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8067           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8068         else if (difi.lt.-drange(i)) then
8069           difi=difi+drange(i)
8070           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8071           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8072         else
8073           difi=0.0
8074         endif
8075        enddo
8076        endif
8077       return
8078       end
8079
8080 C The rigorous attempt to derive energy function
8081       subroutine ebend_kcc(etheta,ethetacnstr)
8082
8083       implicit real*8 (a-h,o-z)
8084       include 'DIMENSIONS'
8085       include 'COMMON.VAR'
8086       include 'COMMON.GEO'
8087       include 'COMMON.LOCAL'
8088       include 'COMMON.TORSION'
8089       include 'COMMON.INTERACT'
8090       include 'COMMON.DERIV'
8091       include 'COMMON.CHAIN'
8092       include 'COMMON.NAMES'
8093       include 'COMMON.IOUNITS'
8094       include 'COMMON.FFIELD'
8095       include 'COMMON.TORCNSTR'
8096       include 'COMMON.CONTROL'
8097       logical lprn
8098       double precision thybt1(maxtermkcc)
8099 C Set lprn=.true. for debugging
8100       lprn=.false.
8101 c     lprn=.true.
8102 C      print *,"wchodze kcc"
8103       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8104       if (tor_mode.ne.2) etheta=0.0D0
8105       do i=ithet_start,ithet_end
8106 c        print *,i,itype(i-1),itype(i),itype(i-2)
8107         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8108      &  .or.itype(i).eq.ntyp1) cycle
8109          iti=itortyp_kcc(itype(i-1))
8110         sinthet=dsin(theta(i)/2.0d0)
8111         costhet=dcos(theta(i)/2.0d0)
8112          do j=1,nbend_kcc_Tb(iti)
8113           thybt1(j)=v1bend_chyb(j,iti)
8114          enddo
8115          sumth1thyb=tschebyshev
8116      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8117         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8118      &    sumth1thyb
8119         ihelp=nbend_kcc_Tb(iti)-1
8120         gradthybt1=gradtschebyshev
8121      &         (0,ihelp,thybt1(1),costhet)
8122         etheta=etheta+sumth1thyb
8123 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8124         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8125      &   gradthybt1*sinthet*(-0.5d0)
8126       enddo
8127       if (tor_mode.ne.2) then
8128       ethetacnstr=0.0d0
8129 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8130       do i=ithetaconstr_start,ithetaconstr_end
8131         itheta=itheta_constr(i)
8132         thetiii=theta(itheta)
8133         difi=pinorm(thetiii-theta_constr0(i))
8134         if (difi.gt.theta_drange(i)) then
8135           difi=difi-theta_drange(i)
8136           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8137           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8138      &    +for_thet_constr(i)*difi**3
8139         else if (difi.lt.-drange(i)) then
8140           difi=difi+drange(i)
8141           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8142           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8143      &    +for_thet_constr(i)*difi**3
8144         else
8145           difi=0.0
8146         endif
8147        if (energy_dec) then
8148         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8149      &    i,itheta,rad2deg*thetiii,
8150      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8151      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8152      &    gloc(itheta+nphi-2,icg)
8153         endif
8154       enddo
8155       endif
8156       return
8157       end
8158 c------------------------------------------------------------------------------
8159       subroutine eback_sc_corr(esccor)
8160 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8161 c        conformational states; temporarily implemented as differences
8162 c        between UNRES torsional potentials (dependent on three types of
8163 c        residues) and the torsional potentials dependent on all 20 types
8164 c        of residues computed from AM1  energy surfaces of terminally-blocked
8165 c        amino-acid residues.
8166       implicit real*8 (a-h,o-z)
8167       include 'DIMENSIONS'
8168       include 'COMMON.VAR'
8169       include 'COMMON.GEO'
8170       include 'COMMON.LOCAL'
8171       include 'COMMON.TORSION'
8172       include 'COMMON.SCCOR'
8173       include 'COMMON.INTERACT'
8174       include 'COMMON.DERIV'
8175       include 'COMMON.CHAIN'
8176       include 'COMMON.NAMES'
8177       include 'COMMON.IOUNITS'
8178       include 'COMMON.FFIELD'
8179       include 'COMMON.CONTROL'
8180       logical lprn
8181 C Set lprn=.true. for debugging
8182       lprn=.false.
8183 c      lprn=.true.
8184 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8185       esccor=0.0D0
8186       do i=itau_start,itau_end
8187         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8188         esccor_ii=0.0D0
8189         isccori=isccortyp(itype(i-2))
8190         isccori1=isccortyp(itype(i-1))
8191 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8192         phii=phi(i)
8193         do intertyp=1,3 !intertyp
8194 cc Added 09 May 2012 (Adasko)
8195 cc  Intertyp means interaction type of backbone mainchain correlation:
8196 c   1 = SC...Ca...Ca...Ca
8197 c   2 = Ca...Ca...Ca...SC
8198 c   3 = SC...Ca...Ca...SCi
8199         gloci=0.0D0
8200         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8201      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8202      &      (itype(i-1).eq.ntyp1)))
8203      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8204      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8205      &     .or.(itype(i).eq.ntyp1)))
8206      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8207      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8208      &      (itype(i-3).eq.ntyp1)))) cycle
8209         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8210         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8211      & cycle
8212        do j=1,nterm_sccor(isccori,isccori1)
8213           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8214           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8215           cosphi=dcos(j*tauangle(intertyp,i))
8216           sinphi=dsin(j*tauangle(intertyp,i))
8217           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8218           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8219         enddo
8220 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8221         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8222         if (lprn)
8223      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8224      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8225      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8226      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8227         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8228        enddo !intertyp
8229       enddo
8230
8231       return
8232       end
8233 c----------------------------------------------------------------------------
8234       subroutine multibody(ecorr)
8235 C This subroutine calculates multi-body contributions to energy following
8236 C the idea of Skolnick et al. If side chains I and J make a contact and
8237 C at the same time side chains I+1 and J+1 make a contact, an extra
8238 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8239       implicit real*8 (a-h,o-z)
8240       include 'DIMENSIONS'
8241       include 'COMMON.IOUNITS'
8242       include 'COMMON.DERIV'
8243       include 'COMMON.INTERACT'
8244       include 'COMMON.CONTACTS'
8245       double precision gx(3),gx1(3)
8246       logical lprn
8247
8248 C Set lprn=.true. for debugging
8249       lprn=.false.
8250
8251       if (lprn) then
8252         write (iout,'(a)') 'Contact function values:'
8253         do i=nnt,nct-2
8254           write (iout,'(i2,20(1x,i2,f10.5))')
8255      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8256         enddo
8257       endif
8258       ecorr=0.0D0
8259       do i=nnt,nct
8260         do j=1,3
8261           gradcorr(j,i)=0.0D0
8262           gradxorr(j,i)=0.0D0
8263         enddo
8264       enddo
8265       do i=nnt,nct-2
8266
8267         DO ISHIFT = 3,4
8268
8269         i1=i+ishift
8270         num_conti=num_cont(i)
8271         num_conti1=num_cont(i1)
8272         do jj=1,num_conti
8273           j=jcont(jj,i)
8274           do kk=1,num_conti1
8275             j1=jcont(kk,i1)
8276             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8277 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8278 cd   &                   ' ishift=',ishift
8279 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8280 C The system gains extra energy.
8281               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8282             endif   ! j1==j+-ishift
8283           enddo     ! kk
8284         enddo       ! jj
8285
8286         ENDDO ! ISHIFT
8287
8288       enddo         ! i
8289       return
8290       end
8291 c------------------------------------------------------------------------------
8292       double precision function esccorr(i,j,k,l,jj,kk)
8293       implicit real*8 (a-h,o-z)
8294       include 'DIMENSIONS'
8295       include 'COMMON.IOUNITS'
8296       include 'COMMON.DERIV'
8297       include 'COMMON.INTERACT'
8298       include 'COMMON.CONTACTS'
8299       include 'COMMON.SHIELD'
8300       double precision gx(3),gx1(3)
8301       logical lprn
8302       lprn=.false.
8303       eij=facont(jj,i)
8304       ekl=facont(kk,k)
8305 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8306 C Calculate the multi-body contribution to energy.
8307 C Calculate multi-body contributions to the gradient.
8308 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8309 cd   & k,l,(gacont(m,kk,k),m=1,3)
8310       do m=1,3
8311         gx(m) =ekl*gacont(m,jj,i)
8312         gx1(m)=eij*gacont(m,kk,k)
8313         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8314         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8315         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8316         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8317       enddo
8318       do m=i,j-1
8319         do ll=1,3
8320           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8321         enddo
8322       enddo
8323       do m=k,l-1
8324         do ll=1,3
8325           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8326         enddo
8327       enddo
8328       esccorr=-eij*ekl
8329       return
8330       end
8331 c------------------------------------------------------------------------------
8332       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8333 C This subroutine calculates multi-body contributions to hydrogen-bonding
8334       implicit real*8 (a-h,o-z)
8335       include 'DIMENSIONS'
8336       include 'COMMON.IOUNITS'
8337 #ifdef MPI
8338       include "mpif.h"
8339       parameter (max_cont=maxconts)
8340       parameter (max_dim=26)
8341       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8342       double precision zapas(max_dim,maxconts,max_fg_procs),
8343      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8344       common /przechowalnia/ zapas
8345       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8346      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8347 #endif
8348       include 'COMMON.SETUP'
8349       include 'COMMON.FFIELD'
8350       include 'COMMON.DERIV'
8351       include 'COMMON.INTERACT'
8352       include 'COMMON.CONTACTS'
8353       include 'COMMON.CONTROL'
8354       include 'COMMON.LOCAL'
8355       double precision gx(3),gx1(3),time00
8356       logical lprn,ldone
8357
8358 C Set lprn=.true. for debugging
8359       lprn=.false.
8360 #ifdef MPI
8361       n_corr=0
8362       n_corr1=0
8363       if (nfgtasks.le.1) goto 30
8364       if (lprn) then
8365         write (iout,'(a)') 'Contact function values before RECEIVE:'
8366         do i=nnt,nct-2
8367           write (iout,'(2i3,50(1x,i2,f5.2))')
8368      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8369      &    j=1,num_cont_hb(i))
8370         enddo
8371       endif
8372       call flush(iout)
8373       do i=1,ntask_cont_from
8374         ncont_recv(i)=0
8375       enddo
8376       do i=1,ntask_cont_to
8377         ncont_sent(i)=0
8378       enddo
8379 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8380 c     & ntask_cont_to
8381 C Make the list of contacts to send to send to other procesors
8382 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8383 c      call flush(iout)
8384       do i=iturn3_start,iturn3_end
8385 c        write (iout,*) "make contact list turn3",i," num_cont",
8386 c     &    num_cont_hb(i)
8387         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8388       enddo
8389       do i=iturn4_start,iturn4_end
8390 c        write (iout,*) "make contact list turn4",i," num_cont",
8391 c     &   num_cont_hb(i)
8392         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8393       enddo
8394       do ii=1,nat_sent
8395         i=iat_sent(ii)
8396 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8397 c     &    num_cont_hb(i)
8398         do j=1,num_cont_hb(i)
8399         do k=1,4
8400           jjc=jcont_hb(j,i)
8401           iproc=iint_sent_local(k,jjc,ii)
8402 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8403           if (iproc.gt.0) then
8404             ncont_sent(iproc)=ncont_sent(iproc)+1
8405             nn=ncont_sent(iproc)
8406             zapas(1,nn,iproc)=i
8407             zapas(2,nn,iproc)=jjc
8408             zapas(3,nn,iproc)=facont_hb(j,i)
8409             zapas(4,nn,iproc)=ees0p(j,i)
8410             zapas(5,nn,iproc)=ees0m(j,i)
8411             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8412             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8413             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8414             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8415             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8416             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8417             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8418             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8419             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8420             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8421             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8422             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8423             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8424             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8425             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8426             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8427             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8428             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8429             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8430             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8431             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8432           endif
8433         enddo
8434         enddo
8435       enddo
8436       if (lprn) then
8437       write (iout,*)
8438      &  "Numbers of contacts to be sent to other processors",
8439      &  (ncont_sent(i),i=1,ntask_cont_to)
8440       write (iout,*) "Contacts sent"
8441       do ii=1,ntask_cont_to
8442         nn=ncont_sent(ii)
8443         iproc=itask_cont_to(ii)
8444         write (iout,*) nn," contacts to processor",iproc,
8445      &   " of CONT_TO_COMM group"
8446         do i=1,nn
8447           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8448         enddo
8449       enddo
8450       call flush(iout)
8451       endif
8452       CorrelType=477
8453       CorrelID=fg_rank+1
8454       CorrelType1=478
8455       CorrelID1=nfgtasks+fg_rank+1
8456       ireq=0
8457 C Receive the numbers of needed contacts from other processors
8458       do ii=1,ntask_cont_from
8459         iproc=itask_cont_from(ii)
8460         ireq=ireq+1
8461         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8462      &    FG_COMM,req(ireq),IERR)
8463       enddo
8464 c      write (iout,*) "IRECV ended"
8465 c      call flush(iout)
8466 C Send the number of contacts needed by other processors
8467       do ii=1,ntask_cont_to
8468         iproc=itask_cont_to(ii)
8469         ireq=ireq+1
8470         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8471      &    FG_COMM,req(ireq),IERR)
8472       enddo
8473 c      write (iout,*) "ISEND ended"
8474 c      write (iout,*) "number of requests (nn)",ireq
8475       call flush(iout)
8476       if (ireq.gt.0)
8477      &  call MPI_Waitall(ireq,req,status_array,ierr)
8478 c      write (iout,*)
8479 c     &  "Numbers of contacts to be received from other processors",
8480 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8481 c      call flush(iout)
8482 C Receive contacts
8483       ireq=0
8484       do ii=1,ntask_cont_from
8485         iproc=itask_cont_from(ii)
8486         nn=ncont_recv(ii)
8487 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8488 c     &   " of CONT_TO_COMM group"
8489         call flush(iout)
8490         if (nn.gt.0) then
8491           ireq=ireq+1
8492           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8493      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8494 c          write (iout,*) "ireq,req",ireq,req(ireq)
8495         endif
8496       enddo
8497 C Send the contacts to processors that need them
8498       do ii=1,ntask_cont_to
8499         iproc=itask_cont_to(ii)
8500         nn=ncont_sent(ii)
8501 c        write (iout,*) nn," contacts to processor",iproc,
8502 c     &   " of CONT_TO_COMM group"
8503         if (nn.gt.0) then
8504           ireq=ireq+1
8505           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8506      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8507 c          write (iout,*) "ireq,req",ireq,req(ireq)
8508 c          do i=1,nn
8509 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8510 c          enddo
8511         endif
8512       enddo
8513 c      write (iout,*) "number of requests (contacts)",ireq
8514 c      write (iout,*) "req",(req(i),i=1,4)
8515 c      call flush(iout)
8516       if (ireq.gt.0)
8517      & call MPI_Waitall(ireq,req,status_array,ierr)
8518       do iii=1,ntask_cont_from
8519         iproc=itask_cont_from(iii)
8520         nn=ncont_recv(iii)
8521         if (lprn) then
8522         write (iout,*) "Received",nn," contacts from processor",iproc,
8523      &   " of CONT_FROM_COMM group"
8524         call flush(iout)
8525         do i=1,nn
8526           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8527         enddo
8528         call flush(iout)
8529         endif
8530         do i=1,nn
8531           ii=zapas_recv(1,i,iii)
8532 c Flag the received contacts to prevent double-counting
8533           jj=-zapas_recv(2,i,iii)
8534 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8535 c          call flush(iout)
8536           nnn=num_cont_hb(ii)+1
8537           num_cont_hb(ii)=nnn
8538           jcont_hb(nnn,ii)=jj
8539           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8540           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8541           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8542           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8543           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8544           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8545           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8546           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8547           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8548           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8549           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8550           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8551           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8552           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8553           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8554           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8555           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8556           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8557           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8558           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8559           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8560           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8561           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8562           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8563         enddo
8564       enddo
8565       call flush(iout)
8566       if (lprn) then
8567         write (iout,'(a)') 'Contact function values after receive:'
8568         do i=nnt,nct-2
8569           write (iout,'(2i3,50(1x,i3,f5.2))')
8570      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8571      &    j=1,num_cont_hb(i))
8572         enddo
8573         call flush(iout)
8574       endif
8575    30 continue
8576 #endif
8577       if (lprn) then
8578         write (iout,'(a)') 'Contact function values:'
8579         do i=nnt,nct-2
8580           write (iout,'(2i3,50(1x,i3,f5.2))')
8581      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8582      &    j=1,num_cont_hb(i))
8583         enddo
8584       endif
8585       ecorr=0.0D0
8586 C Remove the loop below after debugging !!!
8587       do i=nnt,nct
8588         do j=1,3
8589           gradcorr(j,i)=0.0D0
8590           gradxorr(j,i)=0.0D0
8591         enddo
8592       enddo
8593 C Calculate the local-electrostatic correlation terms
8594       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8595         i1=i+1
8596         num_conti=num_cont_hb(i)
8597         num_conti1=num_cont_hb(i+1)
8598         do jj=1,num_conti
8599           j=jcont_hb(jj,i)
8600           jp=iabs(j)
8601           do kk=1,num_conti1
8602             j1=jcont_hb(kk,i1)
8603             jp1=iabs(j1)
8604 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8605 c     &         ' jj=',jj,' kk=',kk
8606             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8607      &          .or. j.lt.0 .and. j1.gt.0) .and.
8608      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8609 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8610 C The system gains extra energy.
8611               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8612               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8613      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8614               n_corr=n_corr+1
8615             else if (j1.eq.j) then
8616 C Contacts I-J and I-(J+1) occur simultaneously.
8617 C The system loses extra energy.
8618 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8619             endif
8620           enddo ! kk
8621           do kk=1,num_conti
8622             j1=jcont_hb(kk,i)
8623 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8624 c    &         ' jj=',jj,' kk=',kk
8625             if (j1.eq.j+1) then
8626 C Contacts I-J and (I+1)-J occur simultaneously.
8627 C The system loses extra energy.
8628 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8629             endif ! j1==j+1
8630           enddo ! kk
8631         enddo ! jj
8632       enddo ! i
8633       return
8634       end
8635 c------------------------------------------------------------------------------
8636       subroutine add_hb_contact(ii,jj,itask)
8637       implicit real*8 (a-h,o-z)
8638       include "DIMENSIONS"
8639       include "COMMON.IOUNITS"
8640       integer max_cont
8641       integer max_dim
8642       parameter (max_cont=maxconts)
8643       parameter (max_dim=26)
8644       include "COMMON.CONTACTS"
8645       double precision zapas(max_dim,maxconts,max_fg_procs),
8646      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8647       common /przechowalnia/ zapas
8648       integer i,j,ii,jj,iproc,itask(4),nn
8649 c      write (iout,*) "itask",itask
8650       do i=1,2
8651         iproc=itask(i)
8652         if (iproc.gt.0) then
8653           do j=1,num_cont_hb(ii)
8654             jjc=jcont_hb(j,ii)
8655 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8656             if (jjc.eq.jj) then
8657               ncont_sent(iproc)=ncont_sent(iproc)+1
8658               nn=ncont_sent(iproc)
8659               zapas(1,nn,iproc)=ii
8660               zapas(2,nn,iproc)=jjc
8661               zapas(3,nn,iproc)=facont_hb(j,ii)
8662               zapas(4,nn,iproc)=ees0p(j,ii)
8663               zapas(5,nn,iproc)=ees0m(j,ii)
8664               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8665               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8666               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8667               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8668               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8669               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8670               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8671               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8672               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8673               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8674               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8675               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8676               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8677               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8678               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8679               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8680               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8681               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8682               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8683               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8684               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8685               exit
8686             endif
8687           enddo
8688         endif
8689       enddo
8690       return
8691       end
8692 c------------------------------------------------------------------------------
8693       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8694      &  n_corr1)
8695 C This subroutine calculates multi-body contributions to hydrogen-bonding
8696       implicit real*8 (a-h,o-z)
8697       include 'DIMENSIONS'
8698       include 'COMMON.IOUNITS'
8699 #ifdef MPI
8700       include "mpif.h"
8701       parameter (max_cont=maxconts)
8702       parameter (max_dim=70)
8703       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8704       double precision zapas(max_dim,maxconts,max_fg_procs),
8705      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8706       common /przechowalnia/ zapas
8707       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8708      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8709 #endif
8710       include 'COMMON.SETUP'
8711       include 'COMMON.FFIELD'
8712       include 'COMMON.DERIV'
8713       include 'COMMON.LOCAL'
8714       include 'COMMON.INTERACT'
8715       include 'COMMON.CONTACTS'
8716       include 'COMMON.CHAIN'
8717       include 'COMMON.CONTROL'
8718       include 'COMMON.SHIELD'
8719       double precision gx(3),gx1(3)
8720       integer num_cont_hb_old(maxres)
8721       logical lprn,ldone
8722       double precision eello4,eello5,eelo6,eello_turn6
8723       external eello4,eello5,eello6,eello_turn6
8724 C Set lprn=.true. for debugging
8725       lprn=.false.
8726       eturn6=0.0d0
8727 #ifdef MPI
8728       do i=1,nres
8729         num_cont_hb_old(i)=num_cont_hb(i)
8730       enddo
8731       n_corr=0
8732       n_corr1=0
8733       if (nfgtasks.le.1) goto 30
8734       if (lprn) then
8735         write (iout,'(a)') 'Contact function values before RECEIVE:'
8736         do i=nnt,nct-2
8737           write (iout,'(2i3,50(1x,i2,f5.2))')
8738      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8739      &    j=1,num_cont_hb(i))
8740         enddo
8741       endif
8742       call flush(iout)
8743       do i=1,ntask_cont_from
8744         ncont_recv(i)=0
8745       enddo
8746       do i=1,ntask_cont_to
8747         ncont_sent(i)=0
8748       enddo
8749 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8750 c     & ntask_cont_to
8751 C Make the list of contacts to send to send to other procesors
8752       do i=iturn3_start,iturn3_end
8753 c        write (iout,*) "make contact list turn3",i," num_cont",
8754 c     &    num_cont_hb(i)
8755         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8756       enddo
8757       do i=iturn4_start,iturn4_end
8758 c        write (iout,*) "make contact list turn4",i," num_cont",
8759 c     &   num_cont_hb(i)
8760         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8761       enddo
8762       do ii=1,nat_sent
8763         i=iat_sent(ii)
8764 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8765 c     &    num_cont_hb(i)
8766         do j=1,num_cont_hb(i)
8767         do k=1,4
8768           jjc=jcont_hb(j,i)
8769           iproc=iint_sent_local(k,jjc,ii)
8770 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8771           if (iproc.ne.0) then
8772             ncont_sent(iproc)=ncont_sent(iproc)+1
8773             nn=ncont_sent(iproc)
8774             zapas(1,nn,iproc)=i
8775             zapas(2,nn,iproc)=jjc
8776             zapas(3,nn,iproc)=d_cont(j,i)
8777             ind=3
8778             do kk=1,3
8779               ind=ind+1
8780               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8781             enddo
8782             do kk=1,2
8783               do ll=1,2
8784                 ind=ind+1
8785                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8786               enddo
8787             enddo
8788             do jj=1,5
8789               do kk=1,3
8790                 do ll=1,2
8791                   do mm=1,2
8792                     ind=ind+1
8793                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8794                   enddo
8795                 enddo
8796               enddo
8797             enddo
8798           endif
8799         enddo
8800         enddo
8801       enddo
8802       if (lprn) then
8803       write (iout,*)
8804      &  "Numbers of contacts to be sent to other processors",
8805      &  (ncont_sent(i),i=1,ntask_cont_to)
8806       write (iout,*) "Contacts sent"
8807       do ii=1,ntask_cont_to
8808         nn=ncont_sent(ii)
8809         iproc=itask_cont_to(ii)
8810         write (iout,*) nn," contacts to processor",iproc,
8811      &   " of CONT_TO_COMM group"
8812         do i=1,nn
8813           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8814         enddo
8815       enddo
8816       call flush(iout)
8817       endif
8818       CorrelType=477
8819       CorrelID=fg_rank+1
8820       CorrelType1=478
8821       CorrelID1=nfgtasks+fg_rank+1
8822       ireq=0
8823 C Receive the numbers of needed contacts from other processors
8824       do ii=1,ntask_cont_from
8825         iproc=itask_cont_from(ii)
8826         ireq=ireq+1
8827         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8828      &    FG_COMM,req(ireq),IERR)
8829       enddo
8830 c      write (iout,*) "IRECV ended"
8831 c      call flush(iout)
8832 C Send the number of contacts needed by other processors
8833       do ii=1,ntask_cont_to
8834         iproc=itask_cont_to(ii)
8835         ireq=ireq+1
8836         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8837      &    FG_COMM,req(ireq),IERR)
8838       enddo
8839 c      write (iout,*) "ISEND ended"
8840 c      write (iout,*) "number of requests (nn)",ireq
8841       call flush(iout)
8842       if (ireq.gt.0)
8843      &  call MPI_Waitall(ireq,req,status_array,ierr)
8844 c      write (iout,*)
8845 c     &  "Numbers of contacts to be received from other processors",
8846 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8847 c      call flush(iout)
8848 C Receive contacts
8849       ireq=0
8850       do ii=1,ntask_cont_from
8851         iproc=itask_cont_from(ii)
8852         nn=ncont_recv(ii)
8853 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8854 c     &   " of CONT_TO_COMM group"
8855         call flush(iout)
8856         if (nn.gt.0) then
8857           ireq=ireq+1
8858           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8859      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8860 c          write (iout,*) "ireq,req",ireq,req(ireq)
8861         endif
8862       enddo
8863 C Send the contacts to processors that need them
8864       do ii=1,ntask_cont_to
8865         iproc=itask_cont_to(ii)
8866         nn=ncont_sent(ii)
8867 c        write (iout,*) nn," contacts to processor",iproc,
8868 c     &   " of CONT_TO_COMM group"
8869         if (nn.gt.0) then
8870           ireq=ireq+1
8871           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8872      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8873 c          write (iout,*) "ireq,req",ireq,req(ireq)
8874 c          do i=1,nn
8875 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8876 c          enddo
8877         endif
8878       enddo
8879 c      write (iout,*) "number of requests (contacts)",ireq
8880 c      write (iout,*) "req",(req(i),i=1,4)
8881 c      call flush(iout)
8882       if (ireq.gt.0)
8883      & call MPI_Waitall(ireq,req,status_array,ierr)
8884       do iii=1,ntask_cont_from
8885         iproc=itask_cont_from(iii)
8886         nn=ncont_recv(iii)
8887         if (lprn) then
8888         write (iout,*) "Received",nn," contacts from processor",iproc,
8889      &   " of CONT_FROM_COMM group"
8890         call flush(iout)
8891         do i=1,nn
8892           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8893         enddo
8894         call flush(iout)
8895         endif
8896         do i=1,nn
8897           ii=zapas_recv(1,i,iii)
8898 c Flag the received contacts to prevent double-counting
8899           jj=-zapas_recv(2,i,iii)
8900 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8901 c          call flush(iout)
8902           nnn=num_cont_hb(ii)+1
8903           num_cont_hb(ii)=nnn
8904           jcont_hb(nnn,ii)=jj
8905           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8906           ind=3
8907           do kk=1,3
8908             ind=ind+1
8909             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8910           enddo
8911           do kk=1,2
8912             do ll=1,2
8913               ind=ind+1
8914               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8915             enddo
8916           enddo
8917           do jj=1,5
8918             do kk=1,3
8919               do ll=1,2
8920                 do mm=1,2
8921                   ind=ind+1
8922                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8923                 enddo
8924               enddo
8925             enddo
8926           enddo
8927         enddo
8928       enddo
8929       call flush(iout)
8930       if (lprn) then
8931         write (iout,'(a)') 'Contact function values after receive:'
8932         do i=nnt,nct-2
8933           write (iout,'(2i3,50(1x,i3,5f6.3))')
8934      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8935      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8936         enddo
8937         call flush(iout)
8938       endif
8939    30 continue
8940 #endif
8941       if (lprn) then
8942         write (iout,'(a)') 'Contact function values:'
8943         do i=nnt,nct-2
8944           write (iout,'(2i3,50(1x,i2,5f6.3))')
8945      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8946      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8947         enddo
8948       endif
8949       ecorr=0.0D0
8950       ecorr5=0.0d0
8951       ecorr6=0.0d0
8952 C Remove the loop below after debugging !!!
8953       do i=nnt,nct
8954         do j=1,3
8955           gradcorr(j,i)=0.0D0
8956           gradxorr(j,i)=0.0D0
8957         enddo
8958       enddo
8959 C Calculate the dipole-dipole interaction energies
8960       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8961       do i=iatel_s,iatel_e+1
8962         num_conti=num_cont_hb(i)
8963         do jj=1,num_conti
8964           j=jcont_hb(jj,i)
8965 #ifdef MOMENT
8966           call dipole(i,j,jj)
8967 #endif
8968         enddo
8969       enddo
8970       endif
8971 C Calculate the local-electrostatic correlation terms
8972 c                write (iout,*) "gradcorr5 in eello5 before loop"
8973 c                do iii=1,nres
8974 c                  write (iout,'(i5,3f10.5)')
8975 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8976 c                enddo
8977       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8978 c        write (iout,*) "corr loop i",i
8979         i1=i+1
8980         num_conti=num_cont_hb(i)
8981         num_conti1=num_cont_hb(i+1)
8982         do jj=1,num_conti
8983           j=jcont_hb(jj,i)
8984           jp=iabs(j)
8985           do kk=1,num_conti1
8986             j1=jcont_hb(kk,i1)
8987             jp1=iabs(j1)
8988 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8989 c     &         ' jj=',jj,' kk=',kk
8990 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8991             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8992      &          .or. j.lt.0 .and. j1.gt.0) .and.
8993      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8994 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8995 C The system gains extra energy.
8996               n_corr=n_corr+1
8997               sqd1=dsqrt(d_cont(jj,i))
8998               sqd2=dsqrt(d_cont(kk,i1))
8999               sred_geom = sqd1*sqd2
9000               IF (sred_geom.lt.cutoff_corr) THEN
9001                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9002      &            ekont,fprimcont)
9003 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9004 cd     &         ' jj=',jj,' kk=',kk
9005                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9006                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9007                 do l=1,3
9008                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9009                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9010                 enddo
9011                 n_corr1=n_corr1+1
9012 cd               write (iout,*) 'sred_geom=',sred_geom,
9013 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9014 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9015 cd               write (iout,*) "g_contij",g_contij
9016 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9017 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9018                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9019                 if (wcorr4.gt.0.0d0)
9020      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9021 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9022                   if (energy_dec.and.wcorr4.gt.0.0d0)
9023      1                 write (iout,'(a6,4i5,0pf7.3)')
9024      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9025 c                write (iout,*) "gradcorr5 before eello5"
9026 c                do iii=1,nres
9027 c                  write (iout,'(i5,3f10.5)')
9028 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9029 c                enddo
9030                 if (wcorr5.gt.0.0d0)
9031      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9032 c                write (iout,*) "gradcorr5 after eello5"
9033 c                do iii=1,nres
9034 c                  write (iout,'(i5,3f10.5)')
9035 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9036 c                enddo
9037                   if (energy_dec.and.wcorr5.gt.0.0d0)
9038      1                 write (iout,'(a6,4i5,0pf7.3)')
9039      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9040 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9041 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9042                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9043      &               .or. wturn6.eq.0.0d0))then
9044 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9045                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9046                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9047      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9048 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9049 cd     &            'ecorr6=',ecorr6
9050 cd                write (iout,'(4e15.5)') sred_geom,
9051 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9052 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9053 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9054                 else if (wturn6.gt.0.0d0
9055      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9056 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9057                   eturn6=eturn6+eello_turn6(i,jj,kk)
9058                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9059      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9060 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9061                 endif
9062               ENDIF
9063 1111          continue
9064             endif
9065           enddo ! kk
9066         enddo ! jj
9067       enddo ! i
9068       do i=1,nres
9069         num_cont_hb(i)=num_cont_hb_old(i)
9070       enddo
9071 c                write (iout,*) "gradcorr5 in eello5"
9072 c                do iii=1,nres
9073 c                  write (iout,'(i5,3f10.5)')
9074 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9075 c                enddo
9076       return
9077       end
9078 c------------------------------------------------------------------------------
9079       subroutine add_hb_contact_eello(ii,jj,itask)
9080       implicit real*8 (a-h,o-z)
9081       include "DIMENSIONS"
9082       include "COMMON.IOUNITS"
9083       integer max_cont
9084       integer max_dim
9085       parameter (max_cont=maxconts)
9086       parameter (max_dim=70)
9087       include "COMMON.CONTACTS"
9088       double precision zapas(max_dim,maxconts,max_fg_procs),
9089      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9090       common /przechowalnia/ zapas
9091       integer i,j,ii,jj,iproc,itask(4),nn
9092 c      write (iout,*) "itask",itask
9093       do i=1,2
9094         iproc=itask(i)
9095         if (iproc.gt.0) then
9096           do j=1,num_cont_hb(ii)
9097             jjc=jcont_hb(j,ii)
9098 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9099             if (jjc.eq.jj) then
9100               ncont_sent(iproc)=ncont_sent(iproc)+1
9101               nn=ncont_sent(iproc)
9102               zapas(1,nn,iproc)=ii
9103               zapas(2,nn,iproc)=jjc
9104               zapas(3,nn,iproc)=d_cont(j,ii)
9105               ind=3
9106               do kk=1,3
9107                 ind=ind+1
9108                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9109               enddo
9110               do kk=1,2
9111                 do ll=1,2
9112                   ind=ind+1
9113                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9114                 enddo
9115               enddo
9116               do jj=1,5
9117                 do kk=1,3
9118                   do ll=1,2
9119                     do mm=1,2
9120                       ind=ind+1
9121                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9122                     enddo
9123                   enddo
9124                 enddo
9125               enddo
9126               exit
9127             endif
9128           enddo
9129         endif
9130       enddo
9131       return
9132       end
9133 c------------------------------------------------------------------------------
9134       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9135       implicit real*8 (a-h,o-z)
9136       include 'DIMENSIONS'
9137       include 'COMMON.IOUNITS'
9138       include 'COMMON.DERIV'
9139       include 'COMMON.INTERACT'
9140       include 'COMMON.CONTACTS'
9141       include 'COMMON.SHIELD'
9142       include 'COMMON.CONTROL'
9143       double precision gx(3),gx1(3)
9144       logical lprn
9145       lprn=.false.
9146 C      print *,"wchodze",fac_shield(i),shield_mode
9147       eij=facont_hb(jj,i)
9148       ekl=facont_hb(kk,k)
9149       ees0pij=ees0p(jj,i)
9150       ees0pkl=ees0p(kk,k)
9151       ees0mij=ees0m(jj,i)
9152       ees0mkl=ees0m(kk,k)
9153       ekont=eij*ekl
9154       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9155 C*
9156 C     & fac_shield(i)**2*fac_shield(j)**2
9157 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9158 C Following 4 lines for diagnostics.
9159 cd    ees0pkl=0.0D0
9160 cd    ees0pij=1.0D0
9161 cd    ees0mkl=0.0D0
9162 cd    ees0mij=1.0D0
9163 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9164 c     & 'Contacts ',i,j,
9165 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9166 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9167 c     & 'gradcorr_long'
9168 C Calculate the multi-body contribution to energy.
9169 C      ecorr=ecorr+ekont*ees
9170 C Calculate multi-body contributions to the gradient.
9171       coeffpees0pij=coeffp*ees0pij
9172       coeffmees0mij=coeffm*ees0mij
9173       coeffpees0pkl=coeffp*ees0pkl
9174       coeffmees0mkl=coeffm*ees0mkl
9175       do ll=1,3
9176 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9177         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9178      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9179      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9180         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9181      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9182      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9183 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9184         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9185      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9186      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9187         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9188      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9189      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9190         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9191      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9192      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9193         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9194         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9195         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9196      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9197      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9198         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9199         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9200 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9201       enddo
9202 c      write (iout,*)
9203 cgrad      do m=i+1,j-1
9204 cgrad        do ll=1,3
9205 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9206 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9207 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9208 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9209 cgrad        enddo
9210 cgrad      enddo
9211 cgrad      do m=k+1,l-1
9212 cgrad        do ll=1,3
9213 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9214 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9215 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9216 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9217 cgrad        enddo
9218 cgrad      enddo
9219 c      write (iout,*) "ehbcorr",ekont*ees
9220 C      print *,ekont,ees,i,k
9221       ehbcorr=ekont*ees
9222 C now gradient over shielding
9223 C      return
9224       if (shield_mode.gt.0) then
9225        j=ees0plist(jj,i)
9226        l=ees0plist(kk,k)
9227 C        print *,i,j,fac_shield(i),fac_shield(j),
9228 C     &fac_shield(k),fac_shield(l)
9229         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9230      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9231           do ilist=1,ishield_list(i)
9232            iresshield=shield_list(ilist,i)
9233            do m=1,3
9234            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9235 C     &      *2.0
9236            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9237      &              rlocshield
9238      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9239             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9240      &+rlocshield
9241            enddo
9242           enddo
9243           do ilist=1,ishield_list(j)
9244            iresshield=shield_list(ilist,j)
9245            do m=1,3
9246            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9247 C     &     *2.0
9248            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9249      &              rlocshield
9250      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9251            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9252      &     +rlocshield
9253            enddo
9254           enddo
9255
9256           do ilist=1,ishield_list(k)
9257            iresshield=shield_list(ilist,k)
9258            do m=1,3
9259            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9260 C     &     *2.0
9261            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9262      &              rlocshield
9263      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9264            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9265      &     +rlocshield
9266            enddo
9267           enddo
9268           do ilist=1,ishield_list(l)
9269            iresshield=shield_list(ilist,l)
9270            do m=1,3
9271            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9272 C     &     *2.0
9273            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9274      &              rlocshield
9275      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9276            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9277      &     +rlocshield
9278            enddo
9279           enddo
9280 C          print *,gshieldx(m,iresshield)
9281           do m=1,3
9282             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9283      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9284             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9285      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9286             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9287      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9288             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9289      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9290
9291             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9292      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9293             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9294      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9295             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9296      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9297             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9298      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9299
9300            enddo
9301       endif
9302       endif
9303       return
9304       end
9305 #ifdef MOMENT
9306 C---------------------------------------------------------------------------
9307       subroutine dipole(i,j,jj)
9308       implicit real*8 (a-h,o-z)
9309       include 'DIMENSIONS'
9310       include 'COMMON.IOUNITS'
9311       include 'COMMON.CHAIN'
9312       include 'COMMON.FFIELD'
9313       include 'COMMON.DERIV'
9314       include 'COMMON.INTERACT'
9315       include 'COMMON.CONTACTS'
9316       include 'COMMON.TORSION'
9317       include 'COMMON.VAR'
9318       include 'COMMON.GEO'
9319       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9320      &  auxmat(2,2)
9321       iti1 = itortyp(itype(i+1))
9322       if (j.lt.nres-1) then
9323         itj1 = itype2loc(itype(j+1))
9324       else
9325         itj1=nloctyp
9326       endif
9327       do iii=1,2
9328         dipi(iii,1)=Ub2(iii,i)
9329         dipderi(iii)=Ub2der(iii,i)
9330         dipi(iii,2)=b1(iii,i+1)
9331         dipj(iii,1)=Ub2(iii,j)
9332         dipderj(iii)=Ub2der(iii,j)
9333         dipj(iii,2)=b1(iii,j+1)
9334       enddo
9335       kkk=0
9336       do iii=1,2
9337         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9338         do jjj=1,2
9339           kkk=kkk+1
9340           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9341         enddo
9342       enddo
9343       do kkk=1,5
9344         do lll=1,3
9345           mmm=0
9346           do iii=1,2
9347             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9348      &        auxvec(1))
9349             do jjj=1,2
9350               mmm=mmm+1
9351               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9352             enddo
9353           enddo
9354         enddo
9355       enddo
9356       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9357       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9358       do iii=1,2
9359         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9360       enddo
9361       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9362       do iii=1,2
9363         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9364       enddo
9365       return
9366       end
9367 #endif
9368 C---------------------------------------------------------------------------
9369       subroutine calc_eello(i,j,k,l,jj,kk)
9370 C
9371 C This subroutine computes matrices and vectors needed to calculate
9372 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9373 C
9374       implicit real*8 (a-h,o-z)
9375       include 'DIMENSIONS'
9376       include 'COMMON.IOUNITS'
9377       include 'COMMON.CHAIN'
9378       include 'COMMON.DERIV'
9379       include 'COMMON.INTERACT'
9380       include 'COMMON.CONTACTS'
9381       include 'COMMON.TORSION'
9382       include 'COMMON.VAR'
9383       include 'COMMON.GEO'
9384       include 'COMMON.FFIELD'
9385       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9386      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9387       logical lprn
9388       common /kutas/ lprn
9389 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9390 cd     & ' jj=',jj,' kk=',kk
9391 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9392 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9393 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9394       do iii=1,2
9395         do jjj=1,2
9396           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9397           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9398         enddo
9399       enddo
9400       call transpose2(aa1(1,1),aa1t(1,1))
9401       call transpose2(aa2(1,1),aa2t(1,1))
9402       do kkk=1,5
9403         do lll=1,3
9404           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9405      &      aa1tder(1,1,lll,kkk))
9406           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9407      &      aa2tder(1,1,lll,kkk))
9408         enddo
9409       enddo
9410       if (l.eq.j+1) then
9411 C parallel orientation of the two CA-CA-CA frames.
9412         if (i.gt.1) then
9413           iti=itype2loc(itype(i))
9414         else
9415           iti=nloctyp
9416         endif
9417         itk1=itype2loc(itype(k+1))
9418         itj=itype2loc(itype(j))
9419         if (l.lt.nres-1) then
9420           itl1=itype2loc(itype(l+1))
9421         else
9422           itl1=nloctyp
9423         endif
9424 C A1 kernel(j+1) A2T
9425 cd        do iii=1,2
9426 cd          write (iout,'(3f10.5,5x,3f10.5)')
9427 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9428 cd        enddo
9429         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9430      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9431      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9432 C Following matrices are needed only for 6-th order cumulants
9433         IF (wcorr6.gt.0.0d0) THEN
9434         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9435      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9436      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9437         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9438      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9439      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9440      &   ADtEAderx(1,1,1,1,1,1))
9441         lprn=.false.
9442         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9443      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9444      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9445      &   ADtEA1derx(1,1,1,1,1,1))
9446         ENDIF
9447 C End 6-th order cumulants
9448 cd        lprn=.false.
9449 cd        if (lprn) then
9450 cd        write (2,*) 'In calc_eello6'
9451 cd        do iii=1,2
9452 cd          write (2,*) 'iii=',iii
9453 cd          do kkk=1,5
9454 cd            write (2,*) 'kkk=',kkk
9455 cd            do jjj=1,2
9456 cd              write (2,'(3(2f10.5),5x)')
9457 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9458 cd            enddo
9459 cd          enddo
9460 cd        enddo
9461 cd        endif
9462         call transpose2(EUgder(1,1,k),auxmat(1,1))
9463         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9464         call transpose2(EUg(1,1,k),auxmat(1,1))
9465         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9466         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9467         do iii=1,2
9468           do kkk=1,5
9469             do lll=1,3
9470               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9471      &          EAEAderx(1,1,lll,kkk,iii,1))
9472             enddo
9473           enddo
9474         enddo
9475 C A1T kernel(i+1) A2
9476         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9477      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9478      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9479 C Following matrices are needed only for 6-th order cumulants
9480         IF (wcorr6.gt.0.0d0) THEN
9481         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9482      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9483      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9484         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9485      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9486      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9487      &   ADtEAderx(1,1,1,1,1,2))
9488         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9489      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9490      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9491      &   ADtEA1derx(1,1,1,1,1,2))
9492         ENDIF
9493 C End 6-th order cumulants
9494         call transpose2(EUgder(1,1,l),auxmat(1,1))
9495         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9496         call transpose2(EUg(1,1,l),auxmat(1,1))
9497         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9498         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9499         do iii=1,2
9500           do kkk=1,5
9501             do lll=1,3
9502               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9503      &          EAEAderx(1,1,lll,kkk,iii,2))
9504             enddo
9505           enddo
9506         enddo
9507 C AEAb1 and AEAb2
9508 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9509 C They are needed only when the fifth- or the sixth-order cumulants are
9510 C indluded.
9511         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9512         call transpose2(AEA(1,1,1),auxmat(1,1))
9513         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9514         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9515         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9516         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9517         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9518         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9519         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9520         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9521         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9522         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9523         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9524         call transpose2(AEA(1,1,2),auxmat(1,1))
9525         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9526         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9527         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9528         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9529         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9530         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9531         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9532         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9533         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9534         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9535         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9536 C Calculate the Cartesian derivatives of the vectors.
9537         do iii=1,2
9538           do kkk=1,5
9539             do lll=1,3
9540               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9541               call matvec2(auxmat(1,1),b1(1,i),
9542      &          AEAb1derx(1,lll,kkk,iii,1,1))
9543               call matvec2(auxmat(1,1),Ub2(1,i),
9544      &          AEAb2derx(1,lll,kkk,iii,1,1))
9545               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9546      &          AEAb1derx(1,lll,kkk,iii,2,1))
9547               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9548      &          AEAb2derx(1,lll,kkk,iii,2,1))
9549               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9550               call matvec2(auxmat(1,1),b1(1,j),
9551      &          AEAb1derx(1,lll,kkk,iii,1,2))
9552               call matvec2(auxmat(1,1),Ub2(1,j),
9553      &          AEAb2derx(1,lll,kkk,iii,1,2))
9554               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9555      &          AEAb1derx(1,lll,kkk,iii,2,2))
9556               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9557      &          AEAb2derx(1,lll,kkk,iii,2,2))
9558             enddo
9559           enddo
9560         enddo
9561         ENDIF
9562 C End vectors
9563       else
9564 C Antiparallel orientation of the two CA-CA-CA frames.
9565         if (i.gt.1) then
9566           iti=itype2loc(itype(i))
9567         else
9568           iti=nloctyp
9569         endif
9570         itk1=itype2loc(itype(k+1))
9571         itl=itype2loc(itype(l))
9572         itj=itype2loc(itype(j))
9573         if (j.lt.nres-1) then
9574           itj1=itype2loc(itype(j+1))
9575         else
9576           itj1=nloctyp
9577         endif
9578 C A2 kernel(j-1)T A1T
9579         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9580      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9581      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9582 C Following matrices are needed only for 6-th order cumulants
9583         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9584      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9585         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9586      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9587      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9588         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9589      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9590      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9591      &   ADtEAderx(1,1,1,1,1,1))
9592         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9593      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9594      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9595      &   ADtEA1derx(1,1,1,1,1,1))
9596         ENDIF
9597 C End 6-th order cumulants
9598         call transpose2(EUgder(1,1,k),auxmat(1,1))
9599         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9600         call transpose2(EUg(1,1,k),auxmat(1,1))
9601         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9602         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9603         do iii=1,2
9604           do kkk=1,5
9605             do lll=1,3
9606               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9607      &          EAEAderx(1,1,lll,kkk,iii,1))
9608             enddo
9609           enddo
9610         enddo
9611 C A2T kernel(i+1)T A1
9612         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9613      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9614      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9615 C Following matrices are needed only for 6-th order cumulants
9616         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9617      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9618         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9619      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9620      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9621         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9622      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9623      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9624      &   ADtEAderx(1,1,1,1,1,2))
9625         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9626      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9627      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9628      &   ADtEA1derx(1,1,1,1,1,2))
9629         ENDIF
9630 C End 6-th order cumulants
9631         call transpose2(EUgder(1,1,j),auxmat(1,1))
9632         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9633         call transpose2(EUg(1,1,j),auxmat(1,1))
9634         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9635         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9636         do iii=1,2
9637           do kkk=1,5
9638             do lll=1,3
9639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9640      &          EAEAderx(1,1,lll,kkk,iii,2))
9641             enddo
9642           enddo
9643         enddo
9644 C AEAb1 and AEAb2
9645 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9646 C They are needed only when the fifth- or the sixth-order cumulants are
9647 C indluded.
9648         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9649      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9650         call transpose2(AEA(1,1,1),auxmat(1,1))
9651         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9652         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9653         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9654         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9655         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9656         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9657         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9658         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9659         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9660         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9661         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9662         call transpose2(AEA(1,1,2),auxmat(1,1))
9663         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9664         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9665         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9666         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9667         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9668         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9669         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9670         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9671         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9672         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9673         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9674 C Calculate the Cartesian derivatives of the vectors.
9675         do iii=1,2
9676           do kkk=1,5
9677             do lll=1,3
9678               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9679               call matvec2(auxmat(1,1),b1(1,i),
9680      &          AEAb1derx(1,lll,kkk,iii,1,1))
9681               call matvec2(auxmat(1,1),Ub2(1,i),
9682      &          AEAb2derx(1,lll,kkk,iii,1,1))
9683               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9684      &          AEAb1derx(1,lll,kkk,iii,2,1))
9685               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9686      &          AEAb2derx(1,lll,kkk,iii,2,1))
9687               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9688               call matvec2(auxmat(1,1),b1(1,l),
9689      &          AEAb1derx(1,lll,kkk,iii,1,2))
9690               call matvec2(auxmat(1,1),Ub2(1,l),
9691      &          AEAb2derx(1,lll,kkk,iii,1,2))
9692               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9693      &          AEAb1derx(1,lll,kkk,iii,2,2))
9694               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9695      &          AEAb2derx(1,lll,kkk,iii,2,2))
9696             enddo
9697           enddo
9698         enddo
9699         ENDIF
9700 C End vectors
9701       endif
9702       return
9703       end
9704 C---------------------------------------------------------------------------
9705       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9706      &  KK,KKderg,AKA,AKAderg,AKAderx)
9707       implicit none
9708       integer nderg
9709       logical transp
9710       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9711      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9712      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9713       integer iii,kkk,lll
9714       integer jjj,mmm
9715       logical lprn
9716       common /kutas/ lprn
9717       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9718       do iii=1,nderg
9719         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9720      &    AKAderg(1,1,iii))
9721       enddo
9722 cd      if (lprn) write (2,*) 'In kernel'
9723       do kkk=1,5
9724 cd        if (lprn) write (2,*) 'kkk=',kkk
9725         do lll=1,3
9726           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9727      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9728 cd          if (lprn) then
9729 cd            write (2,*) 'lll=',lll
9730 cd            write (2,*) 'iii=1'
9731 cd            do jjj=1,2
9732 cd              write (2,'(3(2f10.5),5x)')
9733 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9734 cd            enddo
9735 cd          endif
9736           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9737      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9738 cd          if (lprn) then
9739 cd            write (2,*) 'lll=',lll
9740 cd            write (2,*) 'iii=2'
9741 cd            do jjj=1,2
9742 cd              write (2,'(3(2f10.5),5x)')
9743 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9744 cd            enddo
9745 cd          endif
9746         enddo
9747       enddo
9748       return
9749       end
9750 C---------------------------------------------------------------------------
9751       double precision function eello4(i,j,k,l,jj,kk)
9752       implicit real*8 (a-h,o-z)
9753       include 'DIMENSIONS'
9754       include 'COMMON.IOUNITS'
9755       include 'COMMON.CHAIN'
9756       include 'COMMON.DERIV'
9757       include 'COMMON.INTERACT'
9758       include 'COMMON.CONTACTS'
9759       include 'COMMON.TORSION'
9760       include 'COMMON.VAR'
9761       include 'COMMON.GEO'
9762       double precision pizda(2,2),ggg1(3),ggg2(3)
9763 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9764 cd        eello4=0.0d0
9765 cd        return
9766 cd      endif
9767 cd      print *,'eello4:',i,j,k,l,jj,kk
9768 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9769 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9770 cold      eij=facont_hb(jj,i)
9771 cold      ekl=facont_hb(kk,k)
9772 cold      ekont=eij*ekl
9773       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9774 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9775       gcorr_loc(k-1)=gcorr_loc(k-1)
9776      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9777       if (l.eq.j+1) then
9778         gcorr_loc(l-1)=gcorr_loc(l-1)
9779      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9780       else
9781         gcorr_loc(j-1)=gcorr_loc(j-1)
9782      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9783       endif
9784       do iii=1,2
9785         do kkk=1,5
9786           do lll=1,3
9787             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9788      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9789 cd            derx(lll,kkk,iii)=0.0d0
9790           enddo
9791         enddo
9792       enddo
9793 cd      gcorr_loc(l-1)=0.0d0
9794 cd      gcorr_loc(j-1)=0.0d0
9795 cd      gcorr_loc(k-1)=0.0d0
9796 cd      eel4=1.0d0
9797 cd      write (iout,*)'Contacts have occurred for peptide groups',
9798 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9799 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9800       if (j.lt.nres-1) then
9801         j1=j+1
9802         j2=j-1
9803       else
9804         j1=j-1
9805         j2=j-2
9806       endif
9807       if (l.lt.nres-1) then
9808         l1=l+1
9809         l2=l-1
9810       else
9811         l1=l-1
9812         l2=l-2
9813       endif
9814       do ll=1,3
9815 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9816 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9817         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9818         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9819 cgrad        ghalf=0.5d0*ggg1(ll)
9820         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9821         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9822         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9823         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9824         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9825         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9826 cgrad        ghalf=0.5d0*ggg2(ll)
9827         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9828         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9829         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9830         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9831         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9832         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9833       enddo
9834 cgrad      do m=i+1,j-1
9835 cgrad        do ll=1,3
9836 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9837 cgrad        enddo
9838 cgrad      enddo
9839 cgrad      do m=k+1,l-1
9840 cgrad        do ll=1,3
9841 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9842 cgrad        enddo
9843 cgrad      enddo
9844 cgrad      do m=i+2,j2
9845 cgrad        do ll=1,3
9846 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9847 cgrad        enddo
9848 cgrad      enddo
9849 cgrad      do m=k+2,l2
9850 cgrad        do ll=1,3
9851 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9852 cgrad        enddo
9853 cgrad      enddo
9854 cd      do iii=1,nres-3
9855 cd        write (2,*) iii,gcorr_loc(iii)
9856 cd      enddo
9857       eello4=ekont*eel4
9858 cd      write (2,*) 'ekont',ekont
9859 cd      write (iout,*) 'eello4',ekont*eel4
9860       return
9861       end
9862 C---------------------------------------------------------------------------
9863       double precision function eello5(i,j,k,l,jj,kk)
9864       implicit real*8 (a-h,o-z)
9865       include 'DIMENSIONS'
9866       include 'COMMON.IOUNITS'
9867       include 'COMMON.CHAIN'
9868       include 'COMMON.DERIV'
9869       include 'COMMON.INTERACT'
9870       include 'COMMON.CONTACTS'
9871       include 'COMMON.TORSION'
9872       include 'COMMON.VAR'
9873       include 'COMMON.GEO'
9874       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9875       double precision ggg1(3),ggg2(3)
9876 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9877 C                                                                              C
9878 C                            Parallel chains                                   C
9879 C                                                                              C
9880 C          o             o                   o             o                   C
9881 C         /l\           / \             \   / \           / \   /              C
9882 C        /   \         /   \             \ /   \         /   \ /               C
9883 C       j| o |l1       | o |              o| o |         | o |o                C
9884 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9885 C      \i/   \         /   \ /             /   \         /   \                 C
9886 C       o    k1             o                                                  C
9887 C         (I)          (II)                (III)          (IV)                 C
9888 C                                                                              C
9889 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9890 C                                                                              C
9891 C                            Antiparallel chains                               C
9892 C                                                                              C
9893 C          o             o                   o             o                   C
9894 C         /j\           / \             \   / \           / \   /              C
9895 C        /   \         /   \             \ /   \         /   \ /               C
9896 C      j1| o |l        | o |              o| o |         | o |o                C
9897 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9898 C      \i/   \         /   \ /             /   \         /   \                 C
9899 C       o     k1            o                                                  C
9900 C         (I)          (II)                (III)          (IV)                 C
9901 C                                                                              C
9902 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9903 C                                                                              C
9904 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9905 C                                                                              C
9906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9907 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9908 cd        eello5=0.0d0
9909 cd        return
9910 cd      endif
9911 cd      write (iout,*)
9912 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9913 cd     &   ' and',k,l
9914       itk=itype2loc(itype(k))
9915       itl=itype2loc(itype(l))
9916       itj=itype2loc(itype(j))
9917       eello5_1=0.0d0
9918       eello5_2=0.0d0
9919       eello5_3=0.0d0
9920       eello5_4=0.0d0
9921 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9922 cd     &   eel5_3_num,eel5_4_num)
9923       do iii=1,2
9924         do kkk=1,5
9925           do lll=1,3
9926             derx(lll,kkk,iii)=0.0d0
9927           enddo
9928         enddo
9929       enddo
9930 cd      eij=facont_hb(jj,i)
9931 cd      ekl=facont_hb(kk,k)
9932 cd      ekont=eij*ekl
9933 cd      write (iout,*)'Contacts have occurred for peptide groups',
9934 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9935 cd      goto 1111
9936 C Contribution from the graph I.
9937 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9938 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9939       call transpose2(EUg(1,1,k),auxmat(1,1))
9940       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9941       vv(1)=pizda(1,1)-pizda(2,2)
9942       vv(2)=pizda(1,2)+pizda(2,1)
9943       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9944      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9945 C Explicit gradient in virtual-dihedral angles.
9946       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9947      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9948      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9949       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9950       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9951       vv(1)=pizda(1,1)-pizda(2,2)
9952       vv(2)=pizda(1,2)+pizda(2,1)
9953       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9954      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9955      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9956       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9957       vv(1)=pizda(1,1)-pizda(2,2)
9958       vv(2)=pizda(1,2)+pizda(2,1)
9959       if (l.eq.j+1) then
9960         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9961      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9962      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9963       else
9964         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9965      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9966      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9967       endif
9968 C Cartesian gradient
9969       do iii=1,2
9970         do kkk=1,5
9971           do lll=1,3
9972             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9973      &        pizda(1,1))
9974             vv(1)=pizda(1,1)-pizda(2,2)
9975             vv(2)=pizda(1,2)+pizda(2,1)
9976             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9977      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9978      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9979           enddo
9980         enddo
9981       enddo
9982 c      goto 1112
9983 c1111  continue
9984 C Contribution from graph II
9985       call transpose2(EE(1,1,k),auxmat(1,1))
9986       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9987       vv(1)=pizda(1,1)+pizda(2,2)
9988       vv(2)=pizda(2,1)-pizda(1,2)
9989       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9990      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9991 C Explicit gradient in virtual-dihedral angles.
9992       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9993      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9994       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9995       vv(1)=pizda(1,1)+pizda(2,2)
9996       vv(2)=pizda(2,1)-pizda(1,2)
9997       if (l.eq.j+1) then
9998         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9999      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10000      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10001       else
10002         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10003      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10004      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10005       endif
10006 C Cartesian gradient
10007       do iii=1,2
10008         do kkk=1,5
10009           do lll=1,3
10010             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10011      &        pizda(1,1))
10012             vv(1)=pizda(1,1)+pizda(2,2)
10013             vv(2)=pizda(2,1)-pizda(1,2)
10014             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10015      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10016      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10017           enddo
10018         enddo
10019       enddo
10020 cd      goto 1112
10021 cd1111  continue
10022       if (l.eq.j+1) then
10023 cd        goto 1110
10024 C Parallel orientation
10025 C Contribution from graph III
10026         call transpose2(EUg(1,1,l),auxmat(1,1))
10027         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10028         vv(1)=pizda(1,1)-pizda(2,2)
10029         vv(2)=pizda(1,2)+pizda(2,1)
10030         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10031      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10032 C Explicit gradient in virtual-dihedral angles.
10033         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10034      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10035      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10036         call matmat2(AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10040      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10041      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10042         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10043         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10044         vv(1)=pizda(1,1)-pizda(2,2)
10045         vv(2)=pizda(1,2)+pizda(2,1)
10046         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10047      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10048      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10049 C Cartesian gradient
10050         do iii=1,2
10051           do kkk=1,5
10052             do lll=1,3
10053               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10054      &          pizda(1,1))
10055               vv(1)=pizda(1,1)-pizda(2,2)
10056               vv(2)=pizda(1,2)+pizda(2,1)
10057               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10058      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10059      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10060             enddo
10061           enddo
10062         enddo
10063 cd        goto 1112
10064 C Contribution from graph IV
10065 cd1110    continue
10066         call transpose2(EE(1,1,l),auxmat(1,1))
10067         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10068         vv(1)=pizda(1,1)+pizda(2,2)
10069         vv(2)=pizda(2,1)-pizda(1,2)
10070         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10071      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10072 C Explicit gradient in virtual-dihedral angles.
10073         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10074      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10075         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10076         vv(1)=pizda(1,1)+pizda(2,2)
10077         vv(2)=pizda(2,1)-pizda(1,2)
10078         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10079      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10080      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10081 C Cartesian gradient
10082         do iii=1,2
10083           do kkk=1,5
10084             do lll=1,3
10085               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10086      &          pizda(1,1))
10087               vv(1)=pizda(1,1)+pizda(2,2)
10088               vv(2)=pizda(2,1)-pizda(1,2)
10089               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10090      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10091      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10092             enddo
10093           enddo
10094         enddo
10095       else
10096 C Antiparallel orientation
10097 C Contribution from graph III
10098 c        goto 1110
10099         call transpose2(EUg(1,1,j),auxmat(1,1))
10100         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10101         vv(1)=pizda(1,1)-pizda(2,2)
10102         vv(2)=pizda(1,2)+pizda(2,1)
10103         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10104      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10105 C Explicit gradient in virtual-dihedral angles.
10106         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10107      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10108      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10109         call matmat2(AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10113      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10114      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10115         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10116         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10117         vv(1)=pizda(1,1)-pizda(2,2)
10118         vv(2)=pizda(1,2)+pizda(2,1)
10119         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10120      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10121      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10122 C Cartesian gradient
10123         do iii=1,2
10124           do kkk=1,5
10125             do lll=1,3
10126               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10127      &          pizda(1,1))
10128               vv(1)=pizda(1,1)-pizda(2,2)
10129               vv(2)=pizda(1,2)+pizda(2,1)
10130               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10131      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10132      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10133             enddo
10134           enddo
10135         enddo
10136 cd        goto 1112
10137 C Contribution from graph IV
10138 1110    continue
10139         call transpose2(EE(1,1,j),auxmat(1,1))
10140         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10141         vv(1)=pizda(1,1)+pizda(2,2)
10142         vv(2)=pizda(2,1)-pizda(1,2)
10143         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10144      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10145 C Explicit gradient in virtual-dihedral angles.
10146         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10147      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10148         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10149         vv(1)=pizda(1,1)+pizda(2,2)
10150         vv(2)=pizda(2,1)-pizda(1,2)
10151         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10152      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10153      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10154 C Cartesian gradient
10155         do iii=1,2
10156           do kkk=1,5
10157             do lll=1,3
10158               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10159      &          pizda(1,1))
10160               vv(1)=pizda(1,1)+pizda(2,2)
10161               vv(2)=pizda(2,1)-pizda(1,2)
10162               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10163      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10164      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10165             enddo
10166           enddo
10167         enddo
10168       endif
10169 1112  continue
10170       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10171 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10172 cd        write (2,*) 'ijkl',i,j,k,l
10173 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10174 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10175 cd      endif
10176 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10177 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10178 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10179 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10180       if (j.lt.nres-1) then
10181         j1=j+1
10182         j2=j-1
10183       else
10184         j1=j-1
10185         j2=j-2
10186       endif
10187       if (l.lt.nres-1) then
10188         l1=l+1
10189         l2=l-1
10190       else
10191         l1=l-1
10192         l2=l-2
10193       endif
10194 cd      eij=1.0d0
10195 cd      ekl=1.0d0
10196 cd      ekont=1.0d0
10197 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10198 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10199 C        summed up outside the subrouine as for the other subroutines
10200 C        handling long-range interactions. The old code is commented out
10201 C        with "cgrad" to keep track of changes.
10202       do ll=1,3
10203 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10204 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10205         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10206         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10207 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10208 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10209 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10210 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10211 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10212 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10213 c     &   gradcorr5ij,
10214 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10215 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10216 cgrad        ghalf=0.5d0*ggg1(ll)
10217 cd        ghalf=0.0d0
10218         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10219         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10220         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10221         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10222         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10223         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10224 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10225 cgrad        ghalf=0.5d0*ggg2(ll)
10226 cd        ghalf=0.0d0
10227         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10228         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10229         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10230         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10231         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10232         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10233       enddo
10234 cd      goto 1112
10235 cgrad      do m=i+1,j-1
10236 cgrad        do ll=1,3
10237 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10238 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10239 cgrad        enddo
10240 cgrad      enddo
10241 cgrad      do m=k+1,l-1
10242 cgrad        do ll=1,3
10243 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10244 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10245 cgrad        enddo
10246 cgrad      enddo
10247 c1112  continue
10248 cgrad      do m=i+2,j2
10249 cgrad        do ll=1,3
10250 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10251 cgrad        enddo
10252 cgrad      enddo
10253 cgrad      do m=k+2,l2
10254 cgrad        do ll=1,3
10255 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10256 cgrad        enddo
10257 cgrad      enddo
10258 cd      do iii=1,nres-3
10259 cd        write (2,*) iii,g_corr5_loc(iii)
10260 cd      enddo
10261       eello5=ekont*eel5
10262 cd      write (2,*) 'ekont',ekont
10263 cd      write (iout,*) 'eello5',ekont*eel5
10264       return
10265       end
10266 c--------------------------------------------------------------------------
10267       double precision function eello6(i,j,k,l,jj,kk)
10268       implicit real*8 (a-h,o-z)
10269       include 'DIMENSIONS'
10270       include 'COMMON.IOUNITS'
10271       include 'COMMON.CHAIN'
10272       include 'COMMON.DERIV'
10273       include 'COMMON.INTERACT'
10274       include 'COMMON.CONTACTS'
10275       include 'COMMON.TORSION'
10276       include 'COMMON.VAR'
10277       include 'COMMON.GEO'
10278       include 'COMMON.FFIELD'
10279       double precision ggg1(3),ggg2(3)
10280 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10281 cd        eello6=0.0d0
10282 cd        return
10283 cd      endif
10284 cd      write (iout,*)
10285 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10286 cd     &   ' and',k,l
10287       eello6_1=0.0d0
10288       eello6_2=0.0d0
10289       eello6_3=0.0d0
10290       eello6_4=0.0d0
10291       eello6_5=0.0d0
10292       eello6_6=0.0d0
10293 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10294 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10295       do iii=1,2
10296         do kkk=1,5
10297           do lll=1,3
10298             derx(lll,kkk,iii)=0.0d0
10299           enddo
10300         enddo
10301       enddo
10302 cd      eij=facont_hb(jj,i)
10303 cd      ekl=facont_hb(kk,k)
10304 cd      ekont=eij*ekl
10305 cd      eij=1.0d0
10306 cd      ekl=1.0d0
10307 cd      ekont=1.0d0
10308       if (l.eq.j+1) then
10309         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10310         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10311         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10312         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10313         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10314         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10315       else
10316         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10317         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10318         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10319         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10320         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10321           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10322         else
10323           eello6_5=0.0d0
10324         endif
10325         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10326       endif
10327 C If turn contributions are considered, they will be handled separately.
10328       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10329 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10330 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10331 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10332 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10333 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10334 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10335 cd      goto 1112
10336       if (j.lt.nres-1) then
10337         j1=j+1
10338         j2=j-1
10339       else
10340         j1=j-1
10341         j2=j-2
10342       endif
10343       if (l.lt.nres-1) then
10344         l1=l+1
10345         l2=l-1
10346       else
10347         l1=l-1
10348         l2=l-2
10349       endif
10350       do ll=1,3
10351 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10352 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10353 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10354 cgrad        ghalf=0.5d0*ggg1(ll)
10355 cd        ghalf=0.0d0
10356         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10357         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10358         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10359         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10360         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10361         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10362         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10363         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10364 cgrad        ghalf=0.5d0*ggg2(ll)
10365 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10366 cd        ghalf=0.0d0
10367         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10368         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10369         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10370         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10371         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10372         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10373       enddo
10374 cd      goto 1112
10375 cgrad      do m=i+1,j-1
10376 cgrad        do ll=1,3
10377 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10378 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10379 cgrad        enddo
10380 cgrad      enddo
10381 cgrad      do m=k+1,l-1
10382 cgrad        do ll=1,3
10383 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10384 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10385 cgrad        enddo
10386 cgrad      enddo
10387 cgrad1112  continue
10388 cgrad      do m=i+2,j2
10389 cgrad        do ll=1,3
10390 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10391 cgrad        enddo
10392 cgrad      enddo
10393 cgrad      do m=k+2,l2
10394 cgrad        do ll=1,3
10395 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10396 cgrad        enddo
10397 cgrad      enddo
10398 cd      do iii=1,nres-3
10399 cd        write (2,*) iii,g_corr6_loc(iii)
10400 cd      enddo
10401       eello6=ekont*eel6
10402 cd      write (2,*) 'ekont',ekont
10403 cd      write (iout,*) 'eello6',ekont*eel6
10404       return
10405       end
10406 c--------------------------------------------------------------------------
10407       double precision function eello6_graph1(i,j,k,l,imat,swap)
10408       implicit real*8 (a-h,o-z)
10409       include 'DIMENSIONS'
10410       include 'COMMON.IOUNITS'
10411       include 'COMMON.CHAIN'
10412       include 'COMMON.DERIV'
10413       include 'COMMON.INTERACT'
10414       include 'COMMON.CONTACTS'
10415       include 'COMMON.TORSION'
10416       include 'COMMON.VAR'
10417       include 'COMMON.GEO'
10418       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10419       logical swap
10420       logical lprn
10421       common /kutas/ lprn
10422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10423 C                                                                              C
10424 C      Parallel       Antiparallel                                             C
10425 C                                                                              C
10426 C          o             o                                                     C
10427 C         /l\           /j\                                                    C
10428 C        /   \         /   \                                                   C
10429 C       /| o |         | o |\                                                  C
10430 C     \ j|/k\|  /   \  |/k\|l /                                                C
10431 C      \ /   \ /     \ /   \ /                                                 C
10432 C       o     o       o     o                                                  C
10433 C       i             i                                                        C
10434 C                                                                              C
10435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10436       itk=itype2loc(itype(k))
10437       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10438       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10439       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10440       call transpose2(EUgC(1,1,k),auxmat(1,1))
10441       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10442       vv1(1)=pizda1(1,1)-pizda1(2,2)
10443       vv1(2)=pizda1(1,2)+pizda1(2,1)
10444       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10445       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10446       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10447       s5=scalar2(vv(1),Dtobr2(1,i))
10448 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10449       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10450       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10451      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10452      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10453      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10454      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10455      & +scalar2(vv(1),Dtobr2der(1,i)))
10456       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10457       vv1(1)=pizda1(1,1)-pizda1(2,2)
10458       vv1(2)=pizda1(1,2)+pizda1(2,1)
10459       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10460       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10461       if (l.eq.j+1) then
10462         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10463      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10464      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10465      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10466      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10467       else
10468         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10469      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10470      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10471      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10472      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10473       endif
10474       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10475       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10476       vv1(1)=pizda1(1,1)-pizda1(2,2)
10477       vv1(2)=pizda1(1,2)+pizda1(2,1)
10478       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10479      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10480      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10481      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10482       do iii=1,2
10483         if (swap) then
10484           ind=3-iii
10485         else
10486           ind=iii
10487         endif
10488         do kkk=1,5
10489           do lll=1,3
10490             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10491             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10492             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10493             call transpose2(EUgC(1,1,k),auxmat(1,1))
10494             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10495      &        pizda1(1,1))
10496             vv1(1)=pizda1(1,1)-pizda1(2,2)
10497             vv1(2)=pizda1(1,2)+pizda1(2,1)
10498             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10499             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10500      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10501             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10502      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10503             s5=scalar2(vv(1),Dtobr2(1,i))
10504             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10505           enddo
10506         enddo
10507       enddo
10508       return
10509       end
10510 c----------------------------------------------------------------------------
10511       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10512       implicit real*8 (a-h,o-z)
10513       include 'DIMENSIONS'
10514       include 'COMMON.IOUNITS'
10515       include 'COMMON.CHAIN'
10516       include 'COMMON.DERIV'
10517       include 'COMMON.INTERACT'
10518       include 'COMMON.CONTACTS'
10519       include 'COMMON.TORSION'
10520       include 'COMMON.VAR'
10521       include 'COMMON.GEO'
10522       logical swap
10523       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10524      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10525       logical lprn
10526       common /kutas/ lprn
10527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10528 C                                                                              C
10529 C      Parallel       Antiparallel                                             C
10530 C                                                                              C
10531 C          o             o                                                     C
10532 C     \   /l\           /j\   /                                                C
10533 C      \ /   \         /   \ /                                                 C
10534 C       o| o |         | o |o                                                  C
10535 C     \ j|/k\|      \  |/k\|l                                                  C
10536 C      \ /   \       \ /   \                                                   C
10537 C       o             o                                                        C
10538 C       i             i                                                        C
10539 C                                                                              C
10540 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10541 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10542 C AL 7/4/01 s1 would occur in the sixth-order moment,
10543 C           but not in a cluster cumulant
10544 #ifdef MOMENT
10545       s1=dip(1,jj,i)*dip(1,kk,k)
10546 #endif
10547       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10548       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10549       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10550       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10551       call transpose2(EUg(1,1,k),auxmat(1,1))
10552       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10553       vv(1)=pizda(1,1)-pizda(2,2)
10554       vv(2)=pizda(1,2)+pizda(2,1)
10555       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10556 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10557 #ifdef MOMENT
10558       eello6_graph2=-(s1+s2+s3+s4)
10559 #else
10560       eello6_graph2=-(s2+s3+s4)
10561 #endif
10562 c      eello6_graph2=-s3
10563 C Derivatives in gamma(i-1)
10564       if (i.gt.1) then
10565 #ifdef MOMENT
10566         s1=dipderg(1,jj,i)*dip(1,kk,k)
10567 #endif
10568         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10569         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10570         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10571         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10572 #ifdef MOMENT
10573         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10574 #else
10575         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10576 #endif
10577 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10578       endif
10579 C Derivatives in gamma(k-1)
10580 #ifdef MOMENT
10581       s1=dip(1,jj,i)*dipderg(1,kk,k)
10582 #endif
10583       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10584       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10585       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10586       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10587       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10588       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10589       vv(1)=pizda(1,1)-pizda(2,2)
10590       vv(2)=pizda(1,2)+pizda(2,1)
10591       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10592 #ifdef MOMENT
10593       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10594 #else
10595       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10596 #endif
10597 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10598 C Derivatives in gamma(j-1) or gamma(l-1)
10599       if (j.gt.1) then
10600 #ifdef MOMENT
10601         s1=dipderg(3,jj,i)*dip(1,kk,k)
10602 #endif
10603         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10604         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10605         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10606         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10607         vv(1)=pizda(1,1)-pizda(2,2)
10608         vv(2)=pizda(1,2)+pizda(2,1)
10609         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10610 #ifdef MOMENT
10611         if (swap) then
10612           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10613         else
10614           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10615         endif
10616 #endif
10617         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10618 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10619       endif
10620 C Derivatives in gamma(l-1) or gamma(j-1)
10621       if (l.gt.1) then
10622 #ifdef MOMENT
10623         s1=dip(1,jj,i)*dipderg(3,kk,k)
10624 #endif
10625         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10626         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10627         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10628         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10629         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10630         vv(1)=pizda(1,1)-pizda(2,2)
10631         vv(2)=pizda(1,2)+pizda(2,1)
10632         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10633 #ifdef MOMENT
10634         if (swap) then
10635           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10636         else
10637           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10638         endif
10639 #endif
10640         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10641 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10642       endif
10643 C Cartesian derivatives.
10644       if (lprn) then
10645         write (2,*) 'In eello6_graph2'
10646         do iii=1,2
10647           write (2,*) 'iii=',iii
10648           do kkk=1,5
10649             write (2,*) 'kkk=',kkk
10650             do jjj=1,2
10651               write (2,'(3(2f10.5),5x)')
10652      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10653             enddo
10654           enddo
10655         enddo
10656       endif
10657       do iii=1,2
10658         do kkk=1,5
10659           do lll=1,3
10660 #ifdef MOMENT
10661             if (iii.eq.1) then
10662               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10663             else
10664               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10665             endif
10666 #endif
10667             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10668      &        auxvec(1))
10669             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10670             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10671      &        auxvec(1))
10672             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10673             call transpose2(EUg(1,1,k),auxmat(1,1))
10674             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10675      &        pizda(1,1))
10676             vv(1)=pizda(1,1)-pizda(2,2)
10677             vv(2)=pizda(1,2)+pizda(2,1)
10678             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10679 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10680 #ifdef MOMENT
10681             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10682 #else
10683             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10684 #endif
10685             if (swap) then
10686               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10687             else
10688               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10689             endif
10690           enddo
10691         enddo
10692       enddo
10693       return
10694       end
10695 c----------------------------------------------------------------------------
10696       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10697       implicit real*8 (a-h,o-z)
10698       include 'DIMENSIONS'
10699       include 'COMMON.IOUNITS'
10700       include 'COMMON.CHAIN'
10701       include 'COMMON.DERIV'
10702       include 'COMMON.INTERACT'
10703       include 'COMMON.CONTACTS'
10704       include 'COMMON.TORSION'
10705       include 'COMMON.VAR'
10706       include 'COMMON.GEO'
10707       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10708       logical swap
10709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10710 C                                                                              C
10711 C      Parallel       Antiparallel                                             C
10712 C                                                                              C
10713 C          o             o                                                     C
10714 C         /l\   /   \   /j\                                                    C
10715 C        /   \ /     \ /   \                                                   C
10716 C       /| o |o       o| o |\                                                  C
10717 C       j|/k\|  /      |/k\|l /                                                C
10718 C        /   \ /       /   \ /                                                 C
10719 C       /     o       /     o                                                  C
10720 C       i             i                                                        C
10721 C                                                                              C
10722 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10723 C
10724 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10725 C           energy moment and not to the cluster cumulant.
10726       iti=itortyp(itype(i))
10727       if (j.lt.nres-1) then
10728         itj1=itype2loc(itype(j+1))
10729       else
10730         itj1=nloctyp
10731       endif
10732       itk=itype2loc(itype(k))
10733       itk1=itype2loc(itype(k+1))
10734       if (l.lt.nres-1) then
10735         itl1=itype2loc(itype(l+1))
10736       else
10737         itl1=nloctyp
10738       endif
10739 #ifdef MOMENT
10740       s1=dip(4,jj,i)*dip(4,kk,k)
10741 #endif
10742       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10743       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10744       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10745       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10746       call transpose2(EE(1,1,k),auxmat(1,1))
10747       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10748       vv(1)=pizda(1,1)+pizda(2,2)
10749       vv(2)=pizda(2,1)-pizda(1,2)
10750       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10751 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10752 cd     & "sum",-(s2+s3+s4)
10753 #ifdef MOMENT
10754       eello6_graph3=-(s1+s2+s3+s4)
10755 #else
10756       eello6_graph3=-(s2+s3+s4)
10757 #endif
10758 c      eello6_graph3=-s4
10759 C Derivatives in gamma(k-1)
10760       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10761       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10762       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10763       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10764 C Derivatives in gamma(l-1)
10765       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10766       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10767       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10768       vv(1)=pizda(1,1)+pizda(2,2)
10769       vv(2)=pizda(2,1)-pizda(1,2)
10770       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10771       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10772 C Cartesian derivatives.
10773       do iii=1,2
10774         do kkk=1,5
10775           do lll=1,3
10776 #ifdef MOMENT
10777             if (iii.eq.1) then
10778               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10779             else
10780               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10781             endif
10782 #endif
10783             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10784      &        auxvec(1))
10785             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10786             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10787      &        auxvec(1))
10788             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10789             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10790      &        pizda(1,1))
10791             vv(1)=pizda(1,1)+pizda(2,2)
10792             vv(2)=pizda(2,1)-pizda(1,2)
10793             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10794 #ifdef MOMENT
10795             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10796 #else
10797             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10798 #endif
10799             if (swap) then
10800               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10801             else
10802               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10803             endif
10804 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10805           enddo
10806         enddo
10807       enddo
10808       return
10809       end
10810 c----------------------------------------------------------------------------
10811       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10812       implicit real*8 (a-h,o-z)
10813       include 'DIMENSIONS'
10814       include 'COMMON.IOUNITS'
10815       include 'COMMON.CHAIN'
10816       include 'COMMON.DERIV'
10817       include 'COMMON.INTERACT'
10818       include 'COMMON.CONTACTS'
10819       include 'COMMON.TORSION'
10820       include 'COMMON.VAR'
10821       include 'COMMON.GEO'
10822       include 'COMMON.FFIELD'
10823       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10824      & auxvec1(2),auxmat1(2,2)
10825       logical swap
10826 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10827 C                                                                              C
10828 C      Parallel       Antiparallel                                             C
10829 C                                                                              C
10830 C          o             o                                                     C
10831 C         /l\   /   \   /j\                                                    C
10832 C        /   \ /     \ /   \                                                   C
10833 C       /| o |o       o| o |\                                                  C
10834 C     \ j|/k\|      \  |/k\|l                                                  C
10835 C      \ /   \       \ /   \                                                   C
10836 C       o     \       o     \                                                  C
10837 C       i             i                                                        C
10838 C                                                                              C
10839 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10840 C
10841 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10842 C           energy moment and not to the cluster cumulant.
10843 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10844       iti=itype2loc(itype(i))
10845       itj=itype2loc(itype(j))
10846       if (j.lt.nres-1) then
10847         itj1=itype2loc(itype(j+1))
10848       else
10849         itj1=nloctyp
10850       endif
10851       itk=itype2loc(itype(k))
10852       if (k.lt.nres-1) then
10853         itk1=itype2loc(itype(k+1))
10854       else
10855         itk1=nloctyp
10856       endif
10857       itl=itype2loc(itype(l))
10858       if (l.lt.nres-1) then
10859         itl1=itype2loc(itype(l+1))
10860       else
10861         itl1=nloctyp
10862       endif
10863 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10864 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10865 cd     & ' itl',itl,' itl1',itl1
10866 #ifdef MOMENT
10867       if (imat.eq.1) then
10868         s1=dip(3,jj,i)*dip(3,kk,k)
10869       else
10870         s1=dip(2,jj,j)*dip(2,kk,l)
10871       endif
10872 #endif
10873       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10874       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10875       if (j.eq.l+1) then
10876         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10877         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10878       else
10879         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10880         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10881       endif
10882       call transpose2(EUg(1,1,k),auxmat(1,1))
10883       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10884       vv(1)=pizda(1,1)-pizda(2,2)
10885       vv(2)=pizda(2,1)+pizda(1,2)
10886       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10887 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10888 #ifdef MOMENT
10889       eello6_graph4=-(s1+s2+s3+s4)
10890 #else
10891       eello6_graph4=-(s2+s3+s4)
10892 #endif
10893 C Derivatives in gamma(i-1)
10894       if (i.gt.1) then
10895 #ifdef MOMENT
10896         if (imat.eq.1) then
10897           s1=dipderg(2,jj,i)*dip(3,kk,k)
10898         else
10899           s1=dipderg(4,jj,j)*dip(2,kk,l)
10900         endif
10901 #endif
10902         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10903         if (j.eq.l+1) then
10904           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10905           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10906         else
10907           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10908           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10909         endif
10910         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10911         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10912 cd          write (2,*) 'turn6 derivatives'
10913 #ifdef MOMENT
10914           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10915 #else
10916           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10917 #endif
10918         else
10919 #ifdef MOMENT
10920           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10921 #else
10922           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10923 #endif
10924         endif
10925       endif
10926 C Derivatives in gamma(k-1)
10927 #ifdef MOMENT
10928       if (imat.eq.1) then
10929         s1=dip(3,jj,i)*dipderg(2,kk,k)
10930       else
10931         s1=dip(2,jj,j)*dipderg(4,kk,l)
10932       endif
10933 #endif
10934       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10935       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10936       if (j.eq.l+1) then
10937         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10938         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10939       else
10940         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10941         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10942       endif
10943       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10944       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10945       vv(1)=pizda(1,1)-pizda(2,2)
10946       vv(2)=pizda(2,1)+pizda(1,2)
10947       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10948       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10949 #ifdef MOMENT
10950         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10951 #else
10952         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10953 #endif
10954       else
10955 #ifdef MOMENT
10956         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10957 #else
10958         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10959 #endif
10960       endif
10961 C Derivatives in gamma(j-1) or gamma(l-1)
10962       if (l.eq.j+1 .and. l.gt.1) then
10963         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10964         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10965         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10966         vv(1)=pizda(1,1)-pizda(2,2)
10967         vv(2)=pizda(2,1)+pizda(1,2)
10968         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10969         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10970       else if (j.gt.1) then
10971         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10972         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10973         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10974         vv(1)=pizda(1,1)-pizda(2,2)
10975         vv(2)=pizda(2,1)+pizda(1,2)
10976         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10977         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10978           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10979         else
10980           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10981         endif
10982       endif
10983 C Cartesian derivatives.
10984       do iii=1,2
10985         do kkk=1,5
10986           do lll=1,3
10987 #ifdef MOMENT
10988             if (iii.eq.1) then
10989               if (imat.eq.1) then
10990                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10991               else
10992                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10993               endif
10994             else
10995               if (imat.eq.1) then
10996                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10997               else
10998                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10999               endif
11000             endif
11001 #endif
11002             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11003      &        auxvec(1))
11004             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11005             if (j.eq.l+1) then
11006               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11007      &          b1(1,j+1),auxvec(1))
11008               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11009             else
11010               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11011      &          b1(1,l+1),auxvec(1))
11012               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11013             endif
11014             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11015      &        pizda(1,1))
11016             vv(1)=pizda(1,1)-pizda(2,2)
11017             vv(2)=pizda(2,1)+pizda(1,2)
11018             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11019             if (swap) then
11020               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11021 #ifdef MOMENT
11022                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11023      &             -(s1+s2+s4)
11024 #else
11025                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11026      &             -(s2+s4)
11027 #endif
11028                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11029               else
11030 #ifdef MOMENT
11031                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11032 #else
11033                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11034 #endif
11035                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11036               endif
11037             else
11038 #ifdef MOMENT
11039               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11040 #else
11041               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11042 #endif
11043               if (l.eq.j+1) then
11044                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11045               else
11046                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11047               endif
11048             endif
11049           enddo
11050         enddo
11051       enddo
11052       return
11053       end
11054 c----------------------------------------------------------------------------
11055       double precision function eello_turn6(i,jj,kk)
11056       implicit real*8 (a-h,o-z)
11057       include 'DIMENSIONS'
11058       include 'COMMON.IOUNITS'
11059       include 'COMMON.CHAIN'
11060       include 'COMMON.DERIV'
11061       include 'COMMON.INTERACT'
11062       include 'COMMON.CONTACTS'
11063       include 'COMMON.TORSION'
11064       include 'COMMON.VAR'
11065       include 'COMMON.GEO'
11066       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11067      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11068      &  ggg1(3),ggg2(3)
11069       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11070      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11071 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11072 C           the respective energy moment and not to the cluster cumulant.
11073       s1=0.0d0
11074       s8=0.0d0
11075       s13=0.0d0
11076 c
11077       eello_turn6=0.0d0
11078       j=i+4
11079       k=i+1
11080       l=i+3
11081       iti=itype2loc(itype(i))
11082       itk=itype2loc(itype(k))
11083       itk1=itype2loc(itype(k+1))
11084       itl=itype2loc(itype(l))
11085       itj=itype2loc(itype(j))
11086 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11087 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11088 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11089 cd        eello6=0.0d0
11090 cd        return
11091 cd      endif
11092 cd      write (iout,*)
11093 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11094 cd     &   ' and',k,l
11095 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11096       do iii=1,2
11097         do kkk=1,5
11098           do lll=1,3
11099             derx_turn(lll,kkk,iii)=0.0d0
11100           enddo
11101         enddo
11102       enddo
11103 cd      eij=1.0d0
11104 cd      ekl=1.0d0
11105 cd      ekont=1.0d0
11106       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11107 cd      eello6_5=0.0d0
11108 cd      write (2,*) 'eello6_5',eello6_5
11109 #ifdef MOMENT
11110       call transpose2(AEA(1,1,1),auxmat(1,1))
11111       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11112       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11113       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11114 #endif
11115       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11116       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11117       s2 = scalar2(b1(1,k),vtemp1(1))
11118 #ifdef MOMENT
11119       call transpose2(AEA(1,1,2),atemp(1,1))
11120       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11121       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11122       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11123 #endif
11124       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11125       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11126       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11127 #ifdef MOMENT
11128       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11129       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11130       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11131       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11132       ss13 = scalar2(b1(1,k),vtemp4(1))
11133       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11134 #endif
11135 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11136 c      s1=0.0d0
11137 c      s2=0.0d0
11138 c      s8=0.0d0
11139 c      s12=0.0d0
11140 c      s13=0.0d0
11141       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11142 C Derivatives in gamma(i+2)
11143       s1d =0.0d0
11144       s8d =0.0d0
11145 #ifdef MOMENT
11146       call transpose2(AEA(1,1,1),auxmatd(1,1))
11147       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11148       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11149       call transpose2(AEAderg(1,1,2),atempd(1,1))
11150       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11151       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11152 #endif
11153       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11154       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11155       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11156 c      s1d=0.0d0
11157 c      s2d=0.0d0
11158 c      s8d=0.0d0
11159 c      s12d=0.0d0
11160 c      s13d=0.0d0
11161       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11162 C Derivatives in gamma(i+3)
11163 #ifdef MOMENT
11164       call transpose2(AEA(1,1,1),auxmatd(1,1))
11165       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11166       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11167       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11168 #endif
11169       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11170       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11171       s2d = scalar2(b1(1,k),vtemp1d(1))
11172 #ifdef MOMENT
11173       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11174       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11175 #endif
11176       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11177 #ifdef MOMENT
11178       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11179       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11180       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11181 #endif
11182 c      s1d=0.0d0
11183 c      s2d=0.0d0
11184 c      s8d=0.0d0
11185 c      s12d=0.0d0
11186 c      s13d=0.0d0
11187 #ifdef MOMENT
11188       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11189      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11190 #else
11191       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11192      &               -0.5d0*ekont*(s2d+s12d)
11193 #endif
11194 C Derivatives in gamma(i+4)
11195       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11196       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11197       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11198 #ifdef MOMENT
11199       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11200       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11201       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11202 #endif
11203 c      s1d=0.0d0
11204 c      s2d=0.0d0
11205 c      s8d=0.0d0
11206 C      s12d=0.0d0
11207 c      s13d=0.0d0
11208 #ifdef MOMENT
11209       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11210 #else
11211       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11212 #endif
11213 C Derivatives in gamma(i+5)
11214 #ifdef MOMENT
11215       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11216       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11217       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11218 #endif
11219       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11220       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11221       s2d = scalar2(b1(1,k),vtemp1d(1))
11222 #ifdef MOMENT
11223       call transpose2(AEA(1,1,2),atempd(1,1))
11224       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11225       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11226 #endif
11227       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11228       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11229 #ifdef MOMENT
11230       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11231       ss13d = scalar2(b1(1,k),vtemp4d(1))
11232       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11233 #endif
11234 c      s1d=0.0d0
11235 c      s2d=0.0d0
11236 c      s8d=0.0d0
11237 c      s12d=0.0d0
11238 c      s13d=0.0d0
11239 #ifdef MOMENT
11240       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11241      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11242 #else
11243       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11244      &               -0.5d0*ekont*(s2d+s12d)
11245 #endif
11246 C Cartesian derivatives
11247       do iii=1,2
11248         do kkk=1,5
11249           do lll=1,3
11250 #ifdef MOMENT
11251             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11252             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11253             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11254 #endif
11255             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11256             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11257      &          vtemp1d(1))
11258             s2d = scalar2(b1(1,k),vtemp1d(1))
11259 #ifdef MOMENT
11260             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11261             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11262             s8d = -(atempd(1,1)+atempd(2,2))*
11263      &           scalar2(cc(1,1,itl),vtemp2(1))
11264 #endif
11265             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11266      &           auxmatd(1,1))
11267             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11268             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11269 c      s1d=0.0d0
11270 c      s2d=0.0d0
11271 c      s8d=0.0d0
11272 c      s12d=0.0d0
11273 c      s13d=0.0d0
11274 #ifdef MOMENT
11275             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11276      &        - 0.5d0*(s1d+s2d)
11277 #else
11278             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11279      &        - 0.5d0*s2d
11280 #endif
11281 #ifdef MOMENT
11282             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11283      &        - 0.5d0*(s8d+s12d)
11284 #else
11285             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11286      &        - 0.5d0*s12d
11287 #endif
11288           enddo
11289         enddo
11290       enddo
11291 #ifdef MOMENT
11292       do kkk=1,5
11293         do lll=1,3
11294           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11295      &      achuj_tempd(1,1))
11296           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11297           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11298           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11299           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11300           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11301      &      vtemp4d(1))
11302           ss13d = scalar2(b1(1,k),vtemp4d(1))
11303           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11304           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11305         enddo
11306       enddo
11307 #endif
11308 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11309 cd     &  16*eel_turn6_num
11310 cd      goto 1112
11311       if (j.lt.nres-1) then
11312         j1=j+1
11313         j2=j-1
11314       else
11315         j1=j-1
11316         j2=j-2
11317       endif
11318       if (l.lt.nres-1) then
11319         l1=l+1
11320         l2=l-1
11321       else
11322         l1=l-1
11323         l2=l-2
11324       endif
11325       do ll=1,3
11326 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11327 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11328 cgrad        ghalf=0.5d0*ggg1(ll)
11329 cd        ghalf=0.0d0
11330         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11331         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11332         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11333      &    +ekont*derx_turn(ll,2,1)
11334         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11335         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11336      &    +ekont*derx_turn(ll,4,1)
11337         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11338         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11339         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11340 cgrad        ghalf=0.5d0*ggg2(ll)
11341 cd        ghalf=0.0d0
11342         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11343      &    +ekont*derx_turn(ll,2,2)
11344         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11345         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11346      &    +ekont*derx_turn(ll,4,2)
11347         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11348         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11349         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11350       enddo
11351 cd      goto 1112
11352 cgrad      do m=i+1,j-1
11353 cgrad        do ll=1,3
11354 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11355 cgrad        enddo
11356 cgrad      enddo
11357 cgrad      do m=k+1,l-1
11358 cgrad        do ll=1,3
11359 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11360 cgrad        enddo
11361 cgrad      enddo
11362 cgrad1112  continue
11363 cgrad      do m=i+2,j2
11364 cgrad        do ll=1,3
11365 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11366 cgrad        enddo
11367 cgrad      enddo
11368 cgrad      do m=k+2,l2
11369 cgrad        do ll=1,3
11370 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11371 cgrad        enddo
11372 cgrad      enddo
11373 cd      do iii=1,nres-3
11374 cd        write (2,*) iii,g_corr6_loc(iii)
11375 cd      enddo
11376       eello_turn6=ekont*eel_turn6
11377 cd      write (2,*) 'ekont',ekont
11378 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11379       return
11380       end
11381
11382 C-----------------------------------------------------------------------------
11383       double precision function scalar(u,v)
11384 !DIR$ INLINEALWAYS scalar
11385 #ifndef OSF
11386 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11387 #endif
11388       implicit none
11389       double precision u(3),v(3)
11390 cd      double precision sc
11391 cd      integer i
11392 cd      sc=0.0d0
11393 cd      do i=1,3
11394 cd        sc=sc+u(i)*v(i)
11395 cd      enddo
11396 cd      scalar=sc
11397
11398       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11399       return
11400       end
11401 crc-------------------------------------------------
11402       SUBROUTINE MATVEC2(A1,V1,V2)
11403 !DIR$ INLINEALWAYS MATVEC2
11404 #ifndef OSF
11405 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11406 #endif
11407       implicit real*8 (a-h,o-z)
11408       include 'DIMENSIONS'
11409       DIMENSION A1(2,2),V1(2),V2(2)
11410 c      DO 1 I=1,2
11411 c        VI=0.0
11412 c        DO 3 K=1,2
11413 c    3     VI=VI+A1(I,K)*V1(K)
11414 c        Vaux(I)=VI
11415 c    1 CONTINUE
11416
11417       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11418       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11419
11420       v2(1)=vaux1
11421       v2(2)=vaux2
11422       END
11423 C---------------------------------------
11424       SUBROUTINE MATMAT2(A1,A2,A3)
11425 #ifndef OSF
11426 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11427 #endif
11428       implicit real*8 (a-h,o-z)
11429       include 'DIMENSIONS'
11430       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11431 c      DIMENSION AI3(2,2)
11432 c        DO  J=1,2
11433 c          A3IJ=0.0
11434 c          DO K=1,2
11435 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11436 c          enddo
11437 c          A3(I,J)=A3IJ
11438 c       enddo
11439 c      enddo
11440
11441       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11442       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11443       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11444       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11445
11446       A3(1,1)=AI3_11
11447       A3(2,1)=AI3_21
11448       A3(1,2)=AI3_12
11449       A3(2,2)=AI3_22
11450       END
11451
11452 c-------------------------------------------------------------------------
11453       double precision function scalar2(u,v)
11454 !DIR$ INLINEALWAYS scalar2
11455       implicit none
11456       double precision u(2),v(2)
11457       double precision sc
11458       integer i
11459       scalar2=u(1)*v(1)+u(2)*v(2)
11460       return
11461       end
11462
11463 C-----------------------------------------------------------------------------
11464
11465       subroutine transpose2(a,at)
11466 !DIR$ INLINEALWAYS transpose2
11467 #ifndef OSF
11468 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11469 #endif
11470       implicit none
11471       double precision a(2,2),at(2,2)
11472       at(1,1)=a(1,1)
11473       at(1,2)=a(2,1)
11474       at(2,1)=a(1,2)
11475       at(2,2)=a(2,2)
11476       return
11477       end
11478 c--------------------------------------------------------------------------
11479       subroutine transpose(n,a,at)
11480       implicit none
11481       integer n,i,j
11482       double precision a(n,n),at(n,n)
11483       do i=1,n
11484         do j=1,n
11485           at(j,i)=a(i,j)
11486         enddo
11487       enddo
11488       return
11489       end
11490 C---------------------------------------------------------------------------
11491       subroutine prodmat3(a1,a2,kk,transp,prod)
11492 !DIR$ INLINEALWAYS prodmat3
11493 #ifndef OSF
11494 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11495 #endif
11496       implicit none
11497       integer i,j
11498       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11499       logical transp
11500 crc      double precision auxmat(2,2),prod_(2,2)
11501
11502       if (transp) then
11503 crc        call transpose2(kk(1,1),auxmat(1,1))
11504 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11505 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11506
11507            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11508      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11509            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11510      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11511            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11512      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11513            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11514      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11515
11516       else
11517 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11518 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11519
11520            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11521      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11522            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11523      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11524            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11525      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11526            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11527      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11528
11529       endif
11530 c      call transpose2(a2(1,1),a2t(1,1))
11531
11532 crc      print *,transp
11533 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11534 crc      print *,((prod(i,j),i=1,2),j=1,2)
11535
11536       return
11537       end
11538 CCC----------------------------------------------
11539       subroutine Eliptransfer(eliptran)
11540       implicit real*8 (a-h,o-z)
11541       include 'DIMENSIONS'
11542       include 'COMMON.GEO'
11543       include 'COMMON.VAR'
11544       include 'COMMON.LOCAL'
11545       include 'COMMON.CHAIN'
11546       include 'COMMON.DERIV'
11547       include 'COMMON.NAMES'
11548       include 'COMMON.INTERACT'
11549       include 'COMMON.IOUNITS'
11550       include 'COMMON.CALC'
11551       include 'COMMON.CONTROL'
11552       include 'COMMON.SPLITELE'
11553       include 'COMMON.SBRIDGE'
11554 C this is done by Adasko
11555 C      print *,"wchodze"
11556 C structure of box:
11557 C      water
11558 C--bordliptop-- buffore starts
11559 C--bufliptop--- here true lipid starts
11560 C      lipid
11561 C--buflipbot--- lipid ends buffore starts
11562 C--bordlipbot--buffore ends
11563       eliptran=0.0
11564       do i=ilip_start,ilip_end
11565 C       do i=1,1
11566         if (itype(i).eq.ntyp1) cycle
11567
11568         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11569         if (positi.le.0.0) positi=positi+boxzsize
11570 C        print *,i
11571 C first for peptide groups
11572 c for each residue check if it is in lipid or lipid water border area
11573        if ((positi.gt.bordlipbot)
11574      &.and.(positi.lt.bordliptop)) then
11575 C the energy transfer exist
11576         if (positi.lt.buflipbot) then
11577 C what fraction I am in
11578          fracinbuf=1.0d0-
11579      &        ((positi-bordlipbot)/lipbufthick)
11580 C lipbufthick is thickenes of lipid buffore
11581          sslip=sscalelip(fracinbuf)
11582          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11583          eliptran=eliptran+sslip*pepliptran
11584          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11585          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11586 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11587
11588 C        print *,"doing sccale for lower part"
11589 C         print *,i,sslip,fracinbuf,ssgradlip
11590         elseif (positi.gt.bufliptop) then
11591          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11592          sslip=sscalelip(fracinbuf)
11593          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11594          eliptran=eliptran+sslip*pepliptran
11595          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11596          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11597 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11598 C          print *, "doing sscalefor top part"
11599 C         print *,i,sslip,fracinbuf,ssgradlip
11600         else
11601          eliptran=eliptran+pepliptran
11602 C         print *,"I am in true lipid"
11603         endif
11604 C       else
11605 C       eliptran=elpitran+0.0 ! I am in water
11606        endif
11607        enddo
11608 C       print *, "nic nie bylo w lipidzie?"
11609 C now multiply all by the peptide group transfer factor
11610 C       eliptran=eliptran*pepliptran
11611 C now the same for side chains
11612 CV       do i=1,1
11613        do i=ilip_start,ilip_end
11614         if (itype(i).eq.ntyp1) cycle
11615         positi=(mod(c(3,i+nres),boxzsize))
11616         if (positi.le.0) positi=positi+boxzsize
11617 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11618 c for each residue check if it is in lipid or lipid water border area
11619 C       respos=mod(c(3,i+nres),boxzsize)
11620 C       print *,positi,bordlipbot,buflipbot
11621        if ((positi.gt.bordlipbot)
11622      & .and.(positi.lt.bordliptop)) then
11623 C the energy transfer exist
11624         if (positi.lt.buflipbot) then
11625          fracinbuf=1.0d0-
11626      &     ((positi-bordlipbot)/lipbufthick)
11627 C lipbufthick is thickenes of lipid buffore
11628          sslip=sscalelip(fracinbuf)
11629          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11630          eliptran=eliptran+sslip*liptranene(itype(i))
11631          gliptranx(3,i)=gliptranx(3,i)
11632      &+ssgradlip*liptranene(itype(i))
11633          gliptranc(3,i-1)= gliptranc(3,i-1)
11634      &+ssgradlip*liptranene(itype(i))
11635 C         print *,"doing sccale for lower part"
11636         elseif (positi.gt.bufliptop) then
11637          fracinbuf=1.0d0-
11638      &((bordliptop-positi)/lipbufthick)
11639          sslip=sscalelip(fracinbuf)
11640          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11641          eliptran=eliptran+sslip*liptranene(itype(i))
11642          gliptranx(3,i)=gliptranx(3,i)
11643      &+ssgradlip*liptranene(itype(i))
11644          gliptranc(3,i-1)= gliptranc(3,i-1)
11645      &+ssgradlip*liptranene(itype(i))
11646 C          print *, "doing sscalefor top part",sslip,fracinbuf
11647         else
11648          eliptran=eliptran+liptranene(itype(i))
11649 C         print *,"I am in true lipid"
11650         endif
11651         endif ! if in lipid or buffor
11652 C       else
11653 C       eliptran=elpitran+0.0 ! I am in water
11654        enddo
11655        return
11656        end
11657 C---------------------------------------------------------
11658 C AFM soubroutine for constant force
11659        subroutine AFMforce(Eafmforce)
11660        implicit real*8 (a-h,o-z)
11661       include 'DIMENSIONS'
11662       include 'COMMON.GEO'
11663       include 'COMMON.VAR'
11664       include 'COMMON.LOCAL'
11665       include 'COMMON.CHAIN'
11666       include 'COMMON.DERIV'
11667       include 'COMMON.NAMES'
11668       include 'COMMON.INTERACT'
11669       include 'COMMON.IOUNITS'
11670       include 'COMMON.CALC'
11671       include 'COMMON.CONTROL'
11672       include 'COMMON.SPLITELE'
11673       include 'COMMON.SBRIDGE'
11674       real*8 diffafm(3)
11675       dist=0.0d0
11676       Eafmforce=0.0d0
11677       do i=1,3
11678       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11679       dist=dist+diffafm(i)**2
11680       enddo
11681       dist=dsqrt(dist)
11682       Eafmforce=-forceAFMconst*(dist-distafminit)
11683       do i=1,3
11684       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11685       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11686       enddo
11687 C      print *,'AFM',Eafmforce
11688       return
11689       end
11690 C---------------------------------------------------------
11691 C AFM subroutine with pseudoconstant velocity
11692        subroutine AFMvel(Eafmforce)
11693        implicit real*8 (a-h,o-z)
11694       include 'DIMENSIONS'
11695       include 'COMMON.GEO'
11696       include 'COMMON.VAR'
11697       include 'COMMON.LOCAL'
11698       include 'COMMON.CHAIN'
11699       include 'COMMON.DERIV'
11700       include 'COMMON.NAMES'
11701       include 'COMMON.INTERACT'
11702       include 'COMMON.IOUNITS'
11703       include 'COMMON.CALC'
11704       include 'COMMON.CONTROL'
11705       include 'COMMON.SPLITELE'
11706       include 'COMMON.SBRIDGE'
11707       real*8 diffafm(3)
11708 C Only for check grad COMMENT if not used for checkgrad
11709 C      totT=3.0d0
11710 C--------------------------------------------------------
11711 C      print *,"wchodze"
11712       dist=0.0d0
11713       Eafmforce=0.0d0
11714       do i=1,3
11715       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11716       dist=dist+diffafm(i)**2
11717       enddo
11718       dist=dsqrt(dist)
11719       Eafmforce=0.5d0*forceAFMconst
11720      & *(distafminit+totTafm*velAFMconst-dist)**2
11721 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11722       do i=1,3
11723       gradafm(i,afmend-1)=-forceAFMconst*
11724      &(distafminit+totTafm*velAFMconst-dist)
11725      &*diffafm(i)/dist
11726       gradafm(i,afmbeg-1)=forceAFMconst*
11727      &(distafminit+totTafm*velAFMconst-dist)
11728      &*diffafm(i)/dist
11729       enddo
11730 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11731       return
11732       end
11733 C-----------------------------------------------------------
11734 C first for shielding is setting of function of side-chains
11735        subroutine set_shield_fac
11736       implicit real*8 (a-h,o-z)
11737       include 'DIMENSIONS'
11738       include 'COMMON.CHAIN'
11739       include 'COMMON.DERIV'
11740       include 'COMMON.IOUNITS'
11741       include 'COMMON.SHIELD'
11742       include 'COMMON.INTERACT'
11743 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11744       double precision div77_81/0.974996043d0/,
11745      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11746
11747 C the vector between center of side_chain and peptide group
11748        double precision pep_side(3),long,side_calf(3),
11749      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11750      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11751 C the line belowe needs to be changed for FGPROC>1
11752       do i=1,nres-1
11753       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11754       ishield_list(i)=0
11755 Cif there two consequtive dummy atoms there is no peptide group between them
11756 C the line below has to be changed for FGPROC>1
11757       VolumeTotal=0.0
11758       do k=1,nres
11759        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11760        dist_pep_side=0.0
11761        dist_side_calf=0.0
11762        do j=1,3
11763 C first lets set vector conecting the ithe side-chain with kth side-chain
11764       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11765 C      pep_side(j)=2.0d0
11766 C and vector conecting the side-chain with its proper calfa
11767       side_calf(j)=c(j,k+nres)-c(j,k)
11768 C      side_calf(j)=2.0d0
11769       pept_group(j)=c(j,i)-c(j,i+1)
11770 C lets have their lenght
11771       dist_pep_side=pep_side(j)**2+dist_pep_side
11772       dist_side_calf=dist_side_calf+side_calf(j)**2
11773       dist_pept_group=dist_pept_group+pept_group(j)**2
11774       enddo
11775        dist_pep_side=dsqrt(dist_pep_side)
11776        dist_pept_group=dsqrt(dist_pept_group)
11777        dist_side_calf=dsqrt(dist_side_calf)
11778       do j=1,3
11779         pep_side_norm(j)=pep_side(j)/dist_pep_side
11780         side_calf_norm(j)=dist_side_calf
11781       enddo
11782 C now sscale fraction
11783        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11784 C       print *,buff_shield,"buff"
11785 C now sscale
11786         if (sh_frac_dist.le.0.0) cycle
11787 C If we reach here it means that this side chain reaches the shielding sphere
11788 C Lets add him to the list for gradient
11789         ishield_list(i)=ishield_list(i)+1
11790 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11791 C this list is essential otherwise problem would be O3
11792         shield_list(ishield_list(i),i)=k
11793 C Lets have the sscale value
11794         if (sh_frac_dist.gt.1.0) then
11795          scale_fac_dist=1.0d0
11796          do j=1,3
11797          sh_frac_dist_grad(j)=0.0d0
11798          enddo
11799         else
11800          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11801      &                   *(2.0*sh_frac_dist-3.0d0)
11802          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11803      &                  /dist_pep_side/buff_shield*0.5
11804 C remember for the final gradient multiply sh_frac_dist_grad(j)
11805 C for side_chain by factor -2 !
11806          do j=1,3
11807          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11808 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11809 C     &                    sh_frac_dist_grad(j)
11810          enddo
11811         endif
11812 C        if ((i.eq.3).and.(k.eq.2)) then
11813 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11814 C     & ,"TU"
11815 C        endif
11816
11817 C this is what is now we have the distance scaling now volume...
11818       short=short_r_sidechain(itype(k))
11819       long=long_r_sidechain(itype(k))
11820       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11821 C now costhet_grad
11822 C       costhet=0.0d0
11823        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11824 C       costhet_fac=0.0d0
11825        do j=1,3
11826          costhet_grad(j)=costhet_fac*pep_side(j)
11827        enddo
11828 C remember for the final gradient multiply costhet_grad(j)
11829 C for side_chain by factor -2 !
11830 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11831 C pep_side0pept_group is vector multiplication
11832       pep_side0pept_group=0.0
11833       do j=1,3
11834       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11835       enddo
11836       cosalfa=(pep_side0pept_group/
11837      & (dist_pep_side*dist_side_calf))
11838       fac_alfa_sin=1.0-cosalfa**2
11839       fac_alfa_sin=dsqrt(fac_alfa_sin)
11840       rkprim=fac_alfa_sin*(long-short)+short
11841 C now costhet_grad
11842        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11843        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11844
11845        do j=1,3
11846          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11847      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11848      &*(long-short)/fac_alfa_sin*cosalfa/
11849      &((dist_pep_side*dist_side_calf))*
11850      &((side_calf(j))-cosalfa*
11851      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11852
11853         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11854      &*(long-short)/fac_alfa_sin*cosalfa
11855      &/((dist_pep_side*dist_side_calf))*
11856      &(pep_side(j)-
11857      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11858        enddo
11859
11860       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11861      &                    /VSolvSphere_div
11862      &                    *wshield
11863 C now the gradient...
11864 C grad_shield is gradient of Calfa for peptide groups
11865 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11866 C     &               costhet,cosphi
11867 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11868 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11869       do j=1,3
11870       grad_shield(j,i)=grad_shield(j,i)
11871 C gradient po skalowaniu
11872      &                +(sh_frac_dist_grad(j)
11873 C  gradient po costhet
11874      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11875      &-scale_fac_dist*(cosphi_grad_long(j))
11876      &/(1.0-cosphi) )*div77_81
11877      &*VofOverlap
11878 C grad_shield_side is Cbeta sidechain gradient
11879       grad_shield_side(j,ishield_list(i),i)=
11880      &        (sh_frac_dist_grad(j)*-2.0d0
11881      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11882      &       +scale_fac_dist*(cosphi_grad_long(j))
11883      &        *2.0d0/(1.0-cosphi))
11884      &        *div77_81*VofOverlap
11885
11886        grad_shield_loc(j,ishield_list(i),i)=
11887      &   scale_fac_dist*cosphi_grad_loc(j)
11888      &        *2.0d0/(1.0-cosphi)
11889      &        *div77_81*VofOverlap
11890       enddo
11891       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11892       enddo
11893       fac_shield(i)=VolumeTotal*div77_81+div4_81
11894 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11895       enddo
11896       return
11897       end
11898 C--------------------------------------------------------------------------
11899       double precision function tschebyshev(m,n,x,y)
11900       implicit none
11901       include "DIMENSIONS"
11902       integer i,m,n
11903       double precision x(n),y,yy(0:maxvar),aux
11904 c Tschebyshev polynomial. Note that the first term is omitted
11905 c m=0: the constant term is included
11906 c m=1: the constant term is not included
11907       yy(0)=1.0d0
11908       yy(1)=y
11909       do i=2,n
11910         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11911       enddo
11912       aux=0.0d0
11913       do i=m,n
11914         aux=aux+x(i)*yy(i)
11915       enddo
11916       tschebyshev=aux
11917       return
11918       end
11919 C--------------------------------------------------------------------------
11920       double precision function gradtschebyshev(m,n,x,y)
11921       implicit none
11922       include "DIMENSIONS"
11923       integer i,m,n
11924       double precision x(n+1),y,yy(0:maxvar),aux
11925 c Tschebyshev polynomial. Note that the first term is omitted
11926 c m=0: the constant term is included
11927 c m=1: the constant term is not included
11928       yy(0)=1.0d0
11929       yy(1)=2.0d0*y
11930       do i=2,n
11931         yy(i)=2*y*yy(i-1)-yy(i-2)
11932       enddo
11933       aux=0.0d0
11934       do i=m,n
11935         aux=aux+x(i+1)*yy(i)*(i+1)
11936 C        print *, x(i+1),yy(i),i
11937       enddo
11938       gradtschebyshev=aux
11939       return
11940       end
11941 C------------------------------------------------------------------------
11942 C first for shielding is setting of function of side-chains
11943        subroutine set_shield_fac2
11944       implicit real*8 (a-h,o-z)
11945       include 'DIMENSIONS'
11946       include 'COMMON.CHAIN'
11947       include 'COMMON.DERIV'
11948       include 'COMMON.IOUNITS'
11949       include 'COMMON.SHIELD'
11950       include 'COMMON.INTERACT'
11951       include 'COMMON.LOCAL'
11952
11953 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11954       double precision div77_81/0.974996043d0/,
11955      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11956
11957 C the vector between center of side_chain and peptide group
11958        double precision pep_side(3),long,side_calf(3),
11959      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11960      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11961 C      write(2,*) "ivec",ivec_start,ivec_end
11962       do i=1,nres
11963         fac_shield(i)=0.0d0
11964         do j=1,3
11965         grad_shield(j,i)=0.0d0
11966         enddo
11967       enddo
11968 C the line belowe needs to be changed for FGPROC>1
11969       do i=ivec_start,ivec_end
11970 C      do i=1,nres-1
11971 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11972       ishield_list(i)=0
11973       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11974 Cif there two consequtive dummy atoms there is no peptide group between them
11975 C the line below has to be changed for FGPROC>1
11976       VolumeTotal=0.0
11977       do k=1,nres
11978        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11979        dist_pep_side=0.0
11980        dist_side_calf=0.0
11981        do j=1,3
11982 C first lets set vector conecting the ithe side-chain with kth side-chain
11983       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11984 C      pep_side(j)=2.0d0
11985 C and vector conecting the side-chain with its proper calfa
11986       side_calf(j)=c(j,k+nres)-c(j,k)
11987 C      side_calf(j)=2.0d0
11988       pept_group(j)=c(j,i)-c(j,i+1)
11989 C lets have their lenght
11990       dist_pep_side=pep_side(j)**2+dist_pep_side
11991       dist_side_calf=dist_side_calf+side_calf(j)**2
11992       dist_pept_group=dist_pept_group+pept_group(j)**2
11993       enddo
11994        dist_pep_side=dsqrt(dist_pep_side)
11995        dist_pept_group=dsqrt(dist_pept_group)
11996        dist_side_calf=dsqrt(dist_side_calf)
11997       do j=1,3
11998         pep_side_norm(j)=pep_side(j)/dist_pep_side
11999         side_calf_norm(j)=dist_side_calf
12000       enddo
12001 C now sscale fraction
12002        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12003 C       print *,buff_shield,"buff"
12004 C now sscale
12005         if (sh_frac_dist.le.0.0) cycle
12006 C        print *,ishield_list(i),i
12007 C If we reach here it means that this side chain reaches the shielding sphere
12008 C Lets add him to the list for gradient
12009         ishield_list(i)=ishield_list(i)+1
12010 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12011 C this list is essential otherwise problem would be O3
12012         shield_list(ishield_list(i),i)=k
12013 C Lets have the sscale value
12014         if (sh_frac_dist.gt.1.0) then
12015          scale_fac_dist=1.0d0
12016          do j=1,3
12017          sh_frac_dist_grad(j)=0.0d0
12018          enddo
12019         else
12020          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12021      &                   *(2.0d0*sh_frac_dist-3.0d0)
12022          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12023      &                  /dist_pep_side/buff_shield*0.5d0
12024 C remember for the final gradient multiply sh_frac_dist_grad(j)
12025 C for side_chain by factor -2 !
12026          do j=1,3
12027          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12028 C         sh_frac_dist_grad(j)=0.0d0
12029 C         scale_fac_dist=1.0d0
12030 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12031 C     &                    sh_frac_dist_grad(j)
12032          enddo
12033         endif
12034 C this is what is now we have the distance scaling now volume...
12035       short=short_r_sidechain(itype(k))
12036       long=long_r_sidechain(itype(k))
12037       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12038       sinthet=short/dist_pep_side*costhet
12039 C now costhet_grad
12040 C       costhet=0.6d0
12041 C       sinthet=0.8
12042        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12043 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12044 C     &             -short/dist_pep_side**2/costhet)
12045 C       costhet_fac=0.0d0
12046        do j=1,3
12047          costhet_grad(j)=costhet_fac*pep_side(j)
12048        enddo
12049 C remember for the final gradient multiply costhet_grad(j)
12050 C for side_chain by factor -2 !
12051 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12052 C pep_side0pept_group is vector multiplication
12053       pep_side0pept_group=0.0d0
12054       do j=1,3
12055       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12056       enddo
12057       cosalfa=(pep_side0pept_group/
12058      & (dist_pep_side*dist_side_calf))
12059       fac_alfa_sin=1.0d0-cosalfa**2
12060       fac_alfa_sin=dsqrt(fac_alfa_sin)
12061       rkprim=fac_alfa_sin*(long-short)+short
12062 C      rkprim=short
12063
12064 C now costhet_grad
12065        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12066 C       cosphi=0.6
12067        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12068        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12069      &      dist_pep_side**2)
12070 C       sinphi=0.8
12071        do j=1,3
12072          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12073      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12074      &*(long-short)/fac_alfa_sin*cosalfa/
12075      &((dist_pep_side*dist_side_calf))*
12076      &((side_calf(j))-cosalfa*
12077      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12078 C       cosphi_grad_long(j)=0.0d0
12079         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12080      &*(long-short)/fac_alfa_sin*cosalfa
12081      &/((dist_pep_side*dist_side_calf))*
12082      &(pep_side(j)-
12083      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12084 C       cosphi_grad_loc(j)=0.0d0
12085        enddo
12086 C      print *,sinphi,sinthet
12087       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12088      &                    /VSolvSphere_div
12089 C     &                    *wshield
12090 C now the gradient...
12091       do j=1,3
12092       grad_shield(j,i)=grad_shield(j,i)
12093 C gradient po skalowaniu
12094      &                +(sh_frac_dist_grad(j)*VofOverlap
12095 C  gradient po costhet
12096      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12097      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12098      &       sinphi/sinthet*costhet*costhet_grad(j)
12099      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12100      & )*wshield
12101 C grad_shield_side is Cbeta sidechain gradient
12102       grad_shield_side(j,ishield_list(i),i)=
12103      &        (sh_frac_dist_grad(j)*-2.0d0
12104      &        *VofOverlap
12105      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.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
12111        grad_shield_loc(j,ishield_list(i),i)=
12112      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12113      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12114      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12115      &        ))
12116      &        *wshield
12117       enddo
12118       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12119       enddo
12120       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12121 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12122       enddo
12123       return
12124       end
12125 C-----------------------------------------------------------------------
12126 C-----------------------------------------------------------
12127 C This subroutine is to mimic the histone like structure but as well can be
12128 C utilizet to nanostructures (infinit) small modification has to be used to
12129 C make it finite (z gradient at the ends has to be changes as well as the x,y
12130 C gradient has to be modified at the ends
12131 C The energy function is Kihara potential
12132 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12133 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12134 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12135 C simple Kihara potential
12136       subroutine calctube(Etube)
12137        implicit real*8 (a-h,o-z)
12138       include 'DIMENSIONS'
12139       include 'COMMON.GEO'
12140       include 'COMMON.VAR'
12141       include 'COMMON.LOCAL'
12142       include 'COMMON.CHAIN'
12143       include 'COMMON.DERIV'
12144       include 'COMMON.NAMES'
12145       include 'COMMON.INTERACT'
12146       include 'COMMON.IOUNITS'
12147       include 'COMMON.CALC'
12148       include 'COMMON.CONTROL'
12149       include 'COMMON.SPLITELE'
12150       include 'COMMON.SBRIDGE'
12151       double precision tub_r,vectube(3),enetube(maxres*2)
12152       Etube=0.0d0
12153       do i=itube_start,itube_end
12154         enetube(i)=0.0d0
12155         enetube(i+nres)=0.0d0
12156       enddo
12157 C first we calculate the distance from tube center
12158 C first sugare-phosphate group for NARES this would be peptide group
12159 C for UNRES
12160        do i=itube_start,itube_end
12161 C lets ommit dummy atoms for now
12162        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12163 C now calculate distance from center of tube and direction vectors
12164       xmin=boxxsize
12165       ymin=boxysize
12166         do j=-1,1
12167          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12168          vectube(1)=vectube(1)+boxxsize*j
12169          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12170          vectube(2)=vectube(2)+boxysize*j
12171
12172          xminact=abs(vectube(1)-tubecenter(1))
12173          yminact=abs(vectube(2)-tubecenter(2))
12174            if (xmin.gt.xminact) then
12175             xmin=xminact
12176             xtemp=vectube(1)
12177            endif
12178            if (ymin.gt.yminact) then
12179              ymin=yminact
12180              ytemp=vectube(2)
12181             endif
12182          enddo
12183       vectube(1)=xtemp
12184       vectube(2)=ytemp
12185       vectube(1)=vectube(1)-tubecenter(1)
12186       vectube(2)=vectube(2)-tubecenter(2)
12187
12188 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12189 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12190
12191 C as the tube is infinity we do not calculate the Z-vector use of Z
12192 C as chosen axis
12193       vectube(3)=0.0d0
12194 C now calculte the distance
12195        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12196 C now normalize vector
12197       vectube(1)=vectube(1)/tub_r
12198       vectube(2)=vectube(2)/tub_r
12199 C calculte rdiffrence between r and r0
12200       rdiff=tub_r-tubeR0
12201 C and its 6 power
12202       rdiff6=rdiff**6.0d0
12203 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12204        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12205 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12206 C       print *,rdiff,rdiff6,pep_aa_tube
12207 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12208 C now we calculate gradient
12209        fac=(-12.0d0*pep_aa_tube/rdiff6-
12210      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12211 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12212 C     &rdiff,fac
12213
12214 C now direction of gg_tube vector
12215         do j=1,3
12216         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12217         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12218         enddo
12219         enddo
12220 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12221 C        print *,gg_tube(1,0),"TU"
12222
12223
12224        do i=itube_start,itube_end
12225 C Lets not jump over memory as we use many times iti
12226          iti=itype(i)
12227 C lets ommit dummy atoms for now
12228          if ((iti.eq.ntyp1)
12229 C in UNRES uncomment the line below as GLY has no side-chain...
12230 C      .or.(iti.eq.10)
12231      &   ) cycle
12232       xmin=boxxsize
12233       ymin=boxysize
12234         do j=-1,1
12235          vectube(1)=mod((c(1,i+nres)),boxxsize)
12236          vectube(1)=vectube(1)+boxxsize*j
12237          vectube(2)=mod((c(2,i+nres)),boxysize)
12238          vectube(2)=vectube(2)+boxysize*j
12239
12240          xminact=abs(vectube(1)-tubecenter(1))
12241          yminact=abs(vectube(2)-tubecenter(2))
12242            if (xmin.gt.xminact) then
12243             xmin=xminact
12244             xtemp=vectube(1)
12245            endif
12246            if (ymin.gt.yminact) then
12247              ymin=yminact
12248              ytemp=vectube(2)
12249             endif
12250          enddo
12251       vectube(1)=xtemp
12252       vectube(2)=ytemp
12253 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12254 C     &     tubecenter(2)
12255       vectube(1)=vectube(1)-tubecenter(1)
12256       vectube(2)=vectube(2)-tubecenter(2)
12257
12258 C as the tube is infinity we do not calculate the Z-vector use of Z
12259 C as chosen axis
12260       vectube(3)=0.0d0
12261 C now calculte the distance
12262        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12263 C now normalize vector
12264       vectube(1)=vectube(1)/tub_r
12265       vectube(2)=vectube(2)/tub_r
12266
12267 C calculte rdiffrence between r and r0
12268       rdiff=tub_r-tubeR0
12269 C and its 6 power
12270       rdiff6=rdiff**6.0d0
12271 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12272        sc_aa_tube=sc_aa_tube_par(iti)
12273        sc_bb_tube=sc_bb_tube_par(iti)
12274        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12275 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12276 C now we calculate gradient
12277        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12278      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12279 C now direction of gg_tube vector
12280          do j=1,3
12281           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12282           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12283          enddo
12284         enddo
12285         do i=itube_start,itube_end
12286           Etube=Etube+enetube(i)+enetube(i+nres)
12287         enddo
12288 C        print *,"ETUBE", etube
12289         return
12290         end
12291 C TO DO 1) add to total energy
12292 C       2) add to gradient summation
12293 C       3) add reading parameters (AND of course oppening of PARAM file)
12294 C       4) add reading the center of tube
12295 C       5) add COMMONs
12296 C       6) add to zerograd
12297
12298 C-----------------------------------------------------------------------
12299 C-----------------------------------------------------------
12300 C This subroutine is to mimic the histone like structure but as well can be
12301 C utilizet to nanostructures (infinit) small modification has to be used to
12302 C make it finite (z gradient at the ends has to be changes as well as the x,y
12303 C gradient has to be modified at the ends
12304 C The energy function is Kihara potential
12305 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12306 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12307 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12308 C simple Kihara potential
12309       subroutine calctube2(Etube)
12310        implicit real*8 (a-h,o-z)
12311       include 'DIMENSIONS'
12312       include 'COMMON.GEO'
12313       include 'COMMON.VAR'
12314       include 'COMMON.LOCAL'
12315       include 'COMMON.CHAIN'
12316       include 'COMMON.DERIV'
12317       include 'COMMON.NAMES'
12318       include 'COMMON.INTERACT'
12319       include 'COMMON.IOUNITS'
12320       include 'COMMON.CALC'
12321       include 'COMMON.CONTROL'
12322       include 'COMMON.SPLITELE'
12323       include 'COMMON.SBRIDGE'
12324       double precision tub_r,vectube(3),enetube(maxres*2)
12325       Etube=0.0d0
12326       do i=itube_start,itube_end
12327         enetube(i)=0.0d0
12328         enetube(i+nres)=0.0d0
12329       enddo
12330 C first we calculate the distance from tube center
12331 C first sugare-phosphate group for NARES this would be peptide group
12332 C for UNRES
12333        do i=itube_start,itube_end
12334 C lets ommit dummy atoms for now
12335
12336        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12337 C now calculate distance from center of tube and direction vectors
12338       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12339           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12340       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12341           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12342       vectube(1)=vectube(1)-tubecenter(1)
12343       vectube(2)=vectube(2)-tubecenter(2)
12344
12345 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12346 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12347
12348 C as the tube is infinity we do not calculate the Z-vector use of Z
12349 C as chosen axis
12350       vectube(3)=0.0d0
12351 C now calculte the distance
12352        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12353 C now normalize vector
12354       vectube(1)=vectube(1)/tub_r
12355       vectube(2)=vectube(2)/tub_r
12356 C calculte rdiffrence between r and r0
12357       rdiff=tub_r-tubeR0
12358 C and its 6 power
12359       rdiff6=rdiff**6.0d0
12360 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12361        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12362 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12363 C       print *,rdiff,rdiff6,pep_aa_tube
12364 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12365 C now we calculate gradient
12366        fac=(-12.0d0*pep_aa_tube/rdiff6-
12367      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12368 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12369 C     &rdiff,fac
12370
12371 C now direction of gg_tube vector
12372         do j=1,3
12373         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12374         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12375         enddo
12376         enddo
12377 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12378 C        print *,gg_tube(1,0),"TU"
12379         do i=itube_start,itube_end
12380 C Lets not jump over memory as we use many times iti
12381          iti=itype(i)
12382 C lets ommit dummy atoms for now
12383          if ((iti.eq.ntyp1)
12384 C in UNRES uncomment the line below as GLY has no side-chain...
12385      &      .or.(iti.eq.10)
12386      &   ) cycle
12387           vectube(1)=c(1,i+nres)
12388           vectube(1)=mod(vectube(1),boxxsize)
12389           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12390           vectube(2)=c(2,i+nres)
12391           vectube(2)=mod(vectube(2),boxysize)
12392           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12393
12394       vectube(1)=vectube(1)-tubecenter(1)
12395       vectube(2)=vectube(2)-tubecenter(2)
12396 C THIS FRAGMENT MAKES TUBE FINITE
12397         positi=(mod(c(3,i+nres),boxzsize))
12398         if (positi.le.0) positi=positi+boxzsize
12399 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12400 c for each residue check if it is in lipid or lipid water border area
12401 C       respos=mod(c(3,i+nres),boxzsize)
12402        print *,positi,bordtubebot,buftubebot,bordtubetop
12403        if ((positi.gt.bordtubebot)
12404      & .and.(positi.lt.bordtubetop)) then
12405 C the energy transfer exist
12406         if (positi.lt.buftubebot) then
12407          fracinbuf=1.0d0-
12408      &     ((positi-bordtubebot)/tubebufthick)
12409 C lipbufthick is thickenes of lipid buffore
12410          sstube=sscalelip(fracinbuf)
12411          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12412          print *,ssgradtube, sstube,tubetranene(itype(i))
12413          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12414 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12415 C     &+ssgradtube*tubetranene(itype(i))
12416 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12417 C     &+ssgradtube*tubetranene(itype(i))
12418 C         print *,"doing sccale for lower part"
12419         elseif (positi.gt.buftubetop) then
12420          fracinbuf=1.0d0-
12421      &((bordtubetop-positi)/tubebufthick)
12422          sstube=sscalelip(fracinbuf)
12423          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12424          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12425 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12426 C     &+ssgradtube*tubetranene(itype(i))
12427 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12428 C     &+ssgradtube*tubetranene(itype(i))
12429 C          print *, "doing sscalefor top part",sslip,fracinbuf
12430         else
12431          sstube=1.0d0
12432          ssgradtube=0.0d0
12433          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12434 C         print *,"I am in true lipid"
12435         endif
12436         else
12437 C          sstube=0.0d0
12438 C          ssgradtube=0.0d0
12439         cycle
12440         endif ! if in lipid or buffor
12441 CEND OF FINITE FRAGMENT
12442 C as the tube is infinity we do not calculate the Z-vector use of Z
12443 C as chosen axis
12444       vectube(3)=0.0d0
12445 C now calculte the distance
12446        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12447 C now normalize vector
12448       vectube(1)=vectube(1)/tub_r
12449       vectube(2)=vectube(2)/tub_r
12450 C calculte rdiffrence between r and r0
12451       rdiff=tub_r-tubeR0
12452 C and its 6 power
12453       rdiff6=rdiff**6.0d0
12454 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12455        sc_aa_tube=sc_aa_tube_par(iti)
12456        sc_bb_tube=sc_bb_tube_par(iti)
12457        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12458      &                 *sstube+enetube(i+nres)
12459 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12460 C now we calculate gradient
12461        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12462      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12463 C now direction of gg_tube vector
12464          do j=1,3
12465           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12466           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12467          enddo
12468          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12469      &+ssgradtube*enetube(i+nres)/sstube
12470          gg_tube(3,i-1)= gg_tube(3,i-1)
12471      &+ssgradtube*enetube(i+nres)/sstube
12472
12473         enddo
12474         do i=itube_start,itube_end
12475           Etube=Etube+enetube(i)+enetube(i+nres)
12476         enddo
12477 C        print *,"ETUBE", etube
12478         return
12479         end
12480 C TO DO 1) add to total energy
12481 C       2) add to gradient summation
12482 C       3) add reading parameters (AND of course oppening of PARAM file)
12483 C       4) add reading the center of tube
12484 C       5) add COMMONs
12485 C       6) add to zerograd
12486