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 C        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 C      print *,'Calling EHPB'
 285       call edis(ehpb)
 286 C      print *,'EHPB exitted succesfully.'
 287 C
 288 C Calculate the virtual-bond-angle energy.
 289 C
 290       if (wang.gt.0d0) then
 291        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 292         call ebend(ebe,ethetacnstr)
 293         endif
 294 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 295 C energy function
 296        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 297          call ebend_kcc(ebe,ethetacnstr)
 298         endif
 299       else
 300         ebe=0
 301         ethetacnstr=0
 302       endif
 303 C       print *,"Processor",myrank," computed UB"
 304 C
 305 C Calculate the SC local energy.
 306 C
 307 C      print *,"TU DOCHODZE?"
 308       call esc(escloc)
 309 C      print *,"Processor",myrank," computed USC"
 310 C
 311 C Calculate the virtual-bond torsional energy.
 312 C
 313 cd    print *,'nterm=',nterm
 314 C      print *,"tor",tor_mode
 315       if (wtor.gt.0) then
 316        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 317        call etor(etors,edihcnstr)
 318        endif
 319 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 320 C energy function
 321        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 322        call etor_kcc(etors,edihcnstr)
 323        endif
 324       else
 325        etors=0
 326        edihcnstr=0
 327       endif
 328 C      print *,"Processor",myrank," computed Utor"
 329 C
 330 C 6/23/01 Calculate double-torsional energy
 331 C
 332       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 333        call etor_d(etors_d)
 334       else
 335        etors_d=0
 336       endif
 337 C      print *,"Processor",myrank," computed Utord"
 338 C
 339 C 21/5/07 Calculate local sicdechain correlation energy
 340 C
 341       if (wsccor.gt.0.0d0) then
 342         call eback_sc_corr(esccor)
 343       else
 344         esccor=0.0d0
 345       endif
 346 C      print *,"PRZED MULIt"
 347 C      print *,"Processor",myrank," computed Usccorr"
 348 C
 349 C 12/1/95 Multi-body terms
 350 C
 351       n_corr=0
 352       n_corr1=0
 353       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 354      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 355          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 356 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 357 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 358       else
 359          ecorr=0.0d0
 360          ecorr5=0.0d0
 361          ecorr6=0.0d0
 362          eturn6=0.0d0
 363       endif
 364       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 365          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 366 cd         write (iout,*) "multibody_hb ecorr",ecorr
 367       endif
 368 c      print *,"Processor",myrank," computed Ucorr"
 369 C
 370 C If performing constraint dynamics, call the constraint energy
 371 C  after the equilibration time
 372       if(usampl.and.totT.gt.eq_time) then
 373          call EconstrQ
 374          call Econstr_back
 375       else
 376          Uconst=0.0d0
 377          Uconst_back=0.0d0
 378       endif
 379 C 01/27/2015 added by adasko
 380 C the energy component below is energy transfer into lipid environment
 381 C based on partition function
 382 C      print *,"przed lipidami"
 383       if (wliptran.gt.0) then
 384         call Eliptransfer(eliptran)
 385       else
 386        eliptran=0.0d0
 387       endif
 388 C      print *,"za lipidami"
 389       if (AFMlog.gt.0) then
 390         call AFMforce(Eafmforce)
 391       else if (selfguide.gt.0) then
 392         call AFMvel(Eafmforce)
 393       endif
 394       if (TUBElog.eq.1) then
 395 C      print *,"just before call"
 396         call calctube(Etube)
 397        elseif (TUBElog.eq.2) then
 398         call calctube2(Etube)
 399        elseif (TUBElog.eq.3) then
 400         call calcnano(Etube)
 401        else
 402        Etube=0.0d0
 403        endif
 404
 405 #ifdef TIMING
 406       time_enecalc=time_enecalc+MPI_Wtime()-time00
 407 #endif
 408 c      print *,"Processor",myrank," computed Uconstr"
 409 #ifdef TIMING
 410       time00=MPI_Wtime()
 411 #endif
 412 c
 413 C Sum the energies
 414 C
 415       energia(1)=evdw
 416 #ifdef SCP14
 417       energia(2)=evdw2-evdw2_14
 418       energia(18)=evdw2_14
 419 #else
 420       energia(2)=evdw2
 421       energia(18)=0.0d0
 422 #endif
 423 #ifdef SPLITELE
 424       energia(3)=ees
 425       energia(16)=evdw1
 426 #else
 427       energia(3)=ees+evdw1
 428       energia(16)=0.0d0
 429 #endif
 430       energia(4)=ecorr
 431       energia(5)=ecorr5
 432       energia(6)=ecorr6
 433       energia(7)=eel_loc
 434       energia(8)=eello_turn3
 435       energia(9)=eello_turn4
 436       energia(10)=eturn6
 437       energia(11)=ebe
 438       energia(12)=escloc
 439       energia(13)=etors
 440       energia(14)=etors_d
 441       energia(15)=ehpb
 442       energia(19)=edihcnstr
 443       energia(17)=estr
 444       energia(20)=Uconst+Uconst_back
 445       energia(21)=esccor
 446       energia(22)=eliptran
 447       energia(23)=Eafmforce
 448       energia(24)=ethetacnstr
 449       energia(25)=Etube
 450 c    Here are the energies showed per procesor if the are more processors
 451 c    per molecule then we sum it up in sum_energy subroutine
 452 c      print *," Processor",myrank," calls SUM_ENERGY"
 453       call sum_energy(energia,.true.)
 454       if (dyn_ss) call dyn_set_nss
 455 c      print *," Processor",myrank," left SUM_ENERGY"
 456 #ifdef TIMING
 457       time_sumene=time_sumene+MPI_Wtime()-time00
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_energy(energia,reduce)
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include "mpif.h"
 473 #endif
 474       include 'COMMON.SETUP'
 475       include 'COMMON.IOUNITS'
 476       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       logical reduce
 486 #ifdef MPI
 487       if (nfgtasks.gt.1 .and. reduce) then
 488 #ifdef DEBUG
 489         write (iout,*) "energies before REDUCE"
 490         call enerprint(energia)
 491         call flush(iout)
 492 #endif
 493         do i=0,n_ene
 494           enebuff(i)=energia(i)
 495         enddo
 496         time00=MPI_Wtime()
 497         call MPI_Barrier(FG_COMM,IERR)
 498         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 499         time00=MPI_Wtime()
 500         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 501      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 502 #ifdef DEBUG
 503         write (iout,*) "energies after REDUCE"
 504         call enerprint(energia)
 505         call flush(iout)
 506 #endif
 507         time_Reduce=time_Reduce+MPI_Wtime()-time00
 508       endif
 509       if (fg_rank.eq.0) then
 510 #endif
 511       evdw=energia(1)
 512 #ifdef SCP14
 513       evdw2=energia(2)+energia(18)
 514       evdw2_14=energia(18)
 515 #else
 516       evdw2=energia(2)
 517 #endif
 518 #ifdef SPLITELE
 519       ees=energia(3)
 520       evdw1=energia(16)
 521 #else
 522       ees=energia(3)
 523       evdw1=0.0d0
 524 #endif
 525       ecorr=energia(4)
 526       ecorr5=energia(5)
 527       ecorr6=energia(6)
 528       eel_loc=energia(7)
 529       eello_turn3=energia(8)
 530       eello_turn4=energia(9)
 531       eturn6=energia(10)
 532       ebe=energia(11)
 533       escloc=energia(12)
 534       etors=energia(13)
 535       etors_d=energia(14)
 536       ehpb=energia(15)
 537       edihcnstr=energia(19)
 538       estr=energia(17)
 539       Uconst=energia(20)
 540       esccor=energia(21)
 541       eliptran=energia(22)
 542       Eafmforce=energia(23)
 543       ethetacnstr=energia(24)
 544       Etube=energia(25)
 545 #ifdef SPLITELE
 546       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 547      & +wang*ebe+wtor*etors+wscloc*escloc
 548      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 549      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 550      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 551      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 552      & +ethetacnstr+wtube*Etube
 553 #else
 554       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 555      & +wang*ebe+wtor*etors+wscloc*escloc
 556      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 557      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 558      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 559      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 560      & +Eafmforce
 561      & +ethetacnstr+wtube*Etube
 562 #endif
 563       energia(0)=etot
 564 c detecting NaNQ
 565 #ifdef ISNAN
 566 #ifdef AIX
 567       if (isnan(etot).ne.0) energia(0)=1.0d+99
 568 #else
 569       if (isnan(etot)) energia(0)=1.0d+99
 570 #endif
 571 #else
 572       i=0
 573 #ifdef WINPGI
 574       idumm=proc_proc(etot,i)
 575 #else
 576       call proc_proc(etot,i)
 577 #endif
 578       if(i.eq.1)energia(0)=1.0d+99
 579 #endif
 580 #ifdef MPI
 581       endif
 582 #endif
 583       return
 584       end
 585 c-------------------------------------------------------------------------------
 586       subroutine sum_gradient
 587       implicit real*8 (a-h,o-z)
 588       include 'DIMENSIONS'
 589 #ifndef ISNAN
 590       external proc_proc
 591 #ifdef WINPGI
 592 cMS$ATTRIBUTES C ::  proc_proc
 593 #endif
 594 #endif
 595 #ifdef MPI
 596       include 'mpif.h'
 597 #endif
 598       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 599      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 600      & ,gloc_scbuf(3,-1:maxres)
 601       include 'COMMON.SETUP'
 602       include 'COMMON.IOUNITS'
 603       include 'COMMON.FFIELD'
 604       include 'COMMON.DERIV'
 605       include 'COMMON.INTERACT'
 606       include 'COMMON.SBRIDGE'
 607       include 'COMMON.CHAIN'
 608       include 'COMMON.VAR'
 609       include 'COMMON.CONTROL'
 610       include 'COMMON.TIME1'
 611       include 'COMMON.MAXGRAD'
 612       include 'COMMON.SCCOR'
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616 #ifdef DEBUG
 617       write (iout,*) "sum_gradient gvdwc, gvdwx"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 620      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef MPI
 625 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 626         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 627      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 628 #endif
 629 C
 630 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 631 C            in virtual-bond-vector coordinates
 632 C
 633 #ifdef DEBUG
 634 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 635 c      do i=1,nres-1
 636 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 637 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 638 c      enddo
 639 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 640 c      do i=1,nres-1
 641 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 642 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 643 c      enddo
 644       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 645       do i=1,nres
 646         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 647      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 648      &   g_corr5_loc(i)
 649       enddo
 650       call flush(iout)
 651 #endif
 652 #ifdef SPLITELE
 653       do i=0,nct
 654         do j=1,3
 655           gradbufc(j,i)=wsc*gvdwc(j,i)+
 656      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 657      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 658      &                wel_loc*gel_loc_long(j,i)+
 659      &                wcorr*gradcorr_long(j,i)+
 660      &                wcorr5*gradcorr5_long(j,i)+
 661      &                wcorr6*gradcorr6_long(j,i)+
 662      &                wturn6*gcorr6_turn_long(j,i)+
 663      &                wstrain*ghpbc(j,i)
 664      &                +wliptran*gliptranc(j,i)
 665      &                +gradafm(j,i)
 666      &                 +welec*gshieldc(j,i)
 667      &                 +wcorr*gshieldc_ec(j,i)
 668      &                 +wturn3*gshieldc_t3(j,i)
 669      &                 +wturn4*gshieldc_t4(j,i)
 670      &                 +wel_loc*gshieldc_ll(j,i)
 671      &                +wtube*gg_tube(j,i)
 672
 673
 674
 675         enddo
 676       enddo
 677 C      j=1
 678 C      i=0
 679 C      print *,"KUPA2",gradbufc(j,i),wsc*gvdwc(j,i),
 680 C     &                wscp*gvdwc_scp(j,i),gvdwc_scpp(j,i),
 681 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 682 C     &                wel_loc*gel_loc_long(j,i),
 683 C     &                wcorr*gradcorr_long(j,i),
 684 C     &                wcorr5*gradcorr5_long(j,i),
 685 C     &                wcorr6*gradcorr6_long(j,i),
 686 C     &                wturn6*gcorr6_turn_long(j,i),
 687 C     &                wstrain*ghpbc(j,i)
 688 C     &                ,wliptran*gliptranc(j,i)
 689 C     &                ,gradafm(j,i)
 690 C     &                 ,welec*gshieldc(j,i)
 691 C     &                 ,wcorr*gshieldc_ec(j,i)
 692 C     &                 ,wturn3*gshieldc_t3(j,i)
 693 C     &                 ,wturn4*gshieldc_t4(j,i)
 694 C     &                 ,wel_loc*gshieldc_ll(j,i)
 695 C     &                ,wtube*gg_tube(j,i)
 696 #else
 697       do i=0,nct
 698         do j=1,3
 699           gradbufc(j,i)=wsc*gvdwc(j,i)+
 700      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 701      &                welec*gelc_long(j,i)+
 702      &                wbond*gradb(j,i)+
 703      &                wel_loc*gel_loc_long(j,i)+
 704      &                wcorr*gradcorr_long(j,i)+
 705      &                wcorr5*gradcorr5_long(j,i)+
 706      &                wcorr6*gradcorr6_long(j,i)+
 707      &                wturn6*gcorr6_turn_long(j,i)+
 708      &                wstrain*ghpbc(j,i)
 709      &                +wliptran*gliptranc(j,i)
 710      &                +gradafm(j,i)
 711      &                 +welec*gshieldc(j,i)
 712      &                 +wcorr*gshieldc_ec(j,i)
 713      &                 +wturn4*gshieldc_t4(j,i)
 714      &                 +wel_loc*gshieldc_ll(j,i)
 715      &                +wtube*gg_tube(j,i)
 716
 717
 718
 719         enddo
 720       enddo
 721 #endif
 722 #ifdef MPI
 723       if (nfgtasks.gt.1) then
 724       time00=MPI_Wtime()
 725 #ifdef DEBUG
 726       write (iout,*) "gradbufc before allreduce"
 727       do i=1,nres
 728         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 729       enddo
 730       call flush(iout)
 731 #endif
 732       do i=0,nres
 733         do j=1,3
 734           gradbufc_sum(j,i)=gradbufc(j,i)
 735         enddo
 736       enddo
 737 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 738 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 739 c      time_reduce=time_reduce+MPI_Wtime()-time00
 740 #ifdef DEBUG
 741 c      write (iout,*) "gradbufc_sum after allreduce"
 742 c      do i=1,nres
 743 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 744 c      enddo
 745 c      call flush(iout)
 746 #endif
 747 #ifdef TIMING
 748 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 749 #endif
 750       do i=0,nres
 751         do k=1,3
 752           gradbufc(k,i)=0.0d0
 753         enddo
 754       enddo
 755 #ifdef DEBUG
 756       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 757       write (iout,*) (i," jgrad_start",jgrad_start(i),
 758      &                  " jgrad_end  ",jgrad_end(i),
 759      &                  i=igrad_start,igrad_end)
 760 #endif
 761 c
 762 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 763 c do not parallelize this part.
 764 c
 765 c      do i=igrad_start,igrad_end
 766 c        do j=jgrad_start(i),jgrad_end(i)
 767 c          do k=1,3
 768 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 769 c          enddo
 770 c        enddo
 771 c      enddo
 772       do j=1,3
 773         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 774       enddo
 775       do i=nres-2,-1,-1
 776         do j=1,3
 777           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 778         enddo
 779       enddo
 780 #ifdef DEBUG
 781       write (iout,*) "gradbufc after summing"
 782       do i=1,nres
 783         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 784       enddo
 785       call flush(iout)
 786 #endif
 787       else
 788 #endif
 789 #ifdef DEBUG
 790       write (iout,*) "gradbufc"
 791       do i=1,nres
 792         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 793       enddo
 794       call flush(iout)
 795 #endif
 796       do i=-1,nres
 797         do j=1,3
 798           gradbufc_sum(j,i)=gradbufc(j,i)
 799           gradbufc(j,i)=0.0d0
 800         enddo
 801       enddo
 802       do j=1,3
 803         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 804       enddo
 805       do i=nres-2,-1,-1
 806         do j=1,3
 807           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 808         enddo
 809       enddo
 810 c      do i=nnt,nres-1
 811 c        do k=1,3
 812 c          gradbufc(k,i)=0.0d0
 813 c        enddo
 814 c        do j=i+1,nres
 815 c          do k=1,3
 816 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 817 c          enddo
 818 c        enddo
 819 c      enddo
 820 #ifdef DEBUG
 821       write (iout,*) "gradbufc after summing"
 822       do i=1,nres
 823         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 824       enddo
 825       call flush(iout)
 826 #endif
 827 #ifdef MPI
 828       endif
 829 #endif
 830       do k=1,3
 831         gradbufc(k,nres)=0.0d0
 832       enddo
 833       do i=-1,nct
 834         do j=1,3
 835 #ifdef SPLITELE
 836 C          print *,gradbufc(1,13)
 837 C          print *,welec*gelc(1,13)
 838 C          print *,wel_loc*gel_loc(1,13)
 839 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 840 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 841 C          print *,wel_loc*gel_loc_long(1,13)
 842 C          print *,gradafm(1,13),"AFM"
 843           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 844      &                wel_loc*gel_loc(j,i)+
 845      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 846      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 847      &                wel_loc*gel_loc_long(j,i)+
 848      &                wcorr*gradcorr_long(j,i)+
 849      &                wcorr5*gradcorr5_long(j,i)+
 850      &                wcorr6*gradcorr6_long(j,i)+
 851      &                wturn6*gcorr6_turn_long(j,i))+
 852      &                wbond*gradb(j,i)+
 853      &                wcorr*gradcorr(j,i)+
 854      &                wturn3*gcorr3_turn(j,i)+
 855      &                wturn4*gcorr4_turn(j,i)+
 856      &                wcorr5*gradcorr5(j,i)+
 857      &                wcorr6*gradcorr6(j,i)+
 858      &                wturn6*gcorr6_turn(j,i)+
 859      &                wsccor*gsccorc(j,i)
 860      &               +wscloc*gscloc(j,i)
 861      &               +wliptran*gliptranc(j,i)
 862      &                +gradafm(j,i)
 863      &                 +welec*gshieldc(j,i)
 864      &                 +welec*gshieldc_loc(j,i)
 865      &                 +wcorr*gshieldc_ec(j,i)
 866      &                 +wcorr*gshieldc_loc_ec(j,i)
 867      &                 +wturn3*gshieldc_t3(j,i)
 868      &                 +wturn3*gshieldc_loc_t3(j,i)
 869      &                 +wturn4*gshieldc_t4(j,i)
 870      &                 +wturn4*gshieldc_loc_t4(j,i)
 871      &                 +wel_loc*gshieldc_ll(j,i)
 872      &                 +wel_loc*gshieldc_loc_ll(j,i)
 873      &                +wtube*gg_tube(j,i)
 874
 875 #else
 876           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 877      &                wel_loc*gel_loc(j,i)+
 878      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 879      &                welec*gelc_long(j,i)+
 880      &                wel_loc*gel_loc_long(j,i)+
 881      &                wcorr*gcorr_long(j,i)+
 882      &                wcorr5*gradcorr5_long(j,i)+
 883      &                wcorr6*gradcorr6_long(j,i)+
 884      &                wturn6*gcorr6_turn_long(j,i))+
 885      &                wbond*gradb(j,i)+
 886      &                wcorr*gradcorr(j,i)+
 887      &                wturn3*gcorr3_turn(j,i)+
 888      &                wturn4*gcorr4_turn(j,i)+
 889      &                wcorr5*gradcorr5(j,i)+
 890      &                wcorr6*gradcorr6(j,i)+
 891      &                wturn6*gcorr6_turn(j,i)+
 892      &                wsccor*gsccorc(j,i)
 893      &               +wscloc*gscloc(j,i)
 894      &               +wliptran*gliptranc(j,i)
 895      &                +gradafm(j,i)
 896      &                 +welec*gshieldc(j,i)
 897      &                 +welec*gshieldc_loc(j,i)
 898      &                 +wcorr*gshieldc_ec(j,i)
 899      &                 +wcorr*gshieldc_loc_ec(j,i)
 900      &                 +wturn3*gshieldc_t3(j,i)
 901      &                 +wturn3*gshieldc_loc_t3(j,i)
 902      &                 +wturn4*gshieldc_t4(j,i)
 903      &                 +wturn4*gshieldc_loc_t4(j,i)
 904      &                 +wel_loc*gshieldc_ll(j,i)
 905      &                 +wel_loc*gshieldc_loc_ll(j,i)
 906      &                +wtube*gg_tube(j,i)
 907
 908
 909 #endif
 910           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 911      &                  wbond*gradbx(j,i)+
 912      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 913      &                  wsccor*gsccorx(j,i)
 914      &                 +wscloc*gsclocx(j,i)
 915      &                 +wliptran*gliptranx(j,i)
 916      &                 +welec*gshieldx(j,i)
 917      &                 +wcorr*gshieldx_ec(j,i)
 918      &                 +wturn3*gshieldx_t3(j,i)
 919      &                 +wturn4*gshieldx_t4(j,i)
 920      &                 +wel_loc*gshieldx_ll(j,i)
 921      &                 +wtube*gg_tube_sc(j,i)
 922
 923
 924
 925         enddo
 926       enddo
 927 C       i=0
 928 C       j=1
 929 C       print *,"KUPA",    gradbufc(j,i),welec*gelc(j,i),
 930 C     &                wel_loc*gel_loc(j,i),
 931 C     &                0.5d0*wscp*gvdwc_scpp(j,i),
 932 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 933 C     &                wel_loc*gel_loc_long(j,i),
 934 C     &                wcorr*gradcorr_long(j,i),
 935 C     &                wcorr5*gradcorr5_long(j,i),
 936 C     &                wcorr6*gradcorr6_long(j,i),
 937 C     &                wturn6*gcorr6_turn_long(j,i),
 938 C     &                wbond*gradb(j,i),
 939 C     &                wcorr*gradcorr(j,i),
 940 C     &                wturn3*gcorr3_turn(j,i),
 941 C     &                wturn4*gcorr4_turn(j,i),
 942 C     &                wcorr5*gradcorr5(j,i),
 943 C     &                wcorr6*gradcorr6(j,i),
 944 C     &                wturn6*gcorr6_turn(j,i),
 945 C     &                wsccor*gsccorc(j,i)
 946 C     &               ,wscloc*gscloc(j,i)
 947 C     &               ,wliptran*gliptranc(j,i)
 948 C     &                ,gradafm(j,i)
 949 C     &                 +welec*gshieldc(j,i)
 950 C     &                 +welec*gshieldc_loc(j,i)
 951 C     &                 +wcorr*gshieldc_ec(j,i)
 952 C     &                 +wcorr*gshieldc_loc_ec(j,i)
 953 C     &                 +wturn3*gshieldc_t3(j,i)
 954 C     &                 +wturn3*gshieldc_loc_t3(j,i)
 955 C     &                 +wturn4*gshieldc_t4(j,i)
 956 C     &                 ,wturn4*gshieldc_loc_t4(j,i)
 957 C     &                 ,wel_loc*gshieldc_ll(j,i)
 958 C     &                 ,wel_loc*gshieldc_loc_ll(j,i)
 959 C     &                ,wtube*gg_tube(j,i)
 960
 961 C      print *,gg_tube(1,0),"TU3"
 962 #ifdef DEBUG
 963       write (iout,*) "gloc before adding corr"
 964       do i=1,4*nres
 965         write (iout,*) i,gloc(i,icg)
 966       enddo
 967 #endif
 968       do i=1,nres-3
 969         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 970      &   +wcorr5*g_corr5_loc(i)
 971      &   +wcorr6*g_corr6_loc(i)
 972      &   +wturn4*gel_loc_turn4(i)
 973      &   +wturn3*gel_loc_turn3(i)
 974      &   +wturn6*gel_loc_turn6(i)
 975      &   +wel_loc*gel_loc_loc(i)
 976       enddo
 977 #ifdef DEBUG
 978       write (iout,*) "gloc after adding corr"
 979       do i=1,4*nres
 980         write (iout,*) i,gloc(i,icg)
 981       enddo
 982 #endif
 983 #ifdef MPI
 984       if (nfgtasks.gt.1) then
 985         do j=1,3
 986           do i=1,nres
 987             gradbufc(j,i)=gradc(j,i,icg)
 988             gradbufx(j,i)=gradx(j,i,icg)
 989           enddo
 990         enddo
 991         do i=1,4*nres
 992           glocbuf(i)=gloc(i,icg)
 993         enddo
 994 c#define DEBUG
 995 #ifdef DEBUG
 996       write (iout,*) "gloc_sc before reduce"
 997       do i=1,nres
 998        do j=1,1
 999         write (iout,*) i,j,gloc_sc(j,i,icg)
1000        enddo
1001       enddo
1002 #endif
1003 c#undef DEBUG
1004         do i=1,nres
1005          do j=1,3
1006           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1007          enddo
1008         enddo
1009         time00=MPI_Wtime()
1010         call MPI_Barrier(FG_COMM,IERR)
1011         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1012         time00=MPI_Wtime()
1013         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,
1014      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1015         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1016      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1017         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1018      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019         time_reduce=time_reduce+MPI_Wtime()-time00
1020         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1021      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1022         time_reduce=time_reduce+MPI_Wtime()-time00
1023 c#define DEBUG
1024 #ifdef DEBUG
1025       write (iout,*) "gloc_sc after reduce"
1026       do i=1,nres
1027        do j=1,1
1028         write (iout,*) i,j,gloc_sc(j,i,icg)
1029        enddo
1030       enddo
1031 #endif
1032 c#undef DEBUG
1033 #ifdef DEBUG
1034       write (iout,*) "gloc after reduce"
1035       do i=1,4*nres
1036         write (iout,*) i,gloc(i,icg)
1037       enddo
1038 #endif
1039       endif
1040 #endif
1041       if (gnorm_check) then
1042 c
1043 c Compute the maximum elements of the gradient
1044 c
1045       gvdwc_max=0.0d0
1046       gvdwc_scp_max=0.0d0
1047       gelc_max=0.0d0
1048       gvdwpp_max=0.0d0
1049       gradb_max=0.0d0
1050       ghpbc_max=0.0d0
1051       gradcorr_max=0.0d0
1052       gel_loc_max=0.0d0
1053       gcorr3_turn_max=0.0d0
1054       gcorr4_turn_max=0.0d0
1055       gradcorr5_max=0.0d0
1056       gradcorr6_max=0.0d0
1057       gcorr6_turn_max=0.0d0
1058       gsccorc_max=0.0d0
1059       gscloc_max=0.0d0
1060       gvdwx_max=0.0d0
1061       gradx_scp_max=0.0d0
1062       ghpbx_max=0.0d0
1063       gradxorr_max=0.0d0
1064       gsccorx_max=0.0d0
1065       gsclocx_max=0.0d0
1066       do i=1,nct
1067         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1068         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1069         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1070         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1071      &   gvdwc_scp_max=gvdwc_scp_norm
1072         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1073         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1074         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1075         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1076         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1077         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1078         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1079         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1080         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1081         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1082         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1083         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1084         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1085      &    gcorr3_turn(1,i)))
1086         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1087      &    gcorr3_turn_max=gcorr3_turn_norm
1088         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1089      &    gcorr4_turn(1,i)))
1090         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1091      &    gcorr4_turn_max=gcorr4_turn_norm
1092         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1093         if (gradcorr5_norm.gt.gradcorr5_max)
1094      &    gradcorr5_max=gradcorr5_norm
1095         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1096         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1097         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1098      &    gcorr6_turn(1,i)))
1099         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1100      &    gcorr6_turn_max=gcorr6_turn_norm
1101         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1102         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1103         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1104         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1105         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1106         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1107         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1108         if (gradx_scp_norm.gt.gradx_scp_max)
1109      &    gradx_scp_max=gradx_scp_norm
1110         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1111         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1112         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1113         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1114         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1115         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1116         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1117         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1118       enddo
1119       if (gradout) then
1120 #ifdef AIX
1121         open(istat,file=statname,position="append")
1122 #else
1123         open(istat,file=statname,access="append")
1124 #endif
1125         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1126      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1127      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1128      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1129      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1130      &     gsccorx_max,gsclocx_max
1131         close(istat)
1132         if (gvdwc_max.gt.1.0d4) then
1133           write (iout,*) "gvdwc gvdwx gradb gradbx"
1134           do i=nnt,nct
1135             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1136      &        gradb(j,i),gradbx(j,i),j=1,3)
1137           enddo
1138           call pdbout(0.0d0,'cipiszcze',iout)
1139           call flush(iout)
1140         endif
1141       endif
1142       endif
1143 #ifdef DEBUG
1144       write (iout,*) "gradc gradx gloc"
1145       do i=1,nres
1146         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1147      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1148       enddo
1149 #endif
1150 #ifdef TIMING
1151       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1152 #endif
1153       return
1154       end
1155 c-------------------------------------------------------------------------------
1156       subroutine rescale_weights(t_bath)
1157       implicit real*8 (a-h,o-z)
1158       include 'DIMENSIONS'
1159       include 'COMMON.IOUNITS'
1160       include 'COMMON.FFIELD'
1161       include 'COMMON.SBRIDGE'
1162       include 'COMMON.CONTROL'
1163       double precision kfac /2.4d0/
1164       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1165 c      facT=temp0/t_bath
1166 c      facT=2*temp0/(t_bath+temp0)
1167       if (rescale_mode.eq.0) then
1168         facT=1.0d0
1169         facT2=1.0d0
1170         facT3=1.0d0
1171         facT4=1.0d0
1172         facT5=1.0d0
1173       else if (rescale_mode.eq.1) then
1174         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1175         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1176         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1177         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1178         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1179       else if (rescale_mode.eq.2) then
1180         x=t_bath/temp0
1181         x2=x*x
1182         x3=x2*x
1183         x4=x3*x
1184         x5=x4*x
1185         facT=licznik/dlog(dexp(x)+dexp(-x))
1186         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1187         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1188         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1189         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1190       else
1191         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1192         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1193 #ifdef MPI
1194        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1195 #endif
1196        stop 555
1197       endif
1198       if (shield_mode.gt.0) then
1199        wscp=weights(2)*fact
1200        wsc=weights(1)*fact
1201        wvdwpp=weights(16)*fact
1202       endif
1203       welec=weights(3)*fact
1204       wcorr=weights(4)*fact3
1205       wcorr5=weights(5)*fact4
1206       wcorr6=weights(6)*fact5
1207       wel_loc=weights(7)*fact2
1208       wturn3=weights(8)*fact2
1209       wturn4=weights(9)*fact3
1210       wturn6=weights(10)*fact5
1211       wtor=weights(13)*fact
1212       wtor_d=weights(14)*fact2
1213       wsccor=weights(21)*fact
1214
1215       return
1216       end
1217 C------------------------------------------------------------------------
1218       subroutine enerprint(energia)
1219       implicit real*8 (a-h,o-z)
1220       include 'DIMENSIONS'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.FFIELD'
1223       include 'COMMON.SBRIDGE'
1224       include 'COMMON.MD'
1225       double precision energia(0:n_ene)
1226       etot=energia(0)
1227       evdw=energia(1)
1228       evdw2=energia(2)
1229 #ifdef SCP14
1230       evdw2=energia(2)+energia(18)
1231 #else
1232       evdw2=energia(2)
1233 #endif
1234       ees=energia(3)
1235 #ifdef SPLITELE
1236       evdw1=energia(16)
1237 #endif
1238       ecorr=energia(4)
1239       ecorr5=energia(5)
1240       ecorr6=energia(6)
1241       eel_loc=energia(7)
1242       eello_turn3=energia(8)
1243       eello_turn4=energia(9)
1244       eello_turn6=energia(10)
1245       ebe=energia(11)
1246       escloc=energia(12)
1247       etors=energia(13)
1248       etors_d=energia(14)
1249       ehpb=energia(15)
1250       edihcnstr=energia(19)
1251       estr=energia(17)
1252       Uconst=energia(20)
1253       esccor=energia(21)
1254       eliptran=energia(22)
1255       Eafmforce=energia(23)
1256       ethetacnstr=energia(24)
1257       etube=energia(25)
1258 #ifdef SPLITELE
1259       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1260      &  estr,wbond,ebe,wang,
1261      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1262      &  ecorr,wcorr,
1263      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1264      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1265      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1266      &  etube,wtube,
1267      &  etot
1268    10 format (/'Virtual-chain energies:'//
1269      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1270      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1271      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1272      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1273      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1274      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1275      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1276      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1277      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1278      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1279      & ' (SS bridges & dist. cnstr.)'/
1280      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1281      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1282      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1283      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1284      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1285      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1286      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1287      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1288      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1289      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1290      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1291      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1292      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1293      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1294      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1295      & 'ETOT=  ',1pE16.6,' (total)')
1296
1297 #else
1298       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1299      &  estr,wbond,ebe,wang,
1300      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1301      &  ecorr,wcorr,
1302      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1303      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1304      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1305      &  etube,wtube,
1306      &  etot
1307    10 format (/'Virtual-chain energies:'//
1308      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1309      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1310      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1311      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1312      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1313      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1314      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1315      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1316      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1317      & ' (SS bridges & dist. cnstr.)'/
1318      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1319      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1320      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1321      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1322      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1323      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1324      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1325      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1326      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1327      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1328      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1329      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1330      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1331      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1332      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1333      & 'ETOT=  ',1pE16.6,' (total)')
1334 #endif
1335       return
1336       end
1337 C-----------------------------------------------------------------------
1338       subroutine elj(evdw)
1339 C
1340 C This subroutine calculates the interaction energy of nonbonded side chains
1341 C assuming the LJ potential of interaction.
1342 C
1343       implicit real*8 (a-h,o-z)
1344       include 'DIMENSIONS'
1345       parameter (accur=1.0d-10)
1346       include 'COMMON.GEO'
1347       include 'COMMON.VAR'
1348       include 'COMMON.LOCAL'
1349       include 'COMMON.CHAIN'
1350       include 'COMMON.DERIV'
1351       include 'COMMON.INTERACT'
1352       include 'COMMON.TORSION'
1353       include 'COMMON.SBRIDGE'
1354       include 'COMMON.NAMES'
1355       include 'COMMON.IOUNITS'
1356       include 'COMMON.CONTACTS'
1357       dimension gg(3)
1358 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1359       evdw=0.0D0
1360       do i=iatsc_s,iatsc_e
1361         itypi=iabs(itype(i))
1362         if (itypi.eq.ntyp1) cycle
1363         itypi1=iabs(itype(i+1))
1364         xi=c(1,nres+i)
1365         yi=c(2,nres+i)
1366         zi=c(3,nres+i)
1367 C Change 12/1/95
1368         num_conti=0
1369 C
1370 C Calculate SC interaction energy.
1371 C
1372         do iint=1,nint_gr(i)
1373 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1374 cd   &                  'iend=',iend(i,iint)
1375           do j=istart(i,iint),iend(i,iint)
1376             itypj=iabs(itype(j))
1377             if (itypj.eq.ntyp1) cycle
1378             xj=c(1,nres+j)-xi
1379             yj=c(2,nres+j)-yi
1380             zj=c(3,nres+j)-zi
1381 C Change 12/1/95 to calculate four-body interactions
1382             rij=xj*xj+yj*yj+zj*zj
1383             rrij=1.0D0/rij
1384 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1385             eps0ij=eps(itypi,itypj)
1386             fac=rrij**expon2
1387 C have you changed here?
1388             e1=fac*fac*aa
1389             e2=fac*bb
1390             evdwij=e1+e2
1391 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1392 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1393 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1394 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1395 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1396 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1397             evdw=evdw+evdwij
1398 C
1399 C Calculate the components of the gradient in DC and X
1400 C
1401             fac=-rrij*(e1+evdwij)
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405             do k=1,3
1406               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1410             enddo
1411 cgrad            do k=i,j-1
1412 cgrad              do l=1,3
1413 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1414 cgrad              enddo
1415 cgrad            enddo
1416 C
1417 C 12/1/95, revised on 5/20/97
1418 C
1419 C Calculate the contact function. The ith column of the array JCONT will
1420 C contain the numbers of atoms that make contacts with the atom I (of numbers
1421 C greater than I). The arrays FACONT and GACONT will contain the values of
1422 C the contact function and its derivative.
1423 C
1424 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1425 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1426 C Uncomment next line, if the correlation interactions are contact function only
1427             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1428               rij=dsqrt(rij)
1429               sigij=sigma(itypi,itypj)
1430               r0ij=rs0(itypi,itypj)
1431 C
1432 C Check whether the SC's are not too far to make a contact.
1433 C
1434               rcut=1.5d0*r0ij
1435               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1436 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1437 C
1438               if (fcont.gt.0.0D0) then
1439 C If the SC-SC distance if close to sigma, apply spline.
1440 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1441 cAdam &             fcont1,fprimcont1)
1442 cAdam           fcont1=1.0d0-fcont1
1443 cAdam           if (fcont1.gt.0.0d0) then
1444 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1445 cAdam             fcont=fcont*fcont1
1446 cAdam           endif
1447 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1448 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1449 cga             do k=1,3
1450 cga               gg(k)=gg(k)*eps0ij
1451 cga             enddo
1452 cga             eps0ij=-evdwij*eps0ij
1453 C Uncomment for AL's type of SC correlation interactions.
1454 cadam           eps0ij=-evdwij
1455                 num_conti=num_conti+1
1456                 jcont(num_conti,i)=j
1457                 facont(num_conti,i)=fcont*eps0ij
1458                 fprimcont=eps0ij*fprimcont/rij
1459                 fcont=expon*fcont
1460 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1461 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1462 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1463 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1464                 gacont(1,num_conti,i)=-fprimcont*xj
1465                 gacont(2,num_conti,i)=-fprimcont*yj
1466                 gacont(3,num_conti,i)=-fprimcont*zj
1467 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1468 cd              write (iout,'(2i3,3f10.5)')
1469 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1470               endif
1471             endif
1472           enddo      ! j
1473         enddo        ! iint
1474 C Change 12/1/95
1475         num_cont(i)=num_conti
1476       enddo          ! i
1477       do i=1,nct
1478         do j=1,3
1479           gvdwc(j,i)=expon*gvdwc(j,i)
1480           gvdwx(j,i)=expon*gvdwx(j,i)
1481         enddo
1482       enddo
1483 C******************************************************************************
1484 C
1485 C                              N O T E !!!
1486 C
1487 C To save time, the factor of EXPON has been extracted from ALL components
1488 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1489 C use!
1490 C
1491 C******************************************************************************
1492       return
1493       end
1494 C-----------------------------------------------------------------------------
1495       subroutine eljk(evdw)
1496 C
1497 C This subroutine calculates the interaction energy of nonbonded side chains
1498 C assuming the LJK potential of interaction.
1499 C
1500       implicit real*8 (a-h,o-z)
1501       include 'DIMENSIONS'
1502       include 'COMMON.GEO'
1503       include 'COMMON.VAR'
1504       include 'COMMON.LOCAL'
1505       include 'COMMON.CHAIN'
1506       include 'COMMON.DERIV'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.NAMES'
1510       dimension gg(3)
1511       logical scheck
1512 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1513       evdw=0.0D0
1514       do i=iatsc_s,iatsc_e
1515         itypi=iabs(itype(i))
1516         if (itypi.eq.ntyp1) cycle
1517         itypi1=iabs(itype(i+1))
1518         xi=c(1,nres+i)
1519         yi=c(2,nres+i)
1520         zi=c(3,nres+i)
1521 C
1522 C Calculate SC interaction energy.
1523 C
1524         do iint=1,nint_gr(i)
1525           do j=istart(i,iint),iend(i,iint)
1526             itypj=iabs(itype(j))
1527             if (itypj.eq.ntyp1) cycle
1528             xj=c(1,nres+j)-xi
1529             yj=c(2,nres+j)-yi
1530             zj=c(3,nres+j)-zi
1531             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532             fac_augm=rrij**expon
1533             e_augm=augm(itypi,itypj)*fac_augm
1534             r_inv_ij=dsqrt(rrij)
1535             rij=1.0D0/r_inv_ij
1536             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1537             fac=r_shift_inv**expon
1538 C have you changed here?
1539             e1=fac*fac*aa
1540             e2=fac*bb
1541             evdwij=e_augm+e1+e2
1542 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1543 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1544 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1545 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1546 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1547 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1548 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1549             evdw=evdw+evdwij
1550 C
1551 C Calculate the components of the gradient in DC and X
1552 C
1553             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557             do k=1,3
1558               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1559               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1561               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1562             enddo
1563 cgrad            do k=i,j-1
1564 cgrad              do l=1,3
1565 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1566 cgrad              enddo
1567 cgrad            enddo
1568           enddo      ! j
1569         enddo        ! iint
1570       enddo          ! i
1571       do i=1,nct
1572         do j=1,3
1573           gvdwc(j,i)=expon*gvdwc(j,i)
1574           gvdwx(j,i)=expon*gvdwx(j,i)
1575         enddo
1576       enddo
1577       return
1578       end
1579 C-----------------------------------------------------------------------------
1580       subroutine ebp(evdw)
1581 C
1582 C This subroutine calculates the interaction energy of nonbonded side chains
1583 C assuming the Berne-Pechukas potential of interaction.
1584 C
1585       implicit real*8 (a-h,o-z)
1586       include 'DIMENSIONS'
1587       include 'COMMON.GEO'
1588       include 'COMMON.VAR'
1589       include 'COMMON.LOCAL'
1590       include 'COMMON.CHAIN'
1591       include 'COMMON.DERIV'
1592       include 'COMMON.NAMES'
1593       include 'COMMON.INTERACT'
1594       include 'COMMON.IOUNITS'
1595       include 'COMMON.CALC'
1596       common /srutu/ icall
1597 c     double precision rrsave(maxdim)
1598       logical lprn
1599       evdw=0.0D0
1600 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1601       evdw=0.0D0
1602 c     if (icall.eq.0) then
1603 c       lprn=.true.
1604 c     else
1605         lprn=.false.
1606 c     endif
1607       ind=0
1608       do i=iatsc_s,iatsc_e
1609         itypi=iabs(itype(i))
1610         if (itypi.eq.ntyp1) cycle
1611         itypi1=iabs(itype(i+1))
1612         xi=c(1,nres+i)
1613         yi=c(2,nres+i)
1614         zi=c(3,nres+i)
1615         dxi=dc_norm(1,nres+i)
1616         dyi=dc_norm(2,nres+i)
1617         dzi=dc_norm(3,nres+i)
1618 c        dsci_inv=dsc_inv(itypi)
1619         dsci_inv=vbld_inv(i+nres)
1620 C
1621 C Calculate SC interaction energy.
1622 C
1623         do iint=1,nint_gr(i)
1624           do j=istart(i,iint),iend(i,iint)
1625             ind=ind+1
1626             itypj=iabs(itype(j))
1627             if (itypj.eq.ntyp1) cycle
1628 c            dscj_inv=dsc_inv(itypj)
1629             dscj_inv=vbld_inv(j+nres)
1630             chi1=chi(itypi,itypj)
1631             chi2=chi(itypj,itypi)
1632             chi12=chi1*chi2
1633             chip1=chip(itypi)
1634             chip2=chip(itypj)
1635             chip12=chip1*chip2
1636             alf1=alp(itypi)
1637             alf2=alp(itypj)
1638             alf12=0.5D0*(alf1+alf2)
1639 C For diagnostics only!!!
1640 c           chi1=0.0D0
1641 c           chi2=0.0D0
1642 c           chi12=0.0D0
1643 c           chip1=0.0D0
1644 c           chip2=0.0D0
1645 c           chip12=0.0D0
1646 c           alf1=0.0D0
1647 c           alf2=0.0D0
1648 c           alf12=0.0D0
1649             xj=c(1,nres+j)-xi
1650             yj=c(2,nres+j)-yi
1651             zj=c(3,nres+j)-zi
1652             dxj=dc_norm(1,nres+j)
1653             dyj=dc_norm(2,nres+j)
1654             dzj=dc_norm(3,nres+j)
1655             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1656 cd          if (icall.eq.0) then
1657 cd            rrsave(ind)=rrij
1658 cd          else
1659 cd            rrij=rrsave(ind)
1660 cd          endif
1661             rij=dsqrt(rrij)
1662 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1663             call sc_angular
1664 C Calculate whole angle-dependent part of epsilon and contributions
1665 C to its derivatives
1666 C have you changed here?
1667             fac=(rrij*sigsq)**expon2
1668             e1=fac*fac*aa
1669             e2=fac*bb
1670             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1671             eps2der=evdwij*eps3rt
1672             eps3der=evdwij*eps2rt
1673             evdwij=evdwij*eps2rt*eps3rt
1674             evdw=evdw+evdwij
1675             if (lprn) then
1676             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1677             epsi=bb**2/aa
1678 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1679 cd     &        restyp(itypi),i,restyp(itypj),j,
1680 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1681 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1682 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1683 cd     &        evdwij
1684             endif
1685 C Calculate gradient components.
1686             e1=e1*eps1*eps2rt**2*eps3rt**2
1687             fac=-expon*(e1+evdwij)
1688             sigder=fac/sigsq
1689             fac=rrij*fac
1690 C Calculate radial part of the gradient
1691             gg(1)=xj*fac
1692             gg(2)=yj*fac
1693             gg(3)=zj*fac
1694 C Calculate the angular part of the gradient and sum add the contributions
1695 C to the appropriate components of the Cartesian gradient.
1696             call sc_grad
1697           enddo      ! j
1698         enddo        ! iint
1699       enddo          ! i
1700 c     stop
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egb(evdw)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       include 'COMMON.CONTROL'
1721       include 'COMMON.SPLITELE'
1722       include 'COMMON.SBRIDGE'
1723       logical lprn
1724       integer xshift,yshift,zshift
1725
1726       evdw=0.0D0
1727 ccccc      energy_dec=.false.
1728 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1729       evdw=0.0D0
1730       lprn=.false.
1731 c     if (icall.eq.0) lprn=.false.
1732       ind=0
1733 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1734 C we have the original box)
1735 C      do xshift=-1,1
1736 C      do yshift=-1,1
1737 C      do zshift=-1,1
1738       do i=iatsc_s,iatsc_e
1739         itypi=iabs(itype(i))
1740         if (itypi.eq.ntyp1) cycle
1741         itypi1=iabs(itype(i+1))
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745 C Return atom into box, boxxsize is size of box in x dimension
1746 c  134   continue
1747 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1748 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1749 C Condition for being inside the proper box
1750 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1751 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1752 c        go to 134
1753 c        endif
1754 c  135   continue
1755 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1756 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1757 C Condition for being inside the proper box
1758 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1759 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1760 c        go to 135
1761 c        endif
1762 c  136   continue
1763 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1764 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1765 C Condition for being inside the proper box
1766 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1767 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1768 c        go to 136
1769 c        endif
1770           xi=mod(xi,boxxsize)
1771           if (xi.lt.0) xi=xi+boxxsize
1772           yi=mod(yi,boxysize)
1773           if (yi.lt.0) yi=yi+boxysize
1774           zi=mod(zi,boxzsize)
1775           if (zi.lt.0) zi=zi+boxzsize
1776 C define scaling factor for lipids
1777
1778 C        if (positi.le.0) positi=positi+boxzsize
1779 C        print *,i
1780 C first for peptide groups
1781 c for each residue check if it is in lipid or lipid water border area
1782        if ((zi.gt.bordlipbot)
1783      &.and.(zi.lt.bordliptop)) then
1784 C the energy transfer exist
1785         if (zi.lt.buflipbot) then
1786 C what fraction I am in
1787          fracinbuf=1.0d0-
1788      &        ((zi-bordlipbot)/lipbufthick)
1789 C lipbufthick is thickenes of lipid buffore
1790          sslipi=sscalelip(fracinbuf)
1791          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1792         elseif (zi.gt.bufliptop) then
1793          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1794          sslipi=sscalelip(fracinbuf)
1795          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1796         else
1797          sslipi=1.0d0
1798          ssgradlipi=0.0
1799         endif
1800        else
1801          sslipi=0.0d0
1802          ssgradlipi=0.0
1803        endif
1804
1805 C          xi=xi+xshift*boxxsize
1806 C          yi=yi+yshift*boxysize
1807 C          zi=zi+zshift*boxzsize
1808
1809         dxi=dc_norm(1,nres+i)
1810         dyi=dc_norm(2,nres+i)
1811         dzi=dc_norm(3,nres+i)
1812 c        dsci_inv=dsc_inv(itypi)
1813         dsci_inv=vbld_inv(i+nres)
1814 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1815 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1816 C
1817 C Calculate SC interaction energy.
1818 C
1819         do iint=1,nint_gr(i)
1820           do j=istart(i,iint),iend(i,iint)
1821             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1822
1823 c              write(iout,*) "PRZED ZWYKLE", evdwij
1824               call dyn_ssbond_ene(i,j,evdwij)
1825 c              write(iout,*) "PO ZWYKLE", evdwij
1826
1827               evdw=evdw+evdwij
1828               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1829      &                        'evdw',i,j,evdwij,' ss'
1830 C triple bond artifac removal
1831              do k=j+1,iend(i,iint)
1832 C search over all next residues
1833               if (dyn_ss_mask(k)) then
1834 C check if they are cysteins
1835 C              write(iout,*) 'k=',k
1836
1837 c              write(iout,*) "PRZED TRI", evdwij
1838                evdwij_przed_tri=evdwij
1839               call triple_ssbond_ene(i,j,k,evdwij)
1840 c               if(evdwij_przed_tri.ne.evdwij) then
1841 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1842 c               endif
1843
1844 c              write(iout,*) "PO TRI", evdwij
1845 C call the energy function that removes the artifical triple disulfide
1846 C bond the soubroutine is located in ssMD.F
1847               evdw=evdw+evdwij
1848               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1849      &                        'evdw',i,j,evdwij,'tss'
1850               endif!dyn_ss_mask(k)
1851              enddo! k
1852             ELSE
1853             ind=ind+1
1854             itypj=iabs(itype(j))
1855             if (itypj.eq.ntyp1) cycle
1856 c            dscj_inv=dsc_inv(itypj)
1857             dscj_inv=vbld_inv(j+nres)
1858 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1859 c     &       1.0d0/vbld(j+nres)
1860 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1861             sig0ij=sigma(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881             xj=c(1,nres+j)
1882             yj=c(2,nres+j)
1883             zj=c(3,nres+j)
1884 C Return atom J into box the original box
1885 c  137   continue
1886 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1887 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1888 C Condition for being inside the proper box
1889 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1890 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1891 c        go to 137
1892 c        endif
1893 c  138   continue
1894 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1895 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1896 C Condition for being inside the proper box
1897 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1898 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1899 c        go to 138
1900 c        endif
1901 c  139   continue
1902 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1903 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1904 C Condition for being inside the proper box
1905 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1906 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1907 c        go to 139
1908 c        endif
1909           xj=mod(xj,boxxsize)
1910           if (xj.lt.0) xj=xj+boxxsize
1911           yj=mod(yj,boxysize)
1912           if (yj.lt.0) yj=yj+boxysize
1913           zj=mod(zj,boxzsize)
1914           if (zj.lt.0) zj=zj+boxzsize
1915        if ((zj.gt.bordlipbot)
1916      &.and.(zj.lt.bordliptop)) then
1917 C the energy transfer exist
1918         if (zj.lt.buflipbot) then
1919 C what fraction I am in
1920          fracinbuf=1.0d0-
1921      &        ((zj-bordlipbot)/lipbufthick)
1922 C lipbufthick is thickenes of lipid buffore
1923          sslipj=sscalelip(fracinbuf)
1924          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925         elseif (zj.gt.bufliptop) then
1926          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927          sslipj=sscalelip(fracinbuf)
1928          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1929         else
1930          sslipj=1.0d0
1931          ssgradlipj=0.0
1932         endif
1933        else
1934          sslipj=0.0d0
1935          ssgradlipj=0.0
1936        endif
1937       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1940      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1942 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1943 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1944 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1945 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1946       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1947       xj_safe=xj
1948       yj_safe=yj
1949       zj_safe=zj
1950       subchap=0
1951       do xshift=-1,1
1952       do yshift=-1,1
1953       do zshift=-1,1
1954           xj=xj_safe+xshift*boxxsize
1955           yj=yj_safe+yshift*boxysize
1956           zj=zj_safe+zshift*boxzsize
1957           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1958           if(dist_temp.lt.dist_init) then
1959             dist_init=dist_temp
1960             xj_temp=xj
1961             yj_temp=yj
1962             zj_temp=zj
1963             subchap=1
1964           endif
1965        enddo
1966        enddo
1967        enddo
1968        if (subchap.eq.1) then
1969           xj=xj_temp-xi
1970           yj=yj_temp-yi
1971           zj=zj_temp-zi
1972        else
1973           xj=xj_safe-xi
1974           yj=yj_safe-yi
1975           zj=zj_safe-zi
1976        endif
1977             dxj=dc_norm(1,nres+j)
1978             dyj=dc_norm(2,nres+j)
1979             dzj=dc_norm(3,nres+j)
1980 C            xj=xj-xi
1981 C            yj=yj-yi
1982 C            zj=zj-zi
1983 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1984 c            write (iout,*) "j",j," dc_norm",
1985 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1986             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1987             rij=dsqrt(rrij)
1988             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1989             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1990
1991 c            write (iout,'(a7,4f8.3)')
1992 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1993             if (sss.gt.0.0d0) then
1994 C Calculate angle-dependent terms of energy and contributions to their
1995 C derivatives.
1996             call sc_angular
1997             sigsq=1.0D0/sigsq
1998             sig=sig0ij*dsqrt(sigsq)
1999             rij_shift=1.0D0/rij-sig+sig0ij
2000 c for diagnostics; uncomment
2001 c            rij_shift=1.2*sig0ij
2002 C I hate to put IF's in the loops, but here don't have another choice!!!!
2003             if (rij_shift.le.0.0D0) then
2004               evdw=1.0D20
2005 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2006 cd     &        restyp(itypi),i,restyp(itypj),j,
2007 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2008               return
2009             endif
2010             sigder=-sig*sigsq
2011 c---------------------------------------------------------------
2012             rij_shift=1.0D0/rij_shift
2013             fac=rij_shift**expon
2014 C here to start with
2015 C            if (c(i,3).gt.
2016             faclip=fac
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2023 C     &((sslipi+sslipj)/2.0d0+
2024 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2025 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2026 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2027             evdwij=evdwij*eps2rt*eps3rt
2028             evdw=evdw+evdwij*sss
2029             if (lprn) then
2030             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2031             epsi=bb**2/aa
2032             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2033      &        restyp(itypi),i,restyp(itypj),j,
2034      &        epsi,sigm,chi1,chi2,chip1,chip2,
2035      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2036      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2037      &        evdwij
2038             endif
2039
2040             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2041      &                        'evdw',i,j,evdwij
2042
2043 C Calculate gradient components.
2044             e1=e1*eps1*eps2rt**2*eps3rt**2
2045             fac=-expon*(e1+evdwij)*rij_shift
2046             sigder=fac*sigder
2047             fac=rij*fac
2048 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2049 c     &      evdwij,fac,sigma(itypi,itypj),expon
2050             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2051 c            fac=0.0d0
2052 C Calculate the radial part of the gradient
2053             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2054      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2055      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2056      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2057             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2058             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2059 C            gg_lipi(3)=0.0d0
2060 C            gg_lipj(3)=0.0d0
2061             gg(1)=xj*fac
2062             gg(2)=yj*fac
2063             gg(3)=zj*fac
2064 C Calculate angular part of the gradient.
2065             call sc_grad
2066             endif
2067             ENDIF    ! dyn_ss
2068           enddo      ! j
2069         enddo        ! iint
2070       enddo          ! i
2071 C      enddo          ! zshift
2072 C      enddo          ! yshift
2073 C      enddo          ! xshift
2074 c      write (iout,*) "Number of loop steps in EGB:",ind
2075 cccc      energy_dec=.false.
2076       return
2077       end
2078 C-----------------------------------------------------------------------------
2079       subroutine egbv(evdw)
2080 C
2081 C This subroutine calculates the interaction energy of nonbonded side chains
2082 C assuming the Gay-Berne-Vorobjev potential of interaction.
2083 C
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.GEO'
2087       include 'COMMON.VAR'
2088       include 'COMMON.LOCAL'
2089       include 'COMMON.CHAIN'
2090       include 'COMMON.DERIV'
2091       include 'COMMON.NAMES'
2092       include 'COMMON.INTERACT'
2093       include 'COMMON.IOUNITS'
2094       include 'COMMON.CALC'
2095       common /srutu/ icall
2096       logical lprn
2097       evdw=0.0D0
2098 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2099       evdw=0.0D0
2100       lprn=.false.
2101 c     if (icall.eq.0) lprn=.true.
2102       ind=0
2103       do i=iatsc_s,iatsc_e
2104         itypi=iabs(itype(i))
2105         if (itypi.eq.ntyp1) cycle
2106         itypi1=iabs(itype(i+1))
2107         xi=c(1,nres+i)
2108         yi=c(2,nres+i)
2109         zi=c(3,nres+i)
2110           xi=mod(xi,boxxsize)
2111           if (xi.lt.0) xi=xi+boxxsize
2112           yi=mod(yi,boxysize)
2113           if (yi.lt.0) yi=yi+boxysize
2114           zi=mod(zi,boxzsize)
2115           if (zi.lt.0) zi=zi+boxzsize
2116 C define scaling factor for lipids
2117
2118 C        if (positi.le.0) positi=positi+boxzsize
2119 C        print *,i
2120 C first for peptide groups
2121 c for each residue check if it is in lipid or lipid water border area
2122        if ((zi.gt.bordlipbot)
2123      &.and.(zi.lt.bordliptop)) then
2124 C the energy transfer exist
2125         if (zi.lt.buflipbot) then
2126 C what fraction I am in
2127          fracinbuf=1.0d0-
2128      &        ((zi-bordlipbot)/lipbufthick)
2129 C lipbufthick is thickenes of lipid buffore
2130          sslipi=sscalelip(fracinbuf)
2131          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2132         elseif (zi.gt.bufliptop) then
2133          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2134          sslipi=sscalelip(fracinbuf)
2135          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2136         else
2137          sslipi=1.0d0
2138          ssgradlipi=0.0
2139         endif
2140        else
2141          sslipi=0.0d0
2142          ssgradlipi=0.0
2143        endif
2144
2145         dxi=dc_norm(1,nres+i)
2146         dyi=dc_norm(2,nres+i)
2147         dzi=dc_norm(3,nres+i)
2148 c        dsci_inv=dsc_inv(itypi)
2149         dsci_inv=vbld_inv(i+nres)
2150 C
2151 C Calculate SC interaction energy.
2152 C
2153         do iint=1,nint_gr(i)
2154           do j=istart(i,iint),iend(i,iint)
2155             ind=ind+1
2156             itypj=iabs(itype(j))
2157             if (itypj.eq.ntyp1) cycle
2158 c            dscj_inv=dsc_inv(itypj)
2159             dscj_inv=vbld_inv(j+nres)
2160             sig0ij=sigma(itypi,itypj)
2161             r0ij=r0(itypi,itypj)
2162             chi1=chi(itypi,itypj)
2163             chi2=chi(itypj,itypi)
2164             chi12=chi1*chi2
2165             chip1=chip(itypi)
2166             chip2=chip(itypj)
2167             chip12=chip1*chip2
2168             alf1=alp(itypi)
2169             alf2=alp(itypj)
2170             alf12=0.5D0*(alf1+alf2)
2171 C For diagnostics only!!!
2172 c           chi1=0.0D0
2173 c           chi2=0.0D0
2174 c           chi12=0.0D0
2175 c           chip1=0.0D0
2176 c           chip2=0.0D0
2177 c           chip12=0.0D0
2178 c           alf1=0.0D0
2179 c           alf2=0.0D0
2180 c           alf12=0.0D0
2181 C            xj=c(1,nres+j)-xi
2182 C            yj=c(2,nres+j)-yi
2183 C            zj=c(3,nres+j)-zi
2184           xj=mod(xj,boxxsize)
2185           if (xj.lt.0) xj=xj+boxxsize
2186           yj=mod(yj,boxysize)
2187           if (yj.lt.0) yj=yj+boxysize
2188           zj=mod(zj,boxzsize)
2189           if (zj.lt.0) zj=zj+boxzsize
2190        if ((zj.gt.bordlipbot)
2191      &.and.(zj.lt.bordliptop)) then
2192 C the energy transfer exist
2193         if (zj.lt.buflipbot) then
2194 C what fraction I am in
2195          fracinbuf=1.0d0-
2196      &        ((zj-bordlipbot)/lipbufthick)
2197 C lipbufthick is thickenes of lipid buffore
2198          sslipj=sscalelip(fracinbuf)
2199          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2200         elseif (zj.gt.bufliptop) then
2201          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2202          sslipj=sscalelip(fracinbuf)
2203          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2204         else
2205          sslipj=1.0d0
2206          ssgradlipj=0.0
2207         endif
2208        else
2209          sslipj=0.0d0
2210          ssgradlipj=0.0
2211        endif
2212       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2213      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2214       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2215      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2216 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2217 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2218 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2219       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2220       xj_safe=xj
2221       yj_safe=yj
2222       zj_safe=zj
2223       subchap=0
2224       do xshift=-1,1
2225       do yshift=-1,1
2226       do zshift=-1,1
2227           xj=xj_safe+xshift*boxxsize
2228           yj=yj_safe+yshift*boxysize
2229           zj=zj_safe+zshift*boxzsize
2230           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2231           if(dist_temp.lt.dist_init) then
2232             dist_init=dist_temp
2233             xj_temp=xj
2234             yj_temp=yj
2235             zj_temp=zj
2236             subchap=1
2237           endif
2238        enddo
2239        enddo
2240        enddo
2241        if (subchap.eq.1) then
2242           xj=xj_temp-xi
2243           yj=yj_temp-yi
2244           zj=zj_temp-zi
2245        else
2246           xj=xj_safe-xi
2247           yj=yj_safe-yi
2248           zj=zj_safe-zi
2249        endif
2250             dxj=dc_norm(1,nres+j)
2251             dyj=dc_norm(2,nres+j)
2252             dzj=dc_norm(3,nres+j)
2253             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2254             rij=dsqrt(rrij)
2255 C Calculate angle-dependent terms of energy and contributions to their
2256 C derivatives.
2257             call sc_angular
2258             sigsq=1.0D0/sigsq
2259             sig=sig0ij*dsqrt(sigsq)
2260             rij_shift=1.0D0/rij-sig+r0ij
2261 C I hate to put IF's in the loops, but here don't have another choice!!!!
2262             if (rij_shift.le.0.0D0) then
2263               evdw=1.0D20
2264               return
2265             endif
2266             sigder=-sig*sigsq
2267 c---------------------------------------------------------------
2268             rij_shift=1.0D0/rij_shift
2269             fac=rij_shift**expon
2270             e1=fac*fac*aa
2271             e2=fac*bb
2272             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2273             eps2der=evdwij*eps3rt
2274             eps3der=evdwij*eps2rt
2275             fac_augm=rrij**expon
2276             e_augm=augm(itypi,itypj)*fac_augm
2277             evdwij=evdwij*eps2rt*eps3rt
2278             evdw=evdw+evdwij+e_augm
2279             if (lprn) then
2280             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2281             epsi=bb**2/aa
2282             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2283      &        restyp(itypi),i,restyp(itypj),j,
2284      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2285      &        chi1,chi2,chip1,chip2,
2286      &        eps1,eps2rt**2,eps3rt**2,
2287      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2288      &        evdwij+e_augm
2289             endif
2290 C Calculate gradient components.
2291             e1=e1*eps1*eps2rt**2*eps3rt**2
2292             fac=-expon*(e1+evdwij)*rij_shift
2293             sigder=fac*sigder
2294             fac=rij*fac-2*expon*rrij*e_augm
2295             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2296 C Calculate the radial part of the gradient
2297             gg(1)=xj*fac
2298             gg(2)=yj*fac
2299             gg(3)=zj*fac
2300 C Calculate angular part of the gradient.
2301             call sc_grad
2302           enddo      ! j
2303         enddo        ! iint
2304       enddo          ! i
2305       end
2306 C-----------------------------------------------------------------------------
2307       subroutine sc_angular
2308 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2309 C om12. Called by ebp, egb, and egbv.
2310       implicit none
2311       include 'COMMON.CALC'
2312       include 'COMMON.IOUNITS'
2313       erij(1)=xj*rij
2314       erij(2)=yj*rij
2315       erij(3)=zj*rij
2316       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2317       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2318       om12=dxi*dxj+dyi*dyj+dzi*dzj
2319       chiom12=chi12*om12
2320 C Calculate eps1(om12) and its derivative in om12
2321       faceps1=1.0D0-om12*chiom12
2322       faceps1_inv=1.0D0/faceps1
2323       eps1=dsqrt(faceps1_inv)
2324 C Following variable is eps1*deps1/dom12
2325       eps1_om12=faceps1_inv*chiom12
2326 c diagnostics only
2327 c      faceps1_inv=om12
2328 c      eps1=om12
2329 c      eps1_om12=1.0d0
2330 c      write (iout,*) "om12",om12," eps1",eps1
2331 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2332 C and om12.
2333       om1om2=om1*om2
2334       chiom1=chi1*om1
2335       chiom2=chi2*om2
2336       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2337       sigsq=1.0D0-facsig*faceps1_inv
2338       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2339       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2340       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2341 c diagnostics only
2342 c      sigsq=1.0d0
2343 c      sigsq_om1=0.0d0
2344 c      sigsq_om2=0.0d0
2345 c      sigsq_om12=0.0d0
2346 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2347 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2348 c     &    " eps1",eps1
2349 C Calculate eps2 and its derivatives in om1, om2, and om12.
2350       chipom1=chip1*om1
2351       chipom2=chip2*om2
2352       chipom12=chip12*om12
2353       facp=1.0D0-om12*chipom12
2354       facp_inv=1.0D0/facp
2355       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2356 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2357 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2358 C Following variable is the square root of eps2
2359       eps2rt=1.0D0-facp1*facp_inv
2360 C Following three variables are the derivatives of the square root of eps
2361 C in om1, om2, and om12.
2362       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2363       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2364       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2365 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2366       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2367 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2368 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2369 c     &  " eps2rt_om12",eps2rt_om12
2370 C Calculate whole angle-dependent part of epsilon and contributions
2371 C to its derivatives
2372       return
2373       end
2374 C----------------------------------------------------------------------------
2375       subroutine sc_grad
2376       implicit real*8 (a-h,o-z)
2377       include 'DIMENSIONS'
2378       include 'COMMON.CHAIN'
2379       include 'COMMON.DERIV'
2380       include 'COMMON.CALC'
2381       include 'COMMON.IOUNITS'
2382       double precision dcosom1(3),dcosom2(3)
2383 cc      print *,'sss=',sss
2384       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2385       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2386       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2387      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2388 c diagnostics only
2389 c      eom1=0.0d0
2390 c      eom2=0.0d0
2391 c      eom12=evdwij*eps1_om12
2392 c end diagnostics
2393 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2394 c     &  " sigder",sigder
2395 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2396 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2397       do k=1,3
2398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2400       enddo
2401       do k=1,3
2402         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2403       enddo
2404 c      write (iout,*) "gg",(gg(k),k=1,3)
2405       do k=1,3
2406         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2407      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2409         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2410      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2411      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2412 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2413 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2414 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2415 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2416       enddo
2417 C
2418 C Calculate the components of the gradient in DC and X
2419 C
2420 cgrad      do k=i,j-1
2421 cgrad        do l=1,3
2422 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2423 cgrad        enddo
2424 cgrad      enddo
2425       do l=1,3
2426         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2427         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2428       enddo
2429       return
2430       end
2431 C-----------------------------------------------------------------------
2432       subroutine e_softsphere(evdw)
2433 C
2434 C This subroutine calculates the interaction energy of nonbonded side chains
2435 C assuming the LJ potential of interaction.
2436 C
2437       implicit real*8 (a-h,o-z)
2438       include 'DIMENSIONS'
2439       parameter (accur=1.0d-10)
2440       include 'COMMON.GEO'
2441       include 'COMMON.VAR'
2442       include 'COMMON.LOCAL'
2443       include 'COMMON.CHAIN'
2444       include 'COMMON.DERIV'
2445       include 'COMMON.INTERACT'
2446       include 'COMMON.TORSION'
2447       include 'COMMON.SBRIDGE'
2448       include 'COMMON.NAMES'
2449       include 'COMMON.IOUNITS'
2450       include 'COMMON.CONTACTS'
2451       dimension gg(3)
2452 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2453       evdw=0.0D0
2454       do i=iatsc_s,iatsc_e
2455         itypi=iabs(itype(i))
2456         if (itypi.eq.ntyp1) cycle
2457         itypi1=iabs(itype(i+1))
2458         xi=c(1,nres+i)
2459         yi=c(2,nres+i)
2460         zi=c(3,nres+i)
2461 C
2462 C Calculate SC interaction energy.
2463 C
2464         do iint=1,nint_gr(i)
2465 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd   &                  'iend=',iend(i,iint)
2467           do j=istart(i,iint),iend(i,iint)
2468             itypj=iabs(itype(j))
2469             if (itypj.eq.ntyp1) cycle
2470             xj=c(1,nres+j)-xi
2471             yj=c(2,nres+j)-yi
2472             zj=c(3,nres+j)-zi
2473             rij=xj*xj+yj*yj+zj*zj
2474 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475             r0ij=r0(itypi,itypj)
2476             r0ijsq=r0ij*r0ij
2477 c            print *,i,j,r0ij,dsqrt(rij)
2478             if (rij.lt.r0ijsq) then
2479               evdwij=0.25d0*(rij-r0ijsq)**2
2480               fac=rij-r0ijsq
2481             else
2482               evdwij=0.0d0
2483               fac=0.0d0
2484             endif
2485             evdw=evdw+evdwij
2486 C
2487 C Calculate the components of the gradient in DC and X
2488 C
2489             gg(1)=xj*fac
2490             gg(2)=yj*fac
2491             gg(3)=zj*fac
2492             do k=1,3
2493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2497             enddo
2498 cgrad            do k=i,j-1
2499 cgrad              do l=1,3
2500 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2501 cgrad              enddo
2502 cgrad            enddo
2503           enddo ! j
2504         enddo ! iint
2505       enddo ! i
2506       return
2507       end
2508 C--------------------------------------------------------------------------
2509       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2510      &              eello_turn4)
2511 C
2512 C Soft-sphere potential of p-p interaction
2513 C
2514       implicit real*8 (a-h,o-z)
2515       include 'DIMENSIONS'
2516       include 'COMMON.CONTROL'
2517       include 'COMMON.IOUNITS'
2518       include 'COMMON.GEO'
2519       include 'COMMON.VAR'
2520       include 'COMMON.LOCAL'
2521       include 'COMMON.CHAIN'
2522       include 'COMMON.DERIV'
2523       include 'COMMON.INTERACT'
2524       include 'COMMON.CONTACTS'
2525       include 'COMMON.TORSION'
2526       include 'COMMON.VECTORS'
2527       include 'COMMON.FFIELD'
2528       dimension ggg(3)
2529 C      write(iout,*) 'In EELEC_soft_sphere'
2530       ees=0.0D0
2531       evdw1=0.0D0
2532       eel_loc=0.0d0
2533       eello_turn3=0.0d0
2534       eello_turn4=0.0d0
2535       ind=0
2536       do i=iatel_s,iatel_e
2537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2538         dxi=dc(1,i)
2539         dyi=dc(2,i)
2540         dzi=dc(3,i)
2541         xmedi=c(1,i)+0.5d0*dxi
2542         ymedi=c(2,i)+0.5d0*dyi
2543         zmedi=c(3,i)+0.5d0*dzi
2544           xmedi=mod(xmedi,boxxsize)
2545           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2546           ymedi=mod(ymedi,boxysize)
2547           if (ymedi.lt.0) ymedi=ymedi+boxysize
2548           zmedi=mod(zmedi,boxzsize)
2549           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2550         num_conti=0
2551 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2552         do j=ielstart(i),ielend(i)
2553           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2554           ind=ind+1
2555           iteli=itel(i)
2556           itelj=itel(j)
2557           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2558           r0ij=rpp(iteli,itelj)
2559           r0ijsq=r0ij*r0ij
2560           dxj=dc(1,j)
2561           dyj=dc(2,j)
2562           dzj=dc(3,j)
2563           xj=c(1,j)+0.5D0*dxj
2564           yj=c(2,j)+0.5D0*dyj
2565           zj=c(3,j)+0.5D0*dzj
2566           xj=mod(xj,boxxsize)
2567           if (xj.lt.0) xj=xj+boxxsize
2568           yj=mod(yj,boxysize)
2569           if (yj.lt.0) yj=yj+boxysize
2570           zj=mod(zj,boxzsize)
2571           if (zj.lt.0) zj=zj+boxzsize
2572       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2573       xj_safe=xj
2574       yj_safe=yj
2575       zj_safe=zj
2576       isubchap=0
2577       do xshift=-1,1
2578       do yshift=-1,1
2579       do zshift=-1,1
2580           xj=xj_safe+xshift*boxxsize
2581           yj=yj_safe+yshift*boxysize
2582           zj=zj_safe+zshift*boxzsize
2583           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2584           if(dist_temp.lt.dist_init) then
2585             dist_init=dist_temp
2586             xj_temp=xj
2587             yj_temp=yj
2588             zj_temp=zj
2589             isubchap=1
2590           endif
2591        enddo
2592        enddo
2593        enddo
2594        if (isubchap.eq.1) then
2595           xj=xj_temp-xmedi
2596           yj=yj_temp-ymedi
2597           zj=zj_temp-zmedi
2598        else
2599           xj=xj_safe-xmedi
2600           yj=yj_safe-ymedi
2601           zj=zj_safe-zmedi
2602        endif
2603           rij=xj*xj+yj*yj+zj*zj
2604             sss=sscale(sqrt(rij))
2605             sssgrad=sscagrad(sqrt(rij))
2606           if (rij.lt.r0ijsq) then
2607             evdw1ij=0.25d0*(rij-r0ijsq)**2
2608             fac=rij-r0ijsq
2609           else
2610             evdw1ij=0.0d0
2611             fac=0.0d0
2612           endif
2613           evdw1=evdw1+evdw1ij*sss
2614 C
2615 C Calculate contributions to the Cartesian gradient.
2616 C
2617           ggg(1)=fac*xj*sssgrad
2618           ggg(2)=fac*yj*sssgrad
2619           ggg(3)=fac*zj*sssgrad
2620           do k=1,3
2621             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2622             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2623           enddo
2624 *
2625 * Loop over residues i+1 thru j-1.
2626 *
2627 cgrad          do k=i+1,j-1
2628 cgrad            do l=1,3
2629 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2630 cgrad            enddo
2631 cgrad          enddo
2632         enddo ! j
2633       enddo   ! i
2634 cgrad      do i=nnt,nct-1
2635 cgrad        do k=1,3
2636 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2637 cgrad        enddo
2638 cgrad        do j=i+1,nct-1
2639 cgrad          do k=1,3
2640 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2641 cgrad          enddo
2642 cgrad        enddo
2643 cgrad      enddo
2644       return
2645       end
2646 c------------------------------------------------------------------------------
2647       subroutine vec_and_deriv
2648       implicit real*8 (a-h,o-z)
2649       include 'DIMENSIONS'
2650 #ifdef MPI
2651       include 'mpif.h'
2652 #endif
2653       include 'COMMON.IOUNITS'
2654       include 'COMMON.GEO'
2655       include 'COMMON.VAR'
2656       include 'COMMON.LOCAL'
2657       include 'COMMON.CHAIN'
2658       include 'COMMON.VECTORS'
2659       include 'COMMON.SETUP'
2660       include 'COMMON.TIME1'
2661       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2662 C Compute the local reference systems. For reference system (i), the
2663 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2664 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2665 #ifdef PARVEC
2666       do i=ivec_start,ivec_end
2667 #else
2668       do i=1,nres-1
2669 #endif
2670           if (i.eq.nres-1) then
2671 C Case of the last full residue
2672 C Compute the Z-axis
2673             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2674             costh=dcos(pi-theta(nres))
2675             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2676             do k=1,3
2677               uz(k,i)=fac*uz(k,i)
2678             enddo
2679 C Compute the derivatives of uz
2680             uzder(1,1,1)= 0.0d0
2681             uzder(2,1,1)=-dc_norm(3,i-1)
2682             uzder(3,1,1)= dc_norm(2,i-1)
2683             uzder(1,2,1)= dc_norm(3,i-1)
2684             uzder(2,2,1)= 0.0d0
2685             uzder(3,2,1)=-dc_norm(1,i-1)
2686             uzder(1,3,1)=-dc_norm(2,i-1)
2687             uzder(2,3,1)= dc_norm(1,i-1)
2688             uzder(3,3,1)= 0.0d0
2689             uzder(1,1,2)= 0.0d0
2690             uzder(2,1,2)= dc_norm(3,i)
2691             uzder(3,1,2)=-dc_norm(2,i)
2692             uzder(1,2,2)=-dc_norm(3,i)
2693             uzder(2,2,2)= 0.0d0
2694             uzder(3,2,2)= dc_norm(1,i)
2695             uzder(1,3,2)= dc_norm(2,i)
2696             uzder(2,3,2)=-dc_norm(1,i)
2697             uzder(3,3,2)= 0.0d0
2698 C Compute the Y-axis
2699             facy=fac
2700             do k=1,3
2701               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2702             enddo
2703 C Compute the derivatives of uy
2704             do j=1,3
2705               do k=1,3
2706                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2707      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2708                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2709               enddo
2710               uyder(j,j,1)=uyder(j,j,1)-costh
2711               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2712             enddo
2713             do j=1,2
2714               do k=1,3
2715                 do l=1,3
2716                   uygrad(l,k,j,i)=uyder(l,k,j)
2717                   uzgrad(l,k,j,i)=uzder(l,k,j)
2718                 enddo
2719               enddo
2720             enddo
2721             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2722             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2723             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2724             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2725           else
2726 C Other residues
2727 C Compute the Z-axis
2728             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2729             costh=dcos(pi-theta(i+2))
2730             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2731             do k=1,3
2732               uz(k,i)=fac*uz(k,i)
2733             enddo
2734 C Compute the derivatives of uz
2735             uzder(1,1,1)= 0.0d0
2736             uzder(2,1,1)=-dc_norm(3,i+1)
2737             uzder(3,1,1)= dc_norm(2,i+1)
2738             uzder(1,2,1)= dc_norm(3,i+1)
2739             uzder(2,2,1)= 0.0d0
2740             uzder(3,2,1)=-dc_norm(1,i+1)
2741             uzder(1,3,1)=-dc_norm(2,i+1)
2742             uzder(2,3,1)= dc_norm(1,i+1)
2743             uzder(3,3,1)= 0.0d0
2744             uzder(1,1,2)= 0.0d0
2745             uzder(2,1,2)= dc_norm(3,i)
2746             uzder(3,1,2)=-dc_norm(2,i)
2747             uzder(1,2,2)=-dc_norm(3,i)
2748             uzder(2,2,2)= 0.0d0
2749             uzder(3,2,2)= dc_norm(1,i)
2750             uzder(1,3,2)= dc_norm(2,i)
2751             uzder(2,3,2)=-dc_norm(1,i)
2752             uzder(3,3,2)= 0.0d0
2753 C Compute the Y-axis
2754             facy=fac
2755             do k=1,3
2756               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2757             enddo
2758 C Compute the derivatives of uy
2759             do j=1,3
2760               do k=1,3
2761                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2762      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2763                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2764               enddo
2765               uyder(j,j,1)=uyder(j,j,1)-costh
2766               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2767             enddo
2768             do j=1,2
2769               do k=1,3
2770                 do l=1,3
2771                   uygrad(l,k,j,i)=uyder(l,k,j)
2772                   uzgrad(l,k,j,i)=uzder(l,k,j)
2773                 enddo
2774               enddo
2775             enddo
2776             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2777             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2778             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2779             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2780           endif
2781       enddo
2782       do i=1,nres-1
2783         vbld_inv_temp(1)=vbld_inv(i+1)
2784         if (i.lt.nres-1) then
2785           vbld_inv_temp(2)=vbld_inv(i+2)
2786           else
2787           vbld_inv_temp(2)=vbld_inv(i)
2788           endif
2789         do j=1,2
2790           do k=1,3
2791             do l=1,3
2792               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2793               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2794             enddo
2795           enddo
2796         enddo
2797       enddo
2798 #if defined(PARVEC) && defined(MPI)
2799       if (nfgtasks1.gt.1) then
2800         time00=MPI_Wtime()
2801 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2802 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2803 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2804         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2811      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2812      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2813         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2814      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2815      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2816         time_gather=time_gather+MPI_Wtime()-time00
2817       endif
2818 c      if (fg_rank.eq.0) then
2819 c        write (iout,*) "Arrays UY and UZ"
2820 c        do i=1,nres-1
2821 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2822 c     &     (uz(k,i),k=1,3)
2823 c        enddo
2824 c      endif
2825 #endif
2826       return
2827       end
2828 C-----------------------------------------------------------------------------
2829       subroutine check_vecgrad
2830       implicit real*8 (a-h,o-z)
2831       include 'DIMENSIONS'
2832       include 'COMMON.IOUNITS'
2833       include 'COMMON.GEO'
2834       include 'COMMON.VAR'
2835       include 'COMMON.LOCAL'
2836       include 'COMMON.CHAIN'
2837       include 'COMMON.VECTORS'
2838       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2839       dimension uyt(3,maxres),uzt(3,maxres)
2840       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2841       double precision delta /1.0d-7/
2842       call vec_and_deriv
2843 cd      do i=1,nres
2844 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2845 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2846 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2847 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2848 cd     &     (dc_norm(if90,i),if90=1,3)
2849 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2850 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2851 cd          write(iout,'(a)')
2852 cd      enddo
2853       do i=1,nres
2854         do j=1,2
2855           do k=1,3
2856             do l=1,3
2857               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2858               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2859             enddo
2860           enddo
2861         enddo
2862       enddo
2863       call vec_and_deriv
2864       do i=1,nres
2865         do j=1,3
2866           uyt(j,i)=uy(j,i)
2867           uzt(j,i)=uz(j,i)
2868         enddo
2869       enddo
2870       do i=1,nres
2871 cd        write (iout,*) 'i=',i
2872         do k=1,3
2873           erij(k)=dc_norm(k,i)
2874         enddo
2875         do j=1,3
2876           do k=1,3
2877             dc_norm(k,i)=erij(k)
2878           enddo
2879           dc_norm(j,i)=dc_norm(j,i)+delta
2880 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2881 c          do k=1,3
2882 c            dc_norm(k,i)=dc_norm(k,i)/fac
2883 c          enddo
2884 c          write (iout,*) (dc_norm(k,i),k=1,3)
2885 c          write (iout,*) (erij(k),k=1,3)
2886           call vec_and_deriv
2887           do k=1,3
2888             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2889             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2890             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2891             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2892           enddo
2893 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2894 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2895 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2896         enddo
2897         do k=1,3
2898           dc_norm(k,i)=erij(k)
2899         enddo
2900 cd        do k=1,3
2901 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2902 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2903 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2904 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2905 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2906 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2907 cd          write (iout,'(a)')
2908 cd        enddo
2909       enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine set_matrices
2914       implicit real*8 (a-h,o-z)
2915       include 'DIMENSIONS'
2916 #ifdef MPI
2917       include "mpif.h"
2918       include "COMMON.SETUP"
2919       integer IERR
2920       integer status(MPI_STATUS_SIZE)
2921 #endif
2922       include 'COMMON.IOUNITS'
2923       include 'COMMON.GEO'
2924       include 'COMMON.VAR'
2925       include 'COMMON.LOCAL'
2926       include 'COMMON.CHAIN'
2927       include 'COMMON.DERIV'
2928       include 'COMMON.INTERACT'
2929       include 'COMMON.CONTACTS'
2930       include 'COMMON.TORSION'
2931       include 'COMMON.VECTORS'
2932       include 'COMMON.FFIELD'
2933       double precision auxvec(2),auxmat(2,2)
2934 C
2935 C Compute the virtual-bond-torsional-angle dependent quantities needed
2936 C to calculate the el-loc multibody terms of various order.
2937 C
2938 c      write(iout,*) 'nphi=',nphi,nres
2939 #ifdef PARMAT
2940       do i=ivec_start+2,ivec_end+2
2941 #else
2942       do i=3,nres+1
2943 #endif
2944 #ifdef NEWCORR
2945         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2946           iti = itype2loc(itype(i-2))
2947         else
2948           iti=nloctyp
2949         endif
2950 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2951         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2952           iti1 = itype2loc(itype(i-1))
2953         else
2954           iti1=nloctyp
2955         endif
2956 c        write(iout,*),i
2957         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2958      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2959      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2960         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2961      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2962      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2963 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2964 c     &*(cos(theta(i)/2.0)
2965         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2966      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2967      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2968 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2969 c     &*(cos(theta(i)/2.0)
2970         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2971      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2972      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2973 c        if (ggb1(1,i).eq.0.0d0) then
2974 c        write(iout,*) 'i=',i,ggb1(1,i),
2975 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2976 c     &bnew1(2,1,iti)*cos(theta(i)),
2977 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2978 c        endif
2979         b1(2,i-2)=bnew1(1,2,iti)
2980         gtb1(2,i-2)=0.0
2981         b2(2,i-2)=bnew2(1,2,iti)
2982         gtb2(2,i-2)=0.0
2983         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2984         EE(1,2,i-2)=eeold(1,2,iti)
2985         EE(2,1,i-2)=eeold(2,1,iti)
2986         EE(2,2,i-2)=eeold(2,2,iti)
2987         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2988         gtEE(1,2,i-2)=0.0d0
2989         gtEE(2,2,i-2)=0.0d0
2990         gtEE(2,1,i-2)=0.0d0
2991 c        EE(2,2,iti)=0.0d0
2992 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2993 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2994 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2995 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2996        b1tilde(1,i-2)=b1(1,i-2)
2997        b1tilde(2,i-2)=-b1(2,i-2)
2998        b2tilde(1,i-2)=b2(1,i-2)
2999        b2tilde(2,i-2)=-b2(2,i-2)
3000 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001 c       write(iout,*)  'b1=',b1(1,i-2)
3002 c       write (iout,*) 'theta=', theta(i-1)
3003        enddo
3004 #else
3005         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3006           iti = itype2loc(itype(i-2))
3007         else
3008           iti=nloctyp
3009         endif
3010 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3011         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3012           iti1 = itype2loc(itype(i-1))
3013         else
3014           iti1=nloctyp
3015         endif
3016         b1(1,i-2)=b(3,iti)
3017         b1(2,i-2)=b(5,iti)
3018         b2(1,i-2)=b(2,iti)
3019         b2(2,i-2)=b(4,iti)
3020        b1tilde(1,i-2)=b1(1,i-2)
3021        b1tilde(2,i-2)=-b1(2,i-2)
3022        b2tilde(1,i-2)=b2(1,i-2)
3023        b2tilde(2,i-2)=-b2(2,i-2)
3024         EE(1,2,i-2)=eeold(1,2,iti)
3025         EE(2,1,i-2)=eeold(2,1,iti)
3026         EE(2,2,i-2)=eeold(2,2,iti)
3027         EE(1,1,i-2)=eeold(1,1,iti)
3028       enddo
3029 #endif
3030 #ifdef PARMAT
3031       do i=ivec_start+2,ivec_end+2
3032 #else
3033       do i=3,nres+1
3034 #endif
3035         if (i .lt. nres+1) then
3036           sin1=dsin(phi(i))
3037           cos1=dcos(phi(i))
3038           sintab(i-2)=sin1
3039           costab(i-2)=cos1
3040           obrot(1,i-2)=cos1
3041           obrot(2,i-2)=sin1
3042           sin2=dsin(2*phi(i))
3043           cos2=dcos(2*phi(i))
3044           sintab2(i-2)=sin2
3045           costab2(i-2)=cos2
3046           obrot2(1,i-2)=cos2
3047           obrot2(2,i-2)=sin2
3048           Ug(1,1,i-2)=-cos1
3049           Ug(1,2,i-2)=-sin1
3050           Ug(2,1,i-2)=-sin1
3051           Ug(2,2,i-2)= cos1
3052           Ug2(1,1,i-2)=-cos2
3053           Ug2(1,2,i-2)=-sin2
3054           Ug2(2,1,i-2)=-sin2
3055           Ug2(2,2,i-2)= cos2
3056         else
3057           costab(i-2)=1.0d0
3058           sintab(i-2)=0.0d0
3059           obrot(1,i-2)=1.0d0
3060           obrot(2,i-2)=0.0d0
3061           obrot2(1,i-2)=0.0d0
3062           obrot2(2,i-2)=0.0d0
3063           Ug(1,1,i-2)=1.0d0
3064           Ug(1,2,i-2)=0.0d0
3065           Ug(2,1,i-2)=0.0d0
3066           Ug(2,2,i-2)=1.0d0
3067           Ug2(1,1,i-2)=0.0d0
3068           Ug2(1,2,i-2)=0.0d0
3069           Ug2(2,1,i-2)=0.0d0
3070           Ug2(2,2,i-2)=0.0d0
3071         endif
3072         if (i .gt. 3 .and. i .lt. nres+1) then
3073           obrot_der(1,i-2)=-sin1
3074           obrot_der(2,i-2)= cos1
3075           Ugder(1,1,i-2)= sin1
3076           Ugder(1,2,i-2)=-cos1
3077           Ugder(2,1,i-2)=-cos1
3078           Ugder(2,2,i-2)=-sin1
3079           dwacos2=cos2+cos2
3080           dwasin2=sin2+sin2
3081           obrot2_der(1,i-2)=-dwasin2
3082           obrot2_der(2,i-2)= dwacos2
3083           Ug2der(1,1,i-2)= dwasin2
3084           Ug2der(1,2,i-2)=-dwacos2
3085           Ug2der(2,1,i-2)=-dwacos2
3086           Ug2der(2,2,i-2)=-dwasin2
3087         else
3088           obrot_der(1,i-2)=0.0d0
3089           obrot_der(2,i-2)=0.0d0
3090           Ugder(1,1,i-2)=0.0d0
3091           Ugder(1,2,i-2)=0.0d0
3092           Ugder(2,1,i-2)=0.0d0
3093           Ugder(2,2,i-2)=0.0d0
3094           obrot2_der(1,i-2)=0.0d0
3095           obrot2_der(2,i-2)=0.0d0
3096           Ug2der(1,1,i-2)=0.0d0
3097           Ug2der(1,2,i-2)=0.0d0
3098           Ug2der(2,1,i-2)=0.0d0
3099           Ug2der(2,2,i-2)=0.0d0
3100         endif
3101 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3102         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103           iti = itype2loc(itype(i-2))
3104         else
3105           iti=nloctyp
3106         endif
3107 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3108         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3109           iti1 = itype2loc(itype(i-1))
3110         else
3111           iti1=nloctyp
3112         endif
3113 cd        write (iout,*) '*******i',i,' iti1',iti
3114 cd        write (iout,*) 'b1',b1(:,iti)
3115 cd        write (iout,*) 'b2',b2(:,iti)
3116 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3117 c        if (i .gt. iatel_s+2) then
3118         if (i .gt. nnt+2) then
3119           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3120 #ifdef NEWCORR
3121           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3122 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3123 #endif
3124 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3125 c     &    EE(1,2,iti),EE(2,2,i)
3126           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3127           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3128 c          write(iout,*) "Macierz EUG",
3129 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3130 c     &    eug(2,2,i-2)
3131           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3132      &    then
3133           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3134           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3135           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3136           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3137           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3138           endif
3139         else
3140           do k=1,2
3141             Ub2(k,i-2)=0.0d0
3142             Ctobr(k,i-2)=0.0d0
3143             Dtobr2(k,i-2)=0.0d0
3144             do l=1,2
3145               EUg(l,k,i-2)=0.0d0
3146               CUg(l,k,i-2)=0.0d0
3147               DUg(l,k,i-2)=0.0d0
3148               DtUg2(l,k,i-2)=0.0d0
3149             enddo
3150           enddo
3151         endif
3152         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3153         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3154         do k=1,2
3155           muder(k,i-2)=Ub2der(k,i-2)
3156         enddo
3157 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3158         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3159           if (itype(i-1).le.ntyp) then
3160             iti1 = itype2loc(itype(i-1))
3161           else
3162             iti1=nloctyp
3163           endif
3164         else
3165           iti1=nloctyp
3166         endif
3167         do k=1,2
3168           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3169         enddo
3170 #ifdef MUOUT
3171         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3172      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3173      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3174      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3175      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3176      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3177 #endif
3178 cd        write (iout,*) 'mu1',mu1(:,i-2)
3179 cd        write (iout,*) 'mu2',mu2(:,i-2)
3180         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3181      &  then
3182         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3183         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3184         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3185         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3186         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3187 C Vectors and matrices dependent on a single virtual-bond dihedral.
3188         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3189         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3190         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3191         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3192         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3193         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3194         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3195         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3196         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3197         endif
3198       enddo
3199 C Matrices dependent on two consecutive virtual-bond dihedrals.
3200 C The order of matrices is from left to right.
3201       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3202      &then
3203 c      do i=max0(ivec_start,2),ivec_end
3204       do i=2,nres-1
3205         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3206         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3207         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3208         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3209         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3210         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3211         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3212         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3213       enddo
3214       endif
3215 #if defined(MPI) && defined(PARMAT)
3216 #ifdef DEBUG
3217 c      if (fg_rank.eq.0) then
3218         write (iout,*) "Arrays UG and UGDER before GATHER"
3219         do i=1,nres-1
3220           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3221      &     ((ug(l,k,i),l=1,2),k=1,2),
3222      &     ((ugder(l,k,i),l=1,2),k=1,2)
3223         enddo
3224         write (iout,*) "Arrays UG2 and UG2DER"
3225         do i=1,nres-1
3226           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3227      &     ((ug2(l,k,i),l=1,2),k=1,2),
3228      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3229         enddo
3230         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3231         do i=1,nres-1
3232           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3233      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3234      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3235         enddo
3236         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3237         do i=1,nres-1
3238           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3239      &     costab(i),sintab(i),costab2(i),sintab2(i)
3240         enddo
3241         write (iout,*) "Array MUDER"
3242         do i=1,nres-1
3243           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3244         enddo
3245 c      endif
3246 #endif
3247       if (nfgtasks.gt.1) then
3248         time00=MPI_Wtime()
3249 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3250 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3251 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3252 #ifdef MATGATHER
3253         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3254      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3255      &   FG_COMM1,IERR)
3256         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3257      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3258      &   FG_COMM1,IERR)
3259         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3260      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3261      &   FG_COMM1,IERR)
3262         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3263      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3264      &   FG_COMM1,IERR)
3265         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3266      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3267      &   FG_COMM1,IERR)
3268         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3269      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3270      &   FG_COMM1,IERR)
3271         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3272      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3273      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3274         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3275      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3276      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3277         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3278      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3279      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3280         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3281      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3282      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3283         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3284      &  then
3285         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3292      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3293      &   FG_COMM1,IERR)
3294        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3295      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3296      &   FG_COMM1,IERR)
3297         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3298      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3299      &   FG_COMM1,IERR)
3300         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3301      &   ivec_count(fg_rank1),
3302      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3303      &   FG_COMM1,IERR)
3304         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3305      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3308      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3309      &   FG_COMM1,IERR)
3310         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3311      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3312      &   FG_COMM1,IERR)
3313         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3314      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3315      &   FG_COMM1,IERR)
3316         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3317      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3318      &   FG_COMM1,IERR)
3319         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3320      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3321      &   FG_COMM1,IERR)
3322         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3323      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3324      &   FG_COMM1,IERR)
3325         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3326      &   ivec_count(fg_rank1),
3327      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3331      &   FG_COMM1,IERR)
3332        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3337      &   FG_COMM1,IERR)
3338        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3342      &   ivec_count(fg_rank1),
3343      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3344      &   FG_COMM1,IERR)
3345         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3346      &   ivec_count(fg_rank1),
3347      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3348      &   FG_COMM1,IERR)
3349         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3350      &   ivec_count(fg_rank1),
3351      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3352      &   MPI_MAT2,FG_COMM1,IERR)
3353         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3354      &   ivec_count(fg_rank1),
3355      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3356      &   MPI_MAT2,FG_COMM1,IERR)
3357         endif
3358 #else
3359 c Passes matrix info through the ring
3360       isend=fg_rank1
3361       irecv=fg_rank1-1
3362       if (irecv.lt.0) irecv=nfgtasks1-1
3363       iprev=irecv
3364       inext=fg_rank1+1
3365       if (inext.ge.nfgtasks1) inext=0
3366       do i=1,nfgtasks1-1
3367 c        write (iout,*) "isend",isend," irecv",irecv
3368 c        call flush(iout)
3369         lensend=lentyp(isend)
3370         lenrecv=lentyp(irecv)
3371 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3372 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3373 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3374 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3375 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3376 c        write (iout,*) "Gather ROTAT1"
3377 c        call flush(iout)
3378 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3379 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3380 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3381 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3382 c        write (iout,*) "Gather ROTAT2"
3383 c        call flush(iout)
3384         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3385      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3386      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3387      &   iprev,4400+irecv,FG_COMM,status,IERR)
3388 c        write (iout,*) "Gather ROTAT_OLD"
3389 c        call flush(iout)
3390         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3391      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3392      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3393      &   iprev,5500+irecv,FG_COMM,status,IERR)
3394 c        write (iout,*) "Gather PRECOMP11"
3395 c        call flush(iout)
3396         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3397      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3398      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3399      &   iprev,6600+irecv,FG_COMM,status,IERR)
3400 c        write (iout,*) "Gather PRECOMP12"
3401 c        call flush(iout)
3402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3403      &  then
3404         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3405      &   MPI_ROTAT2(lensend),inext,7700+isend,
3406      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3407      &   iprev,7700+irecv,FG_COMM,status,IERR)
3408 c        write (iout,*) "Gather PRECOMP21"
3409 c        call flush(iout)
3410         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3411      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3412      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3413      &   iprev,8800+irecv,FG_COMM,status,IERR)
3414 c        write (iout,*) "Gather PRECOMP22"
3415 c        call flush(iout)
3416         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3417      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3418      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3419      &   MPI_PRECOMP23(lenrecv),
3420      &   iprev,9900+irecv,FG_COMM,status,IERR)
3421 c        write (iout,*) "Gather PRECOMP23"
3422 c        call flush(iout)
3423         endif
3424         isend=irecv
3425         irecv=irecv-1
3426         if (irecv.lt.0) irecv=nfgtasks1-1
3427       enddo
3428 #endif
3429         time_gather=time_gather+MPI_Wtime()-time00
3430       endif
3431 #ifdef DEBUG
3432 c      if (fg_rank.eq.0) then
3433         write (iout,*) "Arrays UG and UGDER"
3434         do i=1,nres-1
3435           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3436      &     ((ug(l,k,i),l=1,2),k=1,2),
3437      &     ((ugder(l,k,i),l=1,2),k=1,2)
3438         enddo
3439         write (iout,*) "Arrays UG2 and UG2DER"
3440         do i=1,nres-1
3441           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3442      &     ((ug2(l,k,i),l=1,2),k=1,2),
3443      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3444         enddo
3445         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3446         do i=1,nres-1
3447           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3448      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3449      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3450         enddo
3451         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3452         do i=1,nres-1
3453           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3454      &     costab(i),sintab(i),costab2(i),sintab2(i)
3455         enddo
3456         write (iout,*) "Array MUDER"
3457         do i=1,nres-1
3458           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3459         enddo
3460 c      endif
3461 #endif
3462 #endif
3463 cd      do i=1,nres
3464 cd        iti = itype2loc(itype(i))
3465 cd        write (iout,*) i
3466 cd        do j=1,2
3467 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3468 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3469 cd        enddo
3470 cd      enddo
3471       return
3472       end
3473 C--------------------------------------------------------------------------
3474       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3475 C
3476 C This subroutine calculates the average interaction energy and its gradient
3477 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3478 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3479 C The potential depends both on the distance of peptide-group centers and on
3480 C the orientation of the CA-CA virtual bonds.
3481 C
3482       implicit real*8 (a-h,o-z)
3483 #ifdef MPI
3484       include 'mpif.h'
3485 #endif
3486       include 'DIMENSIONS'
3487       include 'COMMON.CONTROL'
3488       include 'COMMON.SETUP'
3489       include 'COMMON.IOUNITS'
3490       include 'COMMON.GEO'
3491       include 'COMMON.VAR'
3492       include 'COMMON.LOCAL'
3493       include 'COMMON.CHAIN'
3494       include 'COMMON.DERIV'
3495       include 'COMMON.INTERACT'
3496       include 'COMMON.CONTACTS'
3497       include 'COMMON.TORSION'
3498       include 'COMMON.VECTORS'
3499       include 'COMMON.FFIELD'
3500       include 'COMMON.TIME1'
3501       include 'COMMON.SPLITELE'
3502       include 'COMMON.SHIELD'
3503       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3504      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3505       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3506      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3507       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3508      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3509      &    num_conti,j1,j2
3510 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3511 #ifdef MOMENT
3512       double precision scal_el /1.0d0/
3513 #else
3514       double precision scal_el /0.5d0/
3515 #endif
3516 C 12/13/98
3517 C 13-go grudnia roku pamietnego...
3518       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3519      &                   0.0d0,1.0d0,0.0d0,
3520      &                   0.0d0,0.0d0,1.0d0/
3521 cd      write(iout,*) 'In EELEC'
3522 cd      do i=1,nloctyp
3523 cd        write(iout,*) 'Type',i
3524 cd        write(iout,*) 'B1',B1(:,i)
3525 cd        write(iout,*) 'B2',B2(:,i)
3526 cd        write(iout,*) 'CC',CC(:,:,i)
3527 cd        write(iout,*) 'DD',DD(:,:,i)
3528 cd        write(iout,*) 'EE',EE(:,:,i)
3529 cd      enddo
3530 cd      call check_vecgrad
3531 cd      stop
3532       if (icheckgrad.eq.1) then
3533         do i=1,nres-1
3534           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3535           do k=1,3
3536             dc_norm(k,i)=dc(k,i)*fac
3537           enddo
3538 c          write (iout,*) 'i',i,' fac',fac
3539         enddo
3540       endif
3541       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3542      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3543      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3544 c        call vec_and_deriv
3545 #ifdef TIMING
3546         time01=MPI_Wtime()
3547 #endif
3548         call set_matrices
3549 #ifdef TIMING
3550         time_mat=time_mat+MPI_Wtime()-time01
3551 #endif
3552       endif
3553 cd      do i=1,nres-1
3554 cd        write (iout,*) 'i=',i
3555 cd        do k=1,3
3556 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3557 cd        enddo
3558 cd        do k=1,3
3559 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3560 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3561 cd        enddo
3562 cd      enddo
3563       t_eelecij=0.0d0
3564       ees=0.0D0
3565       evdw1=0.0D0
3566       eel_loc=0.0d0
3567       eello_turn3=0.0d0
3568       eello_turn4=0.0d0
3569       ind=0
3570       do i=1,nres
3571         num_cont_hb(i)=0
3572       enddo
3573 cd      print '(a)','Enter EELEC'
3574 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3575       do i=1,nres
3576         gel_loc_loc(i)=0.0d0
3577         gcorr_loc(i)=0.0d0
3578       enddo
3579 c
3580 c
3581 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3582 C
3583 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3584 C
3585 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3586       do i=iturn3_start,iturn3_end
3587 c        if (i.le.1) cycle
3588 C        write(iout,*) "tu jest i",i
3589         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3590 C changes suggested by Ana to avoid out of bounds
3591 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3592 c     & .or.((i+4).gt.nres)
3593 c     & .or.((i-1).le.0)
3594 C end of changes by Ana
3595      &  .or. itype(i+2).eq.ntyp1
3596      &  .or. itype(i+3).eq.ntyp1) cycle
3597 C Adam: Instructions below will switch off existing interactions
3598 c        if(i.gt.1)then
3599 c          if(itype(i-1).eq.ntyp1)cycle
3600 c        end if
3601 c        if(i.LT.nres-3)then
3602 c          if (itype(i+4).eq.ntyp1) cycle
3603 c        end if
3604         dxi=dc(1,i)
3605         dyi=dc(2,i)
3606         dzi=dc(3,i)
3607         dx_normi=dc_norm(1,i)
3608         dy_normi=dc_norm(2,i)
3609         dz_normi=dc_norm(3,i)
3610         xmedi=c(1,i)+0.5d0*dxi
3611         ymedi=c(2,i)+0.5d0*dyi
3612         zmedi=c(3,i)+0.5d0*dzi
3613           xmedi=mod(xmedi,boxxsize)
3614           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3615           ymedi=mod(ymedi,boxysize)
3616           if (ymedi.lt.0) ymedi=ymedi+boxysize
3617           zmedi=mod(zmedi,boxzsize)
3618           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3619           zmedi2=mod(zmedi,boxzsize)
3620           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3621        if ((zmedi2.gt.bordlipbot)
3622      &.and.(zmedi2.lt.bordliptop)) then
3623 C the energy transfer exist
3624         if (zmedi2.lt.buflipbot) then
3625 C what fraction I am in
3626          fracinbuf=1.0d0-
3627      &        ((zmedi2-bordlipbot)/lipbufthick)
3628 C lipbufthick is thickenes of lipid buffore
3629          sslipi=sscalelip(fracinbuf)
3630          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3631         elseif (zmedi2.gt.bufliptop) then
3632          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3633          sslipi=sscalelip(fracinbuf)
3634          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3635         else
3636          sslipi=1.0d0
3637          ssgradlipi=0.0d0
3638         endif
3639        else
3640          sslipi=0.0d0
3641          ssgradlipi=0.0d0
3642        endif
3643         num_conti=0
3644         call eelecij(i,i+2,ees,evdw1,eel_loc)
3645         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3646         num_cont_hb(i)=num_conti
3647       enddo
3648       do i=iturn4_start,iturn4_end
3649         if (i.lt.1) cycle
3650         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 c     & .or.((i+5).gt.nres)
3653 c     & .or.((i-1).le.0)
3654 C end of changes suggested by Ana
3655      &    .or. itype(i+3).eq.ntyp1
3656      &    .or. itype(i+4).eq.ntyp1
3657 c     &    .or. itype(i+5).eq.ntyp1
3658 c     &    .or. itype(i).eq.ntyp1
3659 c     &    .or. itype(i-1).eq.ntyp1
3660      &                             ) cycle
3661         dxi=dc(1,i)
3662         dyi=dc(2,i)
3663         dzi=dc(3,i)
3664         dx_normi=dc_norm(1,i)
3665         dy_normi=dc_norm(2,i)
3666         dz_normi=dc_norm(3,i)
3667         xmedi=c(1,i)+0.5d0*dxi
3668         ymedi=c(2,i)+0.5d0*dyi
3669         zmedi=c(3,i)+0.5d0*dzi
3670 C Return atom into box, boxxsize is size of box in x dimension
3671 c  194   continue
3672 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3673 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3674 C Condition for being inside the proper box
3675 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3676 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3677 c        go to 194
3678 c        endif
3679 c  195   continue
3680 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3681 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3682 C Condition for being inside the proper box
3683 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3684 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3685 c        go to 195
3686 c        endif
3687 c  196   continue
3688 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3689 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3690 C Condition for being inside the proper box
3691 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3692 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3693 c        go to 196
3694 c        endif
3695           xmedi=dmod(xmedi,boxxsize)
3696           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3697           ymedi=dmod(ymedi,boxysize)
3698           if (ymedi.lt.0) ymedi=ymedi+boxysize
3699           zmedi=dmod(zmedi,boxzsize)
3700           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3701           zmedi2=dmod(zmedi,boxzsize)
3702           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3703        if ((zmedi2.gt.bordlipbot)
3704      &.and.(zmedi2.lt.bordliptop)) then
3705 C the energy transfer exist
3706         if (zmedi2.lt.buflipbot) then
3707 C what fraction I am in
3708          fracinbuf=1.0d0-
3709      &        ((zmedi2-bordlipbot)/lipbufthick)
3710 C lipbufthick is thickenes of lipid buffore
3711          sslipi=sscalelip(fracinbuf)
3712          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3713         elseif (zmedi2.gt.bufliptop) then
3714          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3715          sslipi=sscalelip(fracinbuf)
3716          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3717         else
3718          sslipi=1.0d0
3719          ssgradlipi=0.0
3720         endif
3721        else
3722          sslipi=0.0d0
3723          ssgradlipi=0.0
3724        endif
3725         num_conti=num_cont_hb(i)
3726 c        write(iout,*) "JESTEM W PETLI"
3727         call eelecij(i,i+3,ees,evdw1,eel_loc)
3728         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3729      &   call eturn4(i,eello_turn4)
3730         num_cont_hb(i)=num_conti
3731       enddo   ! i
3732 C Loop over all neighbouring boxes
3733 C      do xshift=-1,1
3734 C      do yshift=-1,1
3735 C      do zshift=-1,1
3736 c
3737 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3738 c
3739 CTU KURWA
3740       do i=iatel_s,iatel_e
3741 C        do i=75,75
3742 c        if (i.le.1) cycle
3743         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3744 C changes suggested by Ana to avoid out of bounds
3745 c     & .or.((i+2).gt.nres)
3746 c     & .or.((i-1).le.0)
3747 C end of changes by Ana
3748 c     &  .or. itype(i+2).eq.ntyp1
3749 c     &  .or. itype(i-1).eq.ntyp1
3750      &                ) cycle
3751         dxi=dc(1,i)
3752         dyi=dc(2,i)
3753         dzi=dc(3,i)
3754         dx_normi=dc_norm(1,i)
3755         dy_normi=dc_norm(2,i)
3756         dz_normi=dc_norm(3,i)
3757         xmedi=c(1,i)+0.5d0*dxi
3758         ymedi=c(2,i)+0.5d0*dyi
3759         zmedi=c(3,i)+0.5d0*dzi
3760           xmedi=dmod(xmedi,boxxsize)
3761           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3762           ymedi=dmod(ymedi,boxysize)
3763           if (ymedi.lt.0) ymedi=ymedi+boxysize
3764           zmedi=dmod(zmedi,boxzsize)
3765           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3766        if ((zmedi.gt.bordlipbot)
3767      &.and.(zmedi.lt.bordliptop)) then
3768 C the energy transfer exist
3769         if (zmedi.lt.buflipbot) then
3770 C what fraction I am in
3771          fracinbuf=1.0d0-
3772      &        ((zmedi-bordlipbot)/lipbufthick)
3773 C lipbufthick is thickenes of lipid buffore
3774          sslipi=sscalelip(fracinbuf)
3775          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3776         elseif (zmedi.gt.bufliptop) then
3777          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3778          sslipi=sscalelip(fracinbuf)
3779          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3780         else
3781          sslipi=1.0d0
3782          ssgradlipi=0.0
3783         endif
3784        else
3785          sslipi=0.0d0
3786          ssgradlipi=0.0
3787        endif
3788 C         print *,sslipi,"TU?!"
3789 C          xmedi=xmedi+xshift*boxxsize
3790 C          ymedi=ymedi+yshift*boxysize
3791 C          zmedi=zmedi+zshift*boxzsize
3792
3793 C Return tom into box, boxxsize is size of box in x dimension
3794 c  164   continue
3795 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3796 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3797 C Condition for being inside the proper box
3798 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3799 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3800 c        go to 164
3801 c        endif
3802 c  165   continue
3803 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3804 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3805 C Condition for being inside the proper box
3806 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3807 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3808 c        go to 165
3809 c        endif
3810 c  166   continue
3811 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3812 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3813 cC Condition for being inside the proper box
3814 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3815 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3816 c        go to 166
3817 c        endif
3818
3819 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3820         num_conti=num_cont_hb(i)
3821 C I TU KURWA
3822         do j=ielstart(i),ielend(i)
3823 C          do j=16,17
3824 C          write (iout,*) i,j
3825 C         if (j.le.1) cycle
3826           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3827 C changes suggested by Ana to avoid out of bounds
3828 c     & .or.((j+2).gt.nres)
3829 c     & .or.((j-1).le.0)
3830 C end of changes by Ana
3831 c     & .or.itype(j+2).eq.ntyp1
3832 c     & .or.itype(j-1).eq.ntyp1
3833      &) cycle
3834           call eelecij(i,j,ees,evdw1,eel_loc)
3835         enddo ! j
3836         num_cont_hb(i)=num_conti
3837       enddo   ! i
3838 C     enddo   ! zshift
3839 C      enddo   ! yshift
3840 C      enddo   ! xshift
3841
3842 c      write (iout,*) "Number of loop steps in EELEC:",ind
3843 cd      do i=1,nres
3844 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3845 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3846 cd      enddo
3847 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3848 ccc      eel_loc=eel_loc+eello_turn3
3849 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3850       return
3851       end
3852 C-------------------------------------------------------------------------------
3853       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3854       implicit real*8 (a-h,o-z)
3855       include 'DIMENSIONS'
3856 #ifdef MPI
3857       include "mpif.h"
3858 #endif
3859       include 'COMMON.CONTROL'
3860       include 'COMMON.IOUNITS'
3861       include 'COMMON.GEO'
3862       include 'COMMON.VAR'
3863       include 'COMMON.LOCAL'
3864       include 'COMMON.CHAIN'
3865       include 'COMMON.DERIV'
3866       include 'COMMON.INTERACT'
3867       include 'COMMON.CONTACTS'
3868       include 'COMMON.TORSION'
3869       include 'COMMON.VECTORS'
3870       include 'COMMON.FFIELD'
3871       include 'COMMON.TIME1'
3872       include 'COMMON.SPLITELE'
3873       include 'COMMON.SHIELD'
3874       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3875      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3876       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3877      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3878      &    gmuij2(4),gmuji2(4)
3879       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3880      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3881      &    num_conti,j1,j2
3882 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3883 #ifdef MOMENT
3884       double precision scal_el /1.0d0/
3885 #else
3886       double precision scal_el /0.5d0/
3887 #endif
3888 C 12/13/98
3889 C 13-go grudnia roku pamietnego...
3890       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3891      &                   0.0d0,1.0d0,0.0d0,
3892      &                   0.0d0,0.0d0,1.0d0/
3893        integer xshift,yshift,zshift
3894 c          time00=MPI_Wtime()
3895 cd      write (iout,*) "eelecij",i,j
3896 c          ind=ind+1
3897           iteli=itel(i)
3898           itelj=itel(j)
3899           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3900           aaa=app(iteli,itelj)
3901           bbb=bpp(iteli,itelj)
3902           ael6i=ael6(iteli,itelj)
3903           ael3i=ael3(iteli,itelj)
3904           dxj=dc(1,j)
3905           dyj=dc(2,j)
3906           dzj=dc(3,j)
3907           dx_normj=dc_norm(1,j)
3908           dy_normj=dc_norm(2,j)
3909           dz_normj=dc_norm(3,j)
3910 C          xj=c(1,j)+0.5D0*dxj-xmedi
3911 C          yj=c(2,j)+0.5D0*dyj-ymedi
3912 C          zj=c(3,j)+0.5D0*dzj-zmedi
3913           xj=c(1,j)+0.5D0*dxj
3914           yj=c(2,j)+0.5D0*dyj
3915           zj=c(3,j)+0.5D0*dzj
3916           xj=mod(xj,boxxsize)
3917           if (xj.lt.0) xj=xj+boxxsize
3918           yj=mod(yj,boxysize)
3919           if (yj.lt.0) yj=yj+boxysize
3920           zj=mod(zj,boxzsize)
3921           if (zj.lt.0) zj=zj+boxzsize
3922           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3923        if ((zj.gt.bordlipbot)
3924      &.and.(zj.lt.bordliptop)) then
3925 C the energy transfer exist
3926         if (zj.lt.buflipbot) then
3927 C what fraction I am in
3928          fracinbuf=1.0d0-
3929      &        ((zj-bordlipbot)/lipbufthick)
3930 C lipbufthick is thickenes of lipid buffore
3931          sslipj=sscalelip(fracinbuf)
3932          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3933         elseif (zj.gt.bufliptop) then
3934          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3935          sslipj=sscalelip(fracinbuf)
3936          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3937         else
3938          sslipj=1.0d0
3939          ssgradlipj=0.0
3940         endif
3941        else
3942          sslipj=0.0d0
3943          ssgradlipj=0.0
3944        endif
3945       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3946       xj_safe=xj
3947       yj_safe=yj
3948       zj_safe=zj
3949       isubchap=0
3950       do xshift=-1,1
3951       do yshift=-1,1
3952       do zshift=-1,1
3953           xj=xj_safe+xshift*boxxsize
3954           yj=yj_safe+yshift*boxysize
3955           zj=zj_safe+zshift*boxzsize
3956           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3957           if(dist_temp.lt.dist_init) then
3958             dist_init=dist_temp
3959             xj_temp=xj
3960             yj_temp=yj
3961             zj_temp=zj
3962             isubchap=1
3963           endif
3964        enddo
3965        enddo
3966        enddo
3967        if (isubchap.eq.1) then
3968 C          print *,i,j
3969           xj=xj_temp-xmedi
3970           yj=yj_temp-ymedi
3971           zj=zj_temp-zmedi
3972        else
3973           xj=xj_safe-xmedi
3974           yj=yj_safe-ymedi
3975           zj=zj_safe-zmedi
3976        endif
3977 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3978 c  174   continue
3979 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3980 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3981 C Condition for being inside the proper box
3982 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3983 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3984 c        go to 174
3985 c        endif
3986 c  175   continue
3987 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3988 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3989 C Condition for being inside the proper box
3990 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3991 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3992 c        go to 175
3993 c        endif
3994 c  176   continue
3995 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3996 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3997 C Condition for being inside the proper box
3998 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3999 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4000 c        go to 176
4001 c        endif
4002 C        endif !endPBC condintion
4003 C        xj=xj-xmedi
4004 C        yj=yj-ymedi
4005 C        zj=zj-zmedi
4006           rij=xj*xj+yj*yj+zj*zj
4007
4008             sss=sscale(sqrt(rij))
4009             sssgrad=sscagrad(sqrt(rij))
4010 c            if (sss.gt.0.0d0) then
4011           rrmij=1.0D0/rij
4012           rij=dsqrt(rij)
4013           rmij=1.0D0/rij
4014           r3ij=rrmij*rmij
4015           r6ij=r3ij*r3ij
4016           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4017           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4018           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4019           fac=cosa-3.0D0*cosb*cosg
4020           ev1=aaa*r6ij*r6ij
4021 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4022           if (j.eq.i+2) ev1=scal_el*ev1
4023           ev2=bbb*r6ij
4024           fac3=ael6i*r6ij
4025           fac4=ael3i*r3ij
4026           evdwij=(ev1+ev2)
4027           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4028           el2=fac4*fac
4029 C MARYSIA
4030 C          eesij=(el1+el2)
4031 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4032           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4033           if (shield_mode.gt.0) then
4034 C          fac_shield(i)=0.4
4035 C          fac_shield(j)=0.6
4036           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4037           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4038           eesij=(el1+el2)
4039           ees=ees+eesij
4040 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
4041 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4042           else
4043           fac_shield(i)=1.0
4044           fac_shield(j)=1.0
4045           eesij=(el1+el2)
4046           ees=ees+eesij
4047      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4048 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4049           endif
4050           evdw1=evdw1+evdwij*sss
4051      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4052 C          print *,sslipi,sslipj,lipscale**2,
4053 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4054 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4055 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4056 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4057 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4058
4059           if (energy_dec) then
4060               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4061      &'evdw1',i,j,evdwij
4062      &,iteli,itelj,aaa,evdw1
4063               write (iout,*) sss
4064               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4065      &fac_shield(i),fac_shield(j)
4066           endif
4067
4068 C
4069 C Calculate contributions to the Cartesian gradient.
4070 C
4071 #ifdef SPLITELE
4072           facvdw=-6*rrmij*(ev1+evdwij)*sss
4073      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4074           facel=-3*rrmij*(el1+eesij)
4075      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4076           fac1=fac
4077           erij(1)=xj*rmij
4078           erij(2)=yj*rmij
4079           erij(3)=zj*rmij
4080
4081 *
4082 * Radial derivatives. First process both termini of the fragment (i,j)
4083 *
4084           ggg(1)=facel*xj
4085           ggg(2)=facel*yj
4086           ggg(3)=facel*zj
4087           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4088      &  (shield_mode.gt.0)) then
4089 C          print *,i,j
4090           do ilist=1,ishield_list(i)
4091            iresshield=shield_list(ilist,i)
4092            do k=1,3
4093            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4094      &      *2.0
4095            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4096      &              rlocshield
4097      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4098             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4099 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4100 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4101 C             if (iresshield.gt.i) then
4102 C               do ishi=i+1,iresshield-1
4103 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4104 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4105 C
4106 C              enddo
4107 C             else
4108 C               do ishi=iresshield,i
4109 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4110 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4111 C
4112 C               enddo
4113 C              endif
4114            enddo
4115           enddo
4116           do ilist=1,ishield_list(j)
4117            iresshield=shield_list(ilist,j)
4118            do k=1,3
4119            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4120      &     *2.0
4121            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4122      &              rlocshield
4123      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4124            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4125
4126 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4127 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4128 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4129 C             if (iresshield.gt.j) then
4130 C               do ishi=j+1,iresshield-1
4131 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4132 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4133 C
4134 C               enddo
4135 C            else
4136 C               do ishi=iresshield,j
4137 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4138 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4139 C               enddo
4140 C              endif
4141            enddo
4142           enddo
4143
4144           do k=1,3
4145             gshieldc(k,i)=gshieldc(k,i)+
4146      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4147             gshieldc(k,j)=gshieldc(k,j)+
4148      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4149             gshieldc(k,i-1)=gshieldc(k,i-1)+
4150      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4151             gshieldc(k,j-1)=gshieldc(k,j-1)+
4152      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4153
4154            enddo
4155            endif
4156 c          do k=1,3
4157 c            ghalf=0.5D0*ggg(k)
4158 c            gelc(k,i)=gelc(k,i)+ghalf
4159 c            gelc(k,j)=gelc(k,j)+ghalf
4160 c          enddo
4161 c 9/28/08 AL Gradient compotents will be summed only at the end
4162 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4163           do k=1,3
4164             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4165 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4166             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4167 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4168 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4169 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4170 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4171 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4172           enddo
4173 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4174 C Lipidic part for lipscale
4175             gelc_long(3,j)=gelc_long(3,j)+
4176      &     ssgradlipj*eesij/2.0d0*lipscale**2
4177 C           if ((ssgradlipj*eesij/2.0d0*lipscale**2).ne.0.0 )
4178 C     &     write(iout,*) "WTF",j
4179             gelc_long(3,i)=gelc_long(3,i)+
4180      &     ssgradlipi*eesij/2.0d0*lipscale**2
4181
4182 C            if ((ssgradlipi*eesij/2.0d0*lipscale**2).ne.0.0 )
4183 C     &     write(iout,*) "WTF",i
4184
4185 *
4186 * Loop over residues i+1 thru j-1.
4187 *
4188 cgrad          do k=i+1,j-1
4189 cgrad            do l=1,3
4190 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4191 cgrad            enddo
4192 cgrad          enddo
4193           if (sss.gt.0.0) then
4194           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4195      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4196
4197           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4198      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4199
4200           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4201      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4202           else
4203           ggg(1)=0.0
4204           ggg(2)=0.0
4205           ggg(3)=0.0
4206           endif
4207 c          do k=1,3
4208 c            ghalf=0.5D0*ggg(k)
4209 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4210 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4211 c          enddo
4212 c 9/28/08 AL Gradient compotents will be summed only at the end
4213           do k=1,3
4214             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4215             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4216           enddo
4217 C Lipidic part for scaling weight
4218            gvdwpp(3,j)=gvdwpp(3,j)+
4219      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4220            gvdwpp(3,i)=gvdwpp(3,i)+
4221      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4222
4223 *
4224 * Loop over residues i+1 thru j-1.
4225 *
4226 cgrad          do k=i+1,j-1
4227 cgrad            do l=1,3
4228 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4229 cgrad            enddo
4230 cgrad          enddo
4231 #else
4232 C MARYSIA
4233           facvdw=(ev1+evdwij)*sss
4234      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4235           facel=(el1+eesij)
4236           fac1=fac
4237           fac=-3*rrmij*(facvdw+facvdw+facel)
4238           erij(1)=xj*rmij
4239           erij(2)=yj*rmij
4240           erij(3)=zj*rmij
4241 *
4242 * Radial derivatives. First process both termini of the fragment (i,j)
4243 *
4244           ggg(1)=fac*xj
4245 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4246           ggg(2)=fac*yj
4247 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4248           ggg(3)=fac*zj
4249 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4250 c          do k=1,3
4251 c            ghalf=0.5D0*ggg(k)
4252 c            gelc(k,i)=gelc(k,i)+ghalf
4253 c            gelc(k,j)=gelc(k,j)+ghalf
4254 c          enddo
4255 c 9/28/08 AL Gradient compotents will be summed only at the end
4256           do k=1,3
4257             gelc_long(k,j)=gelc(k,j)+ggg(k)
4258             gelc_long(k,i)=gelc(k,i)-ggg(k)
4259           enddo
4260 *
4261 * Loop over residues i+1 thru j-1.
4262 *
4263 cgrad          do k=i+1,j-1
4264 cgrad            do l=1,3
4265 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4266 cgrad            enddo
4267 cgrad          enddo
4268 c 9/28/08 AL Gradient compotents will be summed only at the end
4269           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4270      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4271
4272           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4273      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4274
4275           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4276      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4277           do k=1,3
4278             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4279             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4280           enddo
4281            gvdwpp(3,j)=gvdwpp(3,j)+
4282      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4283            gvdwpp(3,i)=gvdwpp(3,i)+
4284      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4285
4286 #endif
4287 *
4288 * Angular part
4289 *
4290           ecosa=2.0D0*fac3*fac1+fac4
4291           fac4=-3.0D0*fac4
4292           fac3=-6.0D0*fac3
4293           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4294           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4295           do k=1,3
4296             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4297             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4298           enddo
4299 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4300 cd   &          (dcosg(k),k=1,3)
4301           do k=1,3
4302             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4303      &      fac_shield(i)**2*fac_shield(j)**2
4304      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4305           enddo
4306 c          do k=1,3
4307 c            ghalf=0.5D0*ggg(k)
4308 c            gelc(k,i)=gelc(k,i)+ghalf
4309 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4310 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4311 c            gelc(k,j)=gelc(k,j)+ghalf
4312 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4313 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4314 c          enddo
4315 cgrad          do k=i+1,j-1
4316 cgrad            do l=1,3
4317 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4318 cgrad            enddo
4319 cgrad          enddo
4320 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4321           do k=1,3
4322             gelc(k,i)=gelc(k,i)
4323      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4324      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4325      &           *fac_shield(i)**2*fac_shield(j)**2
4326      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4327             gelc(k,j)=gelc(k,j)
4328      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4329      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4330      &           *fac_shield(i)**2*fac_shield(j)**2
4331      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4332             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4333             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4334           enddo
4335 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4336
4337 C MARYSIA
4338 c          endif !sscale
4339           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4340      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4341      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4342 C
4343 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4344 C   energy of a peptide unit is assumed in the form of a second-order
4345 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4346 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4347 C   are computed for EVERY pair of non-contiguous peptide groups.
4348 C
4349
4350           if (j.lt.nres-1) then
4351             j1=j+1
4352             j2=j-1
4353           else
4354             j1=j-1
4355             j2=j-2
4356           endif
4357           kkk=0
4358           lll=0
4359           do k=1,2
4360             do l=1,2
4361               kkk=kkk+1
4362               muij(kkk)=mu(k,i)*mu(l,j)
4363 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4364 #ifdef NEWCORR
4365              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4366 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4367              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4368              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4369 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4370              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4371 #endif
4372             enddo
4373           enddo
4374 cd         write (iout,*) 'EELEC: i',i,' j',j
4375 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4376 cd          write(iout,*) 'muij',muij
4377           ury=scalar(uy(1,i),erij)
4378           urz=scalar(uz(1,i),erij)
4379           vry=scalar(uy(1,j),erij)
4380           vrz=scalar(uz(1,j),erij)
4381           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4382           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4383           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4384           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4385           fac=dsqrt(-ael6i)*r3ij
4386           a22=a22*fac
4387           a23=a23*fac
4388           a32=a32*fac
4389           a33=a33*fac
4390 cd          write (iout,'(4i5,4f10.5)')
4391 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4392 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4393 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4394 cd     &      uy(:,j),uz(:,j)
4395 cd          write (iout,'(4f10.5)')
4396 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4397 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4398 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4399 cd           write (iout,'(9f10.5/)')
4400 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4401 C Derivatives of the elements of A in virtual-bond vectors
4402           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4403           do k=1,3
4404             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4405             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4406             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4407             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4408             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4409             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4410             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4411             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4412             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4413             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4414             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4415             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4416           enddo
4417 C Compute radial contributions to the gradient
4418           facr=-3.0d0*rrmij
4419           a22der=a22*facr
4420           a23der=a23*facr
4421           a32der=a32*facr
4422           a33der=a33*facr
4423           agg(1,1)=a22der*xj
4424           agg(2,1)=a22der*yj
4425           agg(3,1)=a22der*zj
4426           agg(1,2)=a23der*xj
4427           agg(2,2)=a23der*yj
4428           agg(3,2)=a23der*zj
4429           agg(1,3)=a32der*xj
4430           agg(2,3)=a32der*yj
4431           agg(3,3)=a32der*zj
4432           agg(1,4)=a33der*xj
4433           agg(2,4)=a33der*yj
4434           agg(3,4)=a33der*zj
4435 C Add the contributions coming from er
4436           fac3=-3.0d0*fac
4437           do k=1,3
4438             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4439             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4440             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4441             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4442           enddo
4443           do k=1,3
4444 C Derivatives in DC(i)
4445 cgrad            ghalf1=0.5d0*agg(k,1)
4446 cgrad            ghalf2=0.5d0*agg(k,2)
4447 cgrad            ghalf3=0.5d0*agg(k,3)
4448 cgrad            ghalf4=0.5d0*agg(k,4)
4449             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4450      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4451             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4452      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4453             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4454      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4455             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4456      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4457 C Derivatives in DC(i+1)
4458             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4459      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4460             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4461      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4462             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4463      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4464             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4465      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4466 C Derivatives in DC(j)
4467             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4468      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4469             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4470      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4471             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4472      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4473             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4474      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4475 C Derivatives in DC(j+1) or DC(nres-1)
4476             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4477      &      -3.0d0*vryg(k,3)*ury)
4478             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4479      &      -3.0d0*vrzg(k,3)*ury)
4480             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4481      &      -3.0d0*vryg(k,3)*urz)
4482             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4483      &      -3.0d0*vrzg(k,3)*urz)
4484 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4485 cgrad              do l=1,4
4486 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4487 cgrad              enddo
4488 cgrad            endif
4489           enddo
4490           acipa(1,1)=a22
4491           acipa(1,2)=a23
4492           acipa(2,1)=a32
4493           acipa(2,2)=a33
4494           a22=-a22
4495           a23=-a23
4496           do l=1,2
4497             do k=1,3
4498               agg(k,l)=-agg(k,l)
4499               aggi(k,l)=-aggi(k,l)
4500               aggi1(k,l)=-aggi1(k,l)
4501               aggj(k,l)=-aggj(k,l)
4502               aggj1(k,l)=-aggj1(k,l)
4503             enddo
4504           enddo
4505           if (j.lt.nres-1) then
4506             a22=-a22
4507             a32=-a32
4508             do l=1,3,2
4509               do k=1,3
4510                 agg(k,l)=-agg(k,l)
4511                 aggi(k,l)=-aggi(k,l)
4512                 aggi1(k,l)=-aggi1(k,l)
4513                 aggj(k,l)=-aggj(k,l)
4514                 aggj1(k,l)=-aggj1(k,l)
4515               enddo
4516             enddo
4517           else
4518             a22=-a22
4519             a23=-a23
4520             a32=-a32
4521             a33=-a33
4522             do l=1,4
4523               do k=1,3
4524                 agg(k,l)=-agg(k,l)
4525                 aggi(k,l)=-aggi(k,l)
4526                 aggi1(k,l)=-aggi1(k,l)
4527                 aggj(k,l)=-aggj(k,l)
4528                 aggj1(k,l)=-aggj1(k,l)
4529               enddo
4530             enddo
4531           endif
4532           ENDIF ! WCORR
4533           IF (wel_loc.gt.0.0d0) THEN
4534 C Contribution to the local-electrostatic energy coming from the i-j pair
4535           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4536      &     +a33*muij(4)
4537           if (shield_mode.eq.0) then
4538            fac_shield(i)=1.0
4539            fac_shield(j)=1.0
4540 C          else
4541 C           fac_shield(i)=0.4
4542 C           fac_shield(j)=0.6
4543           endif
4544           eel_loc_ij=eel_loc_ij
4545      &    *fac_shield(i)*fac_shield(j)
4546      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4547
4548 C Now derivative over eel_loc
4549           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4550      &  (shield_mode.gt.0)) then
4551 C          print *,i,j
4552
4553           do ilist=1,ishield_list(i)
4554            iresshield=shield_list(ilist,i)
4555            do k=1,3
4556            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4557      &                                          /fac_shield(i)
4558 C     &      *2.0
4559            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4560      &              rlocshield
4561      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4562             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4563      &      +rlocshield
4564            enddo
4565           enddo
4566           do ilist=1,ishield_list(j)
4567            iresshield=shield_list(ilist,j)
4568            do k=1,3
4569            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4570      &                                       /fac_shield(j)
4571 C     &     *2.0
4572            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4573      &              rlocshield
4574      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4575            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4576      &             +rlocshield
4577
4578            enddo
4579           enddo
4580
4581           do k=1,3
4582             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4583      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4584             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4585      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4586             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4587      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4588             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4589      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4590            enddo
4591            endif
4592
4593
4594 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4595 c     &                     ' eel_loc_ij',eel_loc_ij
4596 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4597 C Calculate patrial derivative for theta angle
4598 #ifdef NEWCORR
4599          geel_loc_ij=(a22*gmuij1(1)
4600      &     +a23*gmuij1(2)
4601      &     +a32*gmuij1(3)
4602      &     +a33*gmuij1(4))
4603      &    *fac_shield(i)*fac_shield(j)
4604      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4605
4606 c         write(iout,*) "derivative over thatai"
4607 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4608 c     &   a33*gmuij1(4)
4609          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4610      &      geel_loc_ij*wel_loc
4611 c         write(iout,*) "derivative over thatai-1"
4612 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4613 c     &   a33*gmuij2(4)
4614          geel_loc_ij=
4615      &     a22*gmuij2(1)
4616      &     +a23*gmuij2(2)
4617      &     +a32*gmuij2(3)
4618      &     +a33*gmuij2(4)
4619          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4620      &      geel_loc_ij*wel_loc
4621      &    *fac_shield(i)*fac_shield(j)
4622      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4623
4624
4625 c  Derivative over j residue
4626          geel_loc_ji=a22*gmuji1(1)
4627      &     +a23*gmuji1(2)
4628      &     +a32*gmuji1(3)
4629      &     +a33*gmuji1(4)
4630 c         write(iout,*) "derivative over thataj"
4631 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4632 c     &   a33*gmuji1(4)
4633
4634         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4635      &      geel_loc_ji*wel_loc
4636      &    *fac_shield(i)*fac_shield(j)
4637      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4638
4639          geel_loc_ji=
4640      &     +a22*gmuji2(1)
4641      &     +a23*gmuji2(2)
4642      &     +a32*gmuji2(3)
4643      &     +a33*gmuji2(4)
4644 c         write(iout,*) "derivative over thataj-1"
4645 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4646 c     &   a33*gmuji2(4)
4647          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4648      &      geel_loc_ji*wel_loc
4649      &    *fac_shield(i)*fac_shield(j)
4650      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4651
4652 #endif
4653 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4654
4655           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2f7.3)')
4656      &            'eelloc',i,j,eel_loc_ij,a22*muij(1),a23*muij(2)
4657 c           if (eel_loc_ij.ne.0)
4658 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4659 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4660
4661           eel_loc=eel_loc+eel_loc_ij
4662 C Partial derivatives in virtual-bond dihedral angles gamma
4663           if (i.gt.1)
4664      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4665      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4666      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4667      &    *fac_shield(i)*fac_shield(j)
4668      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4669
4670           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4671      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4672      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4673      &    *fac_shield(i)*fac_shield(j)
4674      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4675
4676 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4677           do l=1,3
4678             ggg(l)=(agg(l,1)*muij(1)+
4679      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4680      &    *fac_shield(i)*fac_shield(j)
4681      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4682
4683             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4684             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4685 cgrad            ghalf=0.5d0*ggg(l)
4686 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4687 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4688           enddo
4689             gel_loc_long(3,j)=gel_loc_long(3,j)+
4690      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4691      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4692
4693             gel_loc_long(3,i)=gel_loc_long(3,i)+
4694      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4695      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4696
4697 cgrad          do k=i+1,j2
4698 cgrad            do l=1,3
4699 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4700 cgrad            enddo
4701 cgrad          enddo
4702 C Remaining derivatives of eello
4703           do l=1,3
4704             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4705      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4706      &    *fac_shield(i)*fac_shield(j)
4707      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4708
4709             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4710      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4711      &    *fac_shield(i)*fac_shield(j)
4712      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4713
4714             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4715      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4716      &    *fac_shield(i)*fac_shield(j)
4717      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4718
4719             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4720      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4721      &    *fac_shield(i)*fac_shield(j)
4722      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4723
4724           enddo
4725           ENDIF
4726 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4727 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4728           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4729      &       .and. num_conti.le.maxconts) then
4730 c            write (iout,*) i,j," entered corr"
4731 C
4732 C Calculate the contact function. The ith column of the array JCONT will
4733 C contain the numbers of atoms that make contacts with the atom I (of numbers
4734 C greater than I). The arrays FACONT and GACONT will contain the values of
4735 C the contact function and its derivative.
4736 c           r0ij=1.02D0*rpp(iteli,itelj)
4737 c           r0ij=1.11D0*rpp(iteli,itelj)
4738             r0ij=2.20D0*rpp(iteli,itelj)
4739 c           r0ij=1.55D0*rpp(iteli,itelj)
4740             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4741             if (fcont.gt.0.0D0) then
4742               num_conti=num_conti+1
4743               if (num_conti.gt.maxconts) then
4744                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4745      &                         ' will skip next contacts for this conf.'
4746               else
4747                 jcont_hb(num_conti,i)=j
4748 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4749 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4750                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4751      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4752 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4753 C  terms.
4754                 d_cont(num_conti,i)=rij
4755 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4756 C     --- Electrostatic-interaction matrix ---
4757                 a_chuj(1,1,num_conti,i)=a22
4758                 a_chuj(1,2,num_conti,i)=a23
4759                 a_chuj(2,1,num_conti,i)=a32
4760                 a_chuj(2,2,num_conti,i)=a33
4761 C     --- Gradient of rij
4762                 do kkk=1,3
4763                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4764                 enddo
4765                 kkll=0
4766                 do k=1,2
4767                   do l=1,2
4768                     kkll=kkll+1
4769                     do m=1,3
4770                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4771                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4772                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4773                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4774                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4775                     enddo
4776                   enddo
4777                 enddo
4778                 ENDIF
4779                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4780 C Calculate contact energies
4781                 cosa4=4.0D0*cosa
4782                 wij=cosa-3.0D0*cosb*cosg
4783                 cosbg1=cosb+cosg
4784                 cosbg2=cosb-cosg
4785 c               fac3=dsqrt(-ael6i)/r0ij**3
4786                 fac3=dsqrt(-ael6i)*r3ij
4787 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4788                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4789                 if (ees0tmp.gt.0) then
4790                   ees0pij=dsqrt(ees0tmp)
4791                 else
4792                   ees0pij=0
4793                 endif
4794 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4795                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4796                 if (ees0tmp.gt.0) then
4797                   ees0mij=dsqrt(ees0tmp)
4798                 else
4799                   ees0mij=0
4800                 endif
4801 c               ees0mij=0.0D0
4802                 if (shield_mode.eq.0) then
4803                 fac_shield(i)=1.0d0
4804                 fac_shield(j)=1.0d0
4805                 else
4806                 ees0plist(num_conti,i)=j
4807 C                fac_shield(i)=0.4d0
4808 C                fac_shield(j)=0.6d0
4809                 endif
4810                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4811      &          *fac_shield(i)*fac_shield(j)
4812                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4813      &          *fac_shield(i)*fac_shield(j)
4814 C Diagnostics. Comment out or remove after debugging!
4815 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4816 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4817 c               ees0m(num_conti,i)=0.0D0
4818 C End diagnostics.
4819 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4820 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4821 C Angular derivatives of the contact function
4822                 ees0pij1=fac3/ees0pij
4823                 ees0mij1=fac3/ees0mij
4824                 fac3p=-3.0D0*fac3*rrmij
4825                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4826                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4827 c               ees0mij1=0.0D0
4828                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4829                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4830                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4831                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4832                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4833                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4834                 ecosap=ecosa1+ecosa2
4835                 ecosbp=ecosb1+ecosb2
4836                 ecosgp=ecosg1+ecosg2
4837                 ecosam=ecosa1-ecosa2
4838                 ecosbm=ecosb1-ecosb2
4839                 ecosgm=ecosg1-ecosg2
4840 C Diagnostics
4841 c               ecosap=ecosa1
4842 c               ecosbp=ecosb1
4843 c               ecosgp=ecosg1
4844 c               ecosam=0.0D0
4845 c               ecosbm=0.0D0
4846 c               ecosgm=0.0D0
4847 C End diagnostics
4848                 facont_hb(num_conti,i)=fcont
4849                 fprimcont=fprimcont/rij
4850 cd              facont_hb(num_conti,i)=1.0D0
4851 C Following line is for diagnostics.
4852 cd              fprimcont=0.0D0
4853                 do k=1,3
4854                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4855                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4856                 enddo
4857                 do k=1,3
4858                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4859                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4860                 enddo
4861                 gggp(1)=gggp(1)+ees0pijp*xj
4862                 gggp(2)=gggp(2)+ees0pijp*yj
4863                 gggp(3)=gggp(3)+ees0pijp*zj
4864                 gggm(1)=gggm(1)+ees0mijp*xj
4865                 gggm(2)=gggm(2)+ees0mijp*yj
4866                 gggm(3)=gggm(3)+ees0mijp*zj
4867 C Derivatives due to the contact function
4868                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4869                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4870                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4871                 do k=1,3
4872 c
4873 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4874 c          following the change of gradient-summation algorithm.
4875 c
4876 cgrad                  ghalfp=0.5D0*gggp(k)
4877 cgrad                  ghalfm=0.5D0*gggm(k)
4878                   gacontp_hb1(k,num_conti,i)=!ghalfp
4879      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4880      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4881      &          *fac_shield(i)*fac_shield(j)
4882
4883                   gacontp_hb2(k,num_conti,i)=!ghalfp
4884      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4885      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4886      &          *fac_shield(i)*fac_shield(j)
4887
4888                   gacontp_hb3(k,num_conti,i)=gggp(k)
4889      &          *fac_shield(i)*fac_shield(j)
4890
4891                   gacontm_hb1(k,num_conti,i)=!ghalfm
4892      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4893      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4894      &          *fac_shield(i)*fac_shield(j)
4895
4896                   gacontm_hb2(k,num_conti,i)=!ghalfm
4897      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4898      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4899      &          *fac_shield(i)*fac_shield(j)
4900
4901                   gacontm_hb3(k,num_conti,i)=gggm(k)
4902      &          *fac_shield(i)*fac_shield(j)
4903
4904                 enddo
4905 C Diagnostics. Comment out or remove after debugging!
4906 cdiag           do k=1,3
4907 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4908 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4909 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4910 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4911 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4912 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4913 cdiag           enddo
4914               ENDIF ! wcorr
4915               endif  ! num_conti.le.maxconts
4916             endif  ! fcont.gt.0
4917           endif    ! j.gt.i+1
4918           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4919             do k=1,4
4920               do l=1,3
4921                 ghalf=0.5d0*agg(l,k)
4922                 aggi(l,k)=aggi(l,k)+ghalf
4923                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4924                 aggj(l,k)=aggj(l,k)+ghalf
4925               enddo
4926             enddo
4927             if (j.eq.nres-1 .and. i.lt.j-2) then
4928               do k=1,4
4929                 do l=1,3
4930                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4931                 enddo
4932               enddo
4933             endif
4934           endif
4935 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4936       return
4937       end
4938 C-----------------------------------------------------------------------------
4939       subroutine eturn3(i,eello_turn3)
4940 C Third- and fourth-order contributions from turns
4941       implicit real*8 (a-h,o-z)
4942       include 'DIMENSIONS'
4943       include 'COMMON.IOUNITS'
4944       include 'COMMON.GEO'
4945       include 'COMMON.VAR'
4946       include 'COMMON.LOCAL'
4947       include 'COMMON.CHAIN'
4948       include 'COMMON.DERIV'
4949       include 'COMMON.INTERACT'
4950       include 'COMMON.CONTACTS'
4951       include 'COMMON.TORSION'
4952       include 'COMMON.VECTORS'
4953       include 'COMMON.FFIELD'
4954       include 'COMMON.CONTROL'
4955       include 'COMMON.SHIELD'
4956       dimension ggg(3)
4957       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4958      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4959      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4960      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4961      &  auxgmat2(2,2),auxgmatt2(2,2)
4962       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4963      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4964       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4965      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4966      &    num_conti,j1,j2
4967       j=i+2
4968 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4969 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4970           zj=(c(3,j)+c(3,j+1))/2.0d0
4971 C          xj=mod(xj,boxxsize)
4972 C          if (xj.lt.0) xj=xj+boxxsize
4973 C          yj=mod(yj,boxysize)
4974 C          if (yj.lt.0) yj=yj+boxysize
4975           zj=mod(zj,boxzsize)
4976           if (zj.lt.0) zj=zj+boxzsize
4977           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4978        if ((zj.gt.bordlipbot)
4979      &.and.(zj.lt.bordliptop)) then
4980 C the energy transfer exist
4981         if (zj.lt.buflipbot) then
4982 C what fraction I am in
4983          fracinbuf=1.0d0-
4984      &        ((zj-bordlipbot)/lipbufthick)
4985 C lipbufthick is thickenes of lipid buffore
4986          sslipj=sscalelip(fracinbuf)
4987          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4988         elseif (zj.gt.bufliptop) then
4989          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4990          sslipj=sscalelip(fracinbuf)
4991          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4992         else
4993          sslipj=1.0d0
4994          ssgradlipj=0.0
4995         endif
4996        else
4997          sslipj=0.0d0
4998          ssgradlipj=0.0
4999        endif
5000 C      sslipj=0.0
5001 C      ssgradlipj=0.0d0
5002
5003 C      write (iout,*) "eturn3",i,j,j1,j2
5004       a_temp(1,1)=a22
5005       a_temp(1,2)=a23
5006       a_temp(2,1)=a32
5007       a_temp(2,2)=a33
5008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5009 C
5010 C               Third-order contributions
5011 C
5012 C                 (i+2)o----(i+3)
5013 C                      | |
5014 C                      | |
5015 C                 (i+1)o----i
5016 C
5017 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5018 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
5019         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5020 c auxalary matices for theta gradient
5021 c auxalary matrix for i+1 and constant i+2
5022         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5023 c auxalary matrix for i+2 and constant i+1
5024         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5025         call transpose2(auxmat(1,1),auxmat1(1,1))
5026         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5027         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5028         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5029         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5030         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5031         if (shield_mode.eq.0) then
5032         fac_shield(i)=1.0d0
5033         fac_shield(j)=1.0d0
5034 C        else
5035 C        fac_shield(i)=0.4
5036 C        fac_shield(j)=0.6
5037         endif
5038 C         if (j.eq.78)
5039 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
5040         eello_turn3=eello_turn3+
5041 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5042      &0.5d0*(pizda(1,1)+pizda(2,2))
5043      &  *fac_shield(i)*fac_shield(j)
5044      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5045         eello_t3=
5046      &0.5d0*(pizda(1,1)+pizda(2,2))
5047      &  *fac_shield(i)*fac_shield(j)
5048 #ifdef NEWCORR
5049 C Derivatives in theta
5050         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5051      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5052      &   *fac_shield(i)*fac_shield(j)
5053      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5054
5055         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5056      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5057      &   *fac_shield(i)*fac_shield(j)
5058      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5059
5060 #endif
5061
5062 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5063 C Derivatives in shield mode
5064           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5065      &  (shield_mode.gt.0)) then
5066 C          print *,i,j
5067
5068           do ilist=1,ishield_list(i)
5069            iresshield=shield_list(ilist,i)
5070            do k=1,3
5071            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5072 C     &      *2.0
5073            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5074      &              rlocshield
5075      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5076             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5077      &      +rlocshield
5078            enddo
5079           enddo
5080           do ilist=1,ishield_list(j)
5081            iresshield=shield_list(ilist,j)
5082            do k=1,3
5083            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5084 C     &     *2.0
5085            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5086      &              rlocshield
5087      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5088            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5089      &             +rlocshield
5090
5091            enddo
5092           enddo
5093
5094           do k=1,3
5095             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5096      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5097             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5098      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5099             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5100      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5101             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5102      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5103            enddo
5104            endif
5105
5106 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5107 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5108 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5109 cd     &    ' eello_turn3_num',4*eello_turn3_num
5110 C Derivatives in gamma(i)
5111         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5112         call transpose2(auxmat2(1,1),auxmat3(1,1))
5113         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5114         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5115      &   *fac_shield(i)*fac_shield(j)
5116      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5117
5118 C Derivatives in gamma(i+1)
5119         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5120         call transpose2(auxmat2(1,1),auxmat3(1,1))
5121         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5122         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5123      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5124      &   *fac_shield(i)*fac_shield(j)
5125      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5126
5127 C Cartesian derivatives
5128 !DIR$ UNROLL(0)
5129         do l=1,3
5130 c            ghalf1=0.5d0*agg(l,1)
5131 c            ghalf2=0.5d0*agg(l,2)
5132 c            ghalf3=0.5d0*agg(l,3)
5133 c            ghalf4=0.5d0*agg(l,4)
5134           a_temp(1,1)=aggi(l,1)!+ghalf1
5135           a_temp(1,2)=aggi(l,2)!+ghalf2
5136           a_temp(2,1)=aggi(l,3)!+ghalf3
5137           a_temp(2,2)=aggi(l,4)!+ghalf4
5138           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5139           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5140      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5141      &   *fac_shield(i)*fac_shield(j)
5142      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5143
5144           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5145           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5146           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5147           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5148           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5149           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5150      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5151      &   *fac_shield(i)*fac_shield(j)
5152      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5153           a_temp(1,1)=aggj(l,1)!+ghalf1
5154           a_temp(1,2)=aggj(l,2)!+ghalf2
5155           a_temp(2,1)=aggj(l,3)!+ghalf3
5156           a_temp(2,2)=aggj(l,4)!+ghalf4
5157           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5158           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5159      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5160      &   *fac_shield(i)*fac_shield(j)
5161      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5162
5163           a_temp(1,1)=aggj1(l,1)
5164           a_temp(1,2)=aggj1(l,2)
5165           a_temp(2,1)=aggj1(l,3)
5166           a_temp(2,2)=aggj1(l,4)
5167           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5168           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5169      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5170      &   *fac_shield(i)*fac_shield(j)
5171      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5172         enddo
5173          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5174      &     ssgradlipi*eello_t3/4.0d0*lipscale
5175          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5176      &     ssgradlipj*eello_t3/4.0d0*lipscale
5177          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5178      &     ssgradlipi*eello_t3/4.0d0*lipscale
5179          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5180      &     ssgradlipj*eello_t3/4.0d0*lipscale
5181
5182 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5183       return
5184       end
5185 C-------------------------------------------------------------------------------
5186       subroutine eturn4(i,eello_turn4)
5187 C Third- and fourth-order contributions from turns
5188       implicit real*8 (a-h,o-z)
5189       include 'DIMENSIONS'
5190       include 'COMMON.IOUNITS'
5191       include 'COMMON.GEO'
5192       include 'COMMON.VAR'
5193       include 'COMMON.LOCAL'
5194       include 'COMMON.CHAIN'
5195       include 'COMMON.DERIV'
5196       include 'COMMON.INTERACT'
5197       include 'COMMON.CONTACTS'
5198       include 'COMMON.TORSION'
5199       include 'COMMON.VECTORS'
5200       include 'COMMON.FFIELD'
5201       include 'COMMON.CONTROL'
5202       include 'COMMON.SHIELD'
5203       dimension ggg(3)
5204       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5205      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5206      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5207      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5208      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5209      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5210      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5211       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5212      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5213       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5214      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5215      &    num_conti,j1,j2
5216       j=i+3
5217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5218 C
5219 C               Fourth-order contributions
5220 C
5221 C                 (i+3)o----(i+4)
5222 C                     /  |
5223 C               (i+2)o   |
5224 C                     \  |
5225 C                 (i+1)o----i
5226 C
5227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5228 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5229 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5230 c        write(iout,*)"WCHODZE W PROGRAM"
5231           zj=(c(3,j)+c(3,j+1))/2.0d0
5232 C          xj=mod(xj,boxxsize)
5233 C          if (xj.lt.0) xj=xj+boxxsize
5234 C          yj=mod(yj,boxysize)
5235 C          if (yj.lt.0) yj=yj+boxysize
5236           zj=mod(zj,boxzsize)
5237           if (zj.lt.0) zj=zj+boxzsize
5238 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5239        if ((zj.gt.bordlipbot)
5240      &.and.(zj.lt.bordliptop)) then
5241 C the energy transfer exist
5242         if (zj.lt.buflipbot) then
5243 C what fraction I am in
5244          fracinbuf=1.0d0-
5245      &        ((zj-bordlipbot)/lipbufthick)
5246 C lipbufthick is thickenes of lipid buffore
5247          sslipj=sscalelip(fracinbuf)
5248          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5249         elseif (zj.gt.bufliptop) then
5250          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5251          sslipj=sscalelip(fracinbuf)
5252          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5253         else
5254          sslipj=1.0d0
5255          ssgradlipj=0.0
5256         endif
5257        else
5258          sslipj=0.0d0
5259          ssgradlipj=0.0
5260        endif
5261
5262         a_temp(1,1)=a22
5263         a_temp(1,2)=a23
5264         a_temp(2,1)=a32
5265         a_temp(2,2)=a33
5266         iti1=itype2loc(itype(i+1))
5267         iti2=itype2loc(itype(i+2))
5268         iti3=itype2loc(itype(i+3))
5269 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5270         call transpose2(EUg(1,1,i+1),e1t(1,1))
5271         call transpose2(Eug(1,1,i+2),e2t(1,1))
5272         call transpose2(Eug(1,1,i+3),e3t(1,1))
5273 C Ematrix derivative in theta
5274         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5275         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5276         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5277         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5278 c       eta1 in derivative theta
5279         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5280         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5281 c       auxgvec is derivative of Ub2 so i+3 theta
5282         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5283 c       auxalary matrix of E i+1
5284         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5285 c        s1=0.0
5286 c        gs1=0.0
5287         s1=scalar2(b1(1,i+2),auxvec(1))
5288 c derivative of theta i+2 with constant i+3
5289         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5290 c derivative of theta i+2 with constant i+2
5291         gs32=scalar2(b1(1,i+2),auxgvec(1))
5292 c derivative of E matix in theta of i+1
5293         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5294
5295         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5296 c       ea31 in derivative theta
5297         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5298         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5299 c auxilary matrix auxgvec of Ub2 with constant E matirx
5300         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5301 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5302         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5303
5304 c        s2=0.0
5305 c        gs2=0.0
5306         s2=scalar2(b1(1,i+1),auxvec(1))
5307 c derivative of theta i+1 with constant i+3
5308         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5309 c derivative of theta i+2 with constant i+1
5310         gs21=scalar2(b1(1,i+1),auxgvec(1))
5311 c derivative of theta i+3 with constant i+1
5312         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5313 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5314 c     &  gtb1(1,i+1)
5315         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5316 c two derivatives over diffetent matrices
5317 c gtae3e2 is derivative over i+3
5318         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5319 c ae3gte2 is derivative over i+2
5320         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5321         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5322 c three possible derivative over theta E matices
5323 c i+1
5324         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5325 c i+2
5326         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5327 c i+3
5328         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5329         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5330
5331         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5332         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5333         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5334         if (shield_mode.eq.0) then
5335         fac_shield(i)=1.0
5336         fac_shield(j)=1.0
5337 C        else
5338 C        fac_shield(i)=0.6
5339 C        fac_shield(j)=0.4
5340         endif
5341         eello_turn4=eello_turn4-(s1+s2+s3)
5342      &  *fac_shield(i)*fac_shield(j)
5343      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5344
5345         eello_t4=-(s1+s2+s3)
5346      &  *fac_shield(i)*fac_shield(j)
5347 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5348         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5349      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5350 C Now derivative over shield:
5351           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5352      &  (shield_mode.gt.0)) then
5353 C          print *,i,j
5354
5355           do ilist=1,ishield_list(i)
5356            iresshield=shield_list(ilist,i)
5357            do k=1,3
5358            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5359 C     &      *2.0
5360            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5361      &              rlocshield
5362      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5363             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5364      &      +rlocshield
5365            enddo
5366           enddo
5367           do ilist=1,ishield_list(j)
5368            iresshield=shield_list(ilist,j)
5369            do k=1,3
5370            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5371 C     &     *2.0
5372            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5373      &              rlocshield
5374      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5375            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5376      &             +rlocshield
5377
5378            enddo
5379           enddo
5380
5381           do k=1,3
5382             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5383      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5384             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5385      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5386             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5387      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5388             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5389      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5390            enddo
5391            endif
5392
5393
5394
5395
5396
5397
5398 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5399 cd     &    ' eello_turn4_num',8*eello_turn4_num
5400 #ifdef NEWCORR
5401         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5402      &                  -(gs13+gsE13+gsEE1)*wturn4
5403      &  *fac_shield(i)*fac_shield(j)
5404      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5405
5406         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5407      &                    -(gs23+gs21+gsEE2)*wturn4
5408      &  *fac_shield(i)*fac_shield(j)
5409      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5410
5411         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5412      &                    -(gs32+gsE31+gsEE3)*wturn4
5413      &  *fac_shield(i)*fac_shield(j)
5414      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5415
5416 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5417 c     &   gs2
5418 #endif
5419         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5420      &      'eturn4',i,j,-(s1+s2+s3)
5421 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5422 c     &    ' eello_turn4_num',8*eello_turn4_num
5423 C Derivatives in gamma(i)
5424         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5425         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5426         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5427         s1=scalar2(b1(1,i+2),auxvec(1))
5428         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5429         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5430         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5431      &  *fac_shield(i)*fac_shield(j)
5432      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5433
5434 C Derivatives in gamma(i+1)
5435         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5436         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5437         s2=scalar2(b1(1,i+1),auxvec(1))
5438         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5439         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5440         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5441         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5442      &  *fac_shield(i)*fac_shield(j)
5443      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5444
5445 C Derivatives in gamma(i+2)
5446         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5447         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5448         s1=scalar2(b1(1,i+2),auxvec(1))
5449         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5450         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5451         s2=scalar2(b1(1,i+1),auxvec(1))
5452         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5453         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5454         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5455         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5456      &  *fac_shield(i)*fac_shield(j)
5457      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5458
5459 C Cartesian derivatives
5460 C Derivatives of this turn contributions in DC(i+2)
5461         if (j.lt.nres-1) then
5462           do l=1,3
5463             a_temp(1,1)=agg(l,1)
5464             a_temp(1,2)=agg(l,2)
5465             a_temp(2,1)=agg(l,3)
5466             a_temp(2,2)=agg(l,4)
5467             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5468             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5469             s1=scalar2(b1(1,i+2),auxvec(1))
5470             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5471             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5472             s2=scalar2(b1(1,i+1),auxvec(1))
5473             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5474             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5475             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5476             ggg(l)=-(s1+s2+s3)
5477             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5478      &  *fac_shield(i)*fac_shield(j)
5479      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5480
5481           enddo
5482         endif
5483 C Remaining derivatives of this turn contribution
5484         do l=1,3
5485           a_temp(1,1)=aggi(l,1)
5486           a_temp(1,2)=aggi(l,2)
5487           a_temp(2,1)=aggi(l,3)
5488           a_temp(2,2)=aggi(l,4)
5489           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5490           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5491           s1=scalar2(b1(1,i+2),auxvec(1))
5492           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5493           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5494           s2=scalar2(b1(1,i+1),auxvec(1))
5495           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5496           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5497           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5498           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5499      &  *fac_shield(i)*fac_shield(j)
5500      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5501
5502           a_temp(1,1)=aggi1(l,1)
5503           a_temp(1,2)=aggi1(l,2)
5504           a_temp(2,1)=aggi1(l,3)
5505           a_temp(2,2)=aggi1(l,4)
5506           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5507           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5508           s1=scalar2(b1(1,i+2),auxvec(1))
5509           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5510           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5511           s2=scalar2(b1(1,i+1),auxvec(1))
5512           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5513           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5514           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5515           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5516      &  *fac_shield(i)*fac_shield(j)
5517      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5518
5519           a_temp(1,1)=aggj(l,1)
5520           a_temp(1,2)=aggj(l,2)
5521           a_temp(2,1)=aggj(l,3)
5522           a_temp(2,2)=aggj(l,4)
5523           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5524           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5525           s1=scalar2(b1(1,i+2),auxvec(1))
5526           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5527           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5528           s2=scalar2(b1(1,i+1),auxvec(1))
5529           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5530           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5531           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5532           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5533      &  *fac_shield(i)*fac_shield(j)
5534      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5535
5536           a_temp(1,1)=aggj1(l,1)
5537           a_temp(1,2)=aggj1(l,2)
5538           a_temp(2,1)=aggj1(l,3)
5539           a_temp(2,2)=aggj1(l,4)
5540           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5541           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5542           s1=scalar2(b1(1,i+2),auxvec(1))
5543           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5544           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5545           s2=scalar2(b1(1,i+1),auxvec(1))
5546           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5547           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5548           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5549 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5550           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5551      &  *fac_shield(i)*fac_shield(j)
5552      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5553         enddo
5554          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5555      &     ssgradlipi*eello_t4/4.0d0*lipscale
5556          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5557      &     ssgradlipj*eello_t4/4.0d0*lipscale
5558          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5559      &     ssgradlipi*eello_t4/4.0d0*lipscale
5560          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5561      &     ssgradlipj*eello_t4/4.0d0*lipscale
5562       return
5563       end
5564 C-----------------------------------------------------------------------------
5565       subroutine vecpr(u,v,w)
5566       implicit real*8(a-h,o-z)
5567       dimension u(3),v(3),w(3)
5568       w(1)=u(2)*v(3)-u(3)*v(2)
5569       w(2)=-u(1)*v(3)+u(3)*v(1)
5570       w(3)=u(1)*v(2)-u(2)*v(1)
5571       return
5572       end
5573 C-----------------------------------------------------------------------------
5574       subroutine unormderiv(u,ugrad,unorm,ungrad)
5575 C This subroutine computes the derivatives of a normalized vector u, given
5576 C the derivatives computed without normalization conditions, ugrad. Returns
5577 C ungrad.
5578       implicit none
5579       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5580       double precision vec(3)
5581       double precision scalar
5582       integer i,j
5583 c      write (2,*) 'ugrad',ugrad
5584 c      write (2,*) 'u',u
5585       do i=1,3
5586         vec(i)=scalar(ugrad(1,i),u(1))
5587       enddo
5588 c      write (2,*) 'vec',vec
5589       do i=1,3
5590         do j=1,3
5591           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5592         enddo
5593       enddo
5594 c      write (2,*) 'ungrad',ungrad
5595       return
5596       end
5597 C-----------------------------------------------------------------------------
5598       subroutine escp_soft_sphere(evdw2,evdw2_14)
5599 C
5600 C This subroutine calculates the excluded-volume interaction energy between
5601 C peptide-group centers and side chains and its gradient in virtual-bond and
5602 C side-chain vectors.
5603 C
5604       implicit real*8 (a-h,o-z)
5605       include 'DIMENSIONS'
5606       include 'COMMON.GEO'
5607       include 'COMMON.VAR'
5608       include 'COMMON.LOCAL'
5609       include 'COMMON.CHAIN'
5610       include 'COMMON.DERIV'
5611       include 'COMMON.INTERACT'
5612       include 'COMMON.FFIELD'
5613       include 'COMMON.IOUNITS'
5614       include 'COMMON.CONTROL'
5615       dimension ggg(3)
5616       evdw2=0.0D0
5617       evdw2_14=0.0d0
5618       r0_scp=4.5d0
5619 cd    print '(a)','Enter ESCP'
5620 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5621 C      do xshift=-1,1
5622 C      do yshift=-1,1
5623 C      do zshift=-1,1
5624       do i=iatscp_s,iatscp_e
5625         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5626         iteli=itel(i)
5627         xi=0.5D0*(c(1,i)+c(1,i+1))
5628         yi=0.5D0*(c(2,i)+c(2,i+1))
5629         zi=0.5D0*(c(3,i)+c(3,i+1))
5630 C Return atom into box, boxxsize is size of box in x dimension
5631 c  134   continue
5632 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5633 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5634 C Condition for being inside the proper box
5635 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5636 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5637 c        go to 134
5638 c        endif
5639 c  135   continue
5640 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5641 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5642 C Condition for being inside the proper box
5643 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5644 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5645 c        go to 135
5646 c c       endif
5647 c  136   continue
5648 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5649 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5650 cC Condition for being inside the proper box
5651 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5652 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5653 c        go to 136
5654 c        endif
5655           xi=mod(xi,boxxsize)
5656           if (xi.lt.0) xi=xi+boxxsize
5657           yi=mod(yi,boxysize)
5658           if (yi.lt.0) yi=yi+boxysize
5659           zi=mod(zi,boxzsize)
5660           if (zi.lt.0) zi=zi+boxzsize
5661 C          xi=xi+xshift*boxxsize
5662 C          yi=yi+yshift*boxysize
5663 C          zi=zi+zshift*boxzsize
5664         do iint=1,nscp_gr(i)
5665
5666         do j=iscpstart(i,iint),iscpend(i,iint)
5667           if (itype(j).eq.ntyp1) cycle
5668           itypj=iabs(itype(j))
5669 C Uncomment following three lines for SC-p interactions
5670 c         xj=c(1,nres+j)-xi
5671 c         yj=c(2,nres+j)-yi
5672 c         zj=c(3,nres+j)-zi
5673 C Uncomment following three lines for Ca-p interactions
5674           xj=c(1,j)
5675           yj=c(2,j)
5676           zj=c(3,j)
5677 c  174   continue
5678 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5679 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5680 C Condition for being inside the proper box
5681 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5682 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5683 c        go to 174
5684 c        endif
5685 c  175   continue
5686 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5687 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5688 cC Condition for being inside the proper box
5689 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5690 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5691 c        go to 175
5692 c        endif
5693 c  176   continue
5694 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5695 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5696 C Condition for being inside the proper box
5697 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5698 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5699 c        go to 176
5700           xj=mod(xj,boxxsize)
5701           if (xj.lt.0) xj=xj+boxxsize
5702           yj=mod(yj,boxysize)
5703           if (yj.lt.0) yj=yj+boxysize
5704           zj=mod(zj,boxzsize)
5705           if (zj.lt.0) zj=zj+boxzsize
5706       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5707       xj_safe=xj
5708       yj_safe=yj
5709       zj_safe=zj
5710       subchap=0
5711       do xshift=-1,1
5712       do yshift=-1,1
5713       do zshift=-1,1
5714           xj=xj_safe+xshift*boxxsize
5715           yj=yj_safe+yshift*boxysize
5716           zj=zj_safe+zshift*boxzsize
5717           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5718           if(dist_temp.lt.dist_init) then
5719             dist_init=dist_temp
5720             xj_temp=xj
5721             yj_temp=yj
5722             zj_temp=zj
5723             subchap=1
5724           endif
5725        enddo
5726        enddo
5727        enddo
5728        if (subchap.eq.1) then
5729           xj=xj_temp-xi
5730           yj=yj_temp-yi
5731           zj=zj_temp-zi
5732        else
5733           xj=xj_safe-xi
5734           yj=yj_safe-yi
5735           zj=zj_safe-zi
5736        endif
5737 c c       endif
5738 C          xj=xj-xi
5739 C          yj=yj-yi
5740 C          zj=zj-zi
5741           rij=xj*xj+yj*yj+zj*zj
5742
5743           r0ij=r0_scp
5744           r0ijsq=r0ij*r0ij
5745           if (rij.lt.r0ijsq) then
5746             evdwij=0.25d0*(rij-r0ijsq)**2
5747             fac=rij-r0ijsq
5748           else
5749             evdwij=0.0d0
5750             fac=0.0d0
5751           endif
5752           evdw2=evdw2+evdwij
5753 C
5754 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5755 C
5756           ggg(1)=xj*fac
5757           ggg(2)=yj*fac
5758           ggg(3)=zj*fac
5759 cgrad          if (j.lt.i) then
5760 cd          write (iout,*) 'j<i'
5761 C Uncomment following three lines for SC-p interactions
5762 c           do k=1,3
5763 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5764 c           enddo
5765 cgrad          else
5766 cd          write (iout,*) 'j>i'
5767 cgrad            do k=1,3
5768 cgrad              ggg(k)=-ggg(k)
5769 C Uncomment following line for SC-p interactions
5770 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5771 cgrad            enddo
5772 cgrad          endif
5773 cgrad          do k=1,3
5774 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5775 cgrad          enddo
5776 cgrad          kstart=min0(i+1,j)
5777 cgrad          kend=max0(i-1,j-1)
5778 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5779 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5780 cgrad          do k=kstart,kend
5781 cgrad            do l=1,3
5782 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5783 cgrad            enddo
5784 cgrad          enddo
5785           do k=1,3
5786             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5787             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5788           enddo
5789         enddo
5790
5791         enddo ! iint
5792       enddo ! i
5793 C      enddo !zshift
5794 C      enddo !yshift
5795 C      enddo !xshift
5796       return
5797       end
5798 C-----------------------------------------------------------------------------
5799       subroutine escp(evdw2,evdw2_14)
5800 C
5801 C This subroutine calculates the excluded-volume interaction energy between
5802 C peptide-group centers and side chains and its gradient in virtual-bond and
5803 C side-chain vectors.
5804 C
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       include 'COMMON.GEO'
5808       include 'COMMON.VAR'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.CHAIN'
5811       include 'COMMON.DERIV'
5812       include 'COMMON.INTERACT'
5813       include 'COMMON.FFIELD'
5814       include 'COMMON.IOUNITS'
5815       include 'COMMON.CONTROL'
5816       include 'COMMON.SPLITELE'
5817       dimension ggg(3)
5818       integer xshift,yshift,zshift
5819       evdw2=0.0D0
5820       evdw2_14=0.0d0
5821 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5822 cd    print '(a)','Enter ESCP'
5823 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5824 C      do xshift=-1,1
5825 C      do yshift=-1,1
5826 C      do zshift=-1,1
5827       do i=iatscp_s,iatscp_e
5828         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5829         iteli=itel(i)
5830         xi=0.5D0*(c(1,i)+c(1,i+1))
5831         yi=0.5D0*(c(2,i)+c(2,i+1))
5832         zi=0.5D0*(c(3,i)+c(3,i+1))
5833           xi=mod(xi,boxxsize)
5834           if (xi.lt.0) xi=xi+boxxsize
5835           yi=mod(yi,boxysize)
5836           if (yi.lt.0) yi=yi+boxysize
5837           zi=mod(zi,boxzsize)
5838           if (zi.lt.0) zi=zi+boxzsize
5839 c          xi=xi+xshift*boxxsize
5840 c          yi=yi+yshift*boxysize
5841 c          zi=zi+zshift*boxzsize
5842 c        print *,xi,yi,zi,'polozenie i'
5843 C Return atom into box, boxxsize is size of box in x dimension
5844 c  134   continue
5845 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5846 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5847 C Condition for being inside the proper box
5848 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5849 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5850 c        go to 134
5851 c        endif
5852 c  135   continue
5853 c          print *,xi,boxxsize,"pierwszy"
5854
5855 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5856 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5857 C Condition for being inside the proper box
5858 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5859 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5860 c        go to 135
5861 c        endif
5862 c  136   continue
5863 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5864 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5865 C Condition for being inside the proper box
5866 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5867 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5868 c        go to 136
5869 c        endif
5870         do iint=1,nscp_gr(i)
5871
5872         do j=iscpstart(i,iint),iscpend(i,iint)
5873           itypj=iabs(itype(j))
5874           if (itypj.eq.ntyp1) cycle
5875 C Uncomment following three lines for SC-p interactions
5876 c         xj=c(1,nres+j)-xi
5877 c         yj=c(2,nres+j)-yi
5878 c         zj=c(3,nres+j)-zi
5879 C Uncomment following three lines for Ca-p interactions
5880           xj=c(1,j)
5881           yj=c(2,j)
5882           zj=c(3,j)
5883           xj=mod(xj,boxxsize)
5884           if (xj.lt.0) xj=xj+boxxsize
5885           yj=mod(yj,boxysize)
5886           if (yj.lt.0) yj=yj+boxysize
5887           zj=mod(zj,boxzsize)
5888           if (zj.lt.0) zj=zj+boxzsize
5889 c  174   continue
5890 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5891 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5892 C Condition for being inside the proper box
5893 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5894 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5895 c        go to 174
5896 c        endif
5897 c  175   continue
5898 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5899 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5900 cC Condition for being inside the proper box
5901 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5902 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5903 c        go to 175
5904 c        endif
5905 c  176   continue
5906 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5907 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5908 C Condition for being inside the proper box
5909 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5910 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5911 c        go to 176
5912 c        endif
5913 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5914       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5915       xj_safe=xj
5916       yj_safe=yj
5917       zj_safe=zj
5918       subchap=0
5919       do xshift=-1,1
5920       do yshift=-1,1
5921       do zshift=-1,1
5922           xj=xj_safe+xshift*boxxsize
5923           yj=yj_safe+yshift*boxysize
5924           zj=zj_safe+zshift*boxzsize
5925           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5926           if(dist_temp.lt.dist_init) then
5927             dist_init=dist_temp
5928             xj_temp=xj
5929             yj_temp=yj
5930             zj_temp=zj
5931             subchap=1
5932           endif
5933        enddo
5934        enddo
5935        enddo
5936        if (subchap.eq.1) then
5937           xj=xj_temp-xi
5938           yj=yj_temp-yi
5939           zj=zj_temp-zi
5940        else
5941           xj=xj_safe-xi
5942           yj=yj_safe-yi
5943           zj=zj_safe-zi
5944        endif
5945 c          print *,xj,yj,zj,'polozenie j'
5946           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5947 c          print *,rrij
5948           sss=sscale(1.0d0/(dsqrt(rrij)))
5949 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5950 c          if (sss.eq.0) print *,'czasem jest OK'
5951           if (sss.le.0.0d0) cycle
5952           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5953           fac=rrij**expon2
5954           e1=fac*fac*aad(itypj,iteli)
5955           e2=fac*bad(itypj,iteli)
5956           if (iabs(j-i) .le. 2) then
5957             e1=scal14*e1
5958             e2=scal14*e2
5959             evdw2_14=evdw2_14+(e1+e2)*sss
5960           endif
5961           evdwij=e1+e2
5962           evdw2=evdw2+evdwij*sss
5963           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5964      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5965      &       bad(itypj,iteli)
5966 C
5967 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5968 C
5969           fac=-(evdwij+e1)*rrij*sss
5970           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5971           ggg(1)=xj*fac
5972           ggg(2)=yj*fac
5973           ggg(3)=zj*fac
5974 cgrad          if (j.lt.i) then
5975 cd          write (iout,*) 'j<i'
5976 C Uncomment following three lines for SC-p interactions
5977 c           do k=1,3
5978 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5979 c           enddo
5980 cgrad          else
5981 cd          write (iout,*) 'j>i'
5982 cgrad            do k=1,3
5983 cgrad              ggg(k)=-ggg(k)
5984 C Uncomment following line for SC-p interactions
5985 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5986 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5987 cgrad            enddo
5988 cgrad          endif
5989 cgrad          do k=1,3
5990 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5991 cgrad          enddo
5992 cgrad          kstart=min0(i+1,j)
5993 cgrad          kend=max0(i-1,j-1)
5994 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5995 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5996 cgrad          do k=kstart,kend
5997 cgrad            do l=1,3
5998 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5999 cgrad            enddo
6000 cgrad          enddo
6001           do k=1,3
6002             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
6003             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
6004           enddo
6005 c        endif !endif for sscale cutoff
6006         enddo ! j
6007
6008         enddo ! iint
6009       enddo ! i
6010 c      enddo !zshift
6011 c      enddo !yshift
6012 c      enddo !xshift
6013       do i=1,nct
6014         do j=1,3
6015           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
6016           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
6017           gradx_scp(j,i)=expon*gradx_scp(j,i)
6018         enddo
6019       enddo
6020 C******************************************************************************
6021 C
6022 C                              N O T E !!!
6023 C
6024 C To save time the factor EXPON has been extracted from ALL components
6025 C of GVDWC and GRADX. Remember to multiply them by this factor before further
6026 C use!
6027 C
6028 C******************************************************************************
6029       return
6030       end
6031 C--------------------------------------------------------------------------
6032       subroutine edis(ehpb)
6033 C
6034 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6035 C
6036       implicit real*8 (a-h,o-z)
6037       include 'DIMENSIONS'
6038       include 'COMMON.SBRIDGE'
6039       include 'COMMON.CHAIN'
6040       include 'COMMON.DERIV'
6041       include 'COMMON.VAR'
6042       include 'COMMON.INTERACT'
6043       include 'COMMON.IOUNITS'
6044       include 'COMMON.CONTROL'
6045       dimension ggg(3)
6046       ehpb=0.0D0
6047       do i=1,3
6048        ggg(i)=0.0d0
6049       enddo
6050 C      write (iout,*) ,"link_end",link_end,constr_dist
6051 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6052 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
6053       if (link_end.eq.0) return
6054       do i=link_start,link_end
6055 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6056 C CA-CA distance used in regularization of structure.
6057         ii=ihpb(i)
6058         jj=jhpb(i)
6059 C iii and jjj point to the residues for which the distance is assigned.
6060         if (ii.gt.nres) then
6061           iii=ii-nres
6062           jjj=jj-nres
6063         else
6064           iii=ii
6065           jjj=jj
6066         endif
6067 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6068 c     &    dhpb(i),dhpb1(i),forcon(i)
6069 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6070 C    distance and angle dependent SS bond potential.
6071 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6072 C     & iabs(itype(jjj)).eq.1) then
6073 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6074 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6075         if (.not.dyn_ss .and. i.le.nss) then
6076 C 15/02/13 CC dynamic SSbond - additional check
6077          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6078      & iabs(itype(jjj)).eq.1) then
6079           call ssbond_ene(iii,jjj,eij)
6080           ehpb=ehpb+2*eij
6081          endif
6082 cd          write (iout,*) "eij",eij
6083 cd   &   ' waga=',waga,' fac=',fac
6084         else if (ii.gt.nres .and. jj.gt.nres) then
6085 c Restraints from contact prediction
6086           dd=dist(ii,jj)
6087           if (constr_dist.eq.11) then
6088             ehpb=ehpb+fordepth(i)**4.0d0
6089      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6090             fac=fordepth(i)**4.0d0
6091      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6092           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6093      &    ehpb,fordepth(i),dd
6094            else
6095           if (dhpb1(i).gt.0.0d0) then
6096             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6097             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6098 c            write (iout,*) "beta nmr",
6099 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6100           else
6101             dd=dist(ii,jj)
6102             rdis=dd-dhpb(i)
6103 C Get the force constant corresponding to this distance.
6104             waga=forcon(i)
6105 C Calculate the contribution to energy.
6106             ehpb=ehpb+waga*rdis*rdis
6107 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6108 C
6109 C Evaluate gradient.
6110 C
6111             fac=waga*rdis/dd
6112           endif
6113           endif
6114           do j=1,3
6115             ggg(j)=fac*(c(j,jj)-c(j,ii))
6116           enddo
6117           do j=1,3
6118             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6119             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6120           enddo
6121           do k=1,3
6122             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6123             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6124           enddo
6125         else
6126 C Calculate the distance between the two points and its difference from the
6127 C target distance.
6128           dd=dist(ii,jj)
6129           if (constr_dist.eq.11) then
6130             ehpb=ehpb+fordepth(i)**4.0d0
6131      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6132             fac=fordepth(i)**4.0d0
6133      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6134           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6135      &    ehpb,fordepth(i),dd
6136            else
6137           if (dhpb1(i).gt.0.0d0) then
6138             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6139             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6140 c            write (iout,*) "alph nmr",
6141 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6142           else
6143             rdis=dd-dhpb(i)
6144 C Get the force constant corresponding to this distance.
6145             waga=forcon(i)
6146 C Calculate the contribution to energy.
6147             ehpb=ehpb+waga*rdis*rdis
6148 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6149 C
6150 C Evaluate gradient.
6151 C
6152             fac=waga*rdis/dd
6153           endif
6154           endif
6155             do j=1,3
6156               ggg(j)=fac*(c(j,jj)-c(j,ii))
6157             enddo
6158 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6159 C If this is a SC-SC distance, we need to calculate the contributions to the
6160 C Cartesian gradient in the SC vectors (ghpbx).
6161           if (iii.lt.ii) then
6162           do j=1,3
6163             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6164             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6165           enddo
6166           endif
6167 cgrad        do j=iii,jjj-1
6168 cgrad          do k=1,3
6169 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6170 cgrad          enddo
6171 cgrad        enddo
6172           do k=1,3
6173             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6174             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6175           enddo
6176         endif
6177       enddo
6178       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6179       return
6180       end
6181 C--------------------------------------------------------------------------
6182       subroutine ssbond_ene(i,j,eij)
6183 C
6184 C Calculate the distance and angle dependent SS-bond potential energy
6185 C using a free-energy function derived based on RHF/6-31G** ab initio
6186 C calculations of diethyl disulfide.
6187 C
6188 C A. Liwo and U. Kozlowska, 11/24/03
6189 C
6190       implicit real*8 (a-h,o-z)
6191       include 'DIMENSIONS'
6192       include 'COMMON.SBRIDGE'
6193       include 'COMMON.CHAIN'
6194       include 'COMMON.DERIV'
6195       include 'COMMON.LOCAL'
6196       include 'COMMON.INTERACT'
6197       include 'COMMON.VAR'
6198       include 'COMMON.IOUNITS'
6199       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6200       itypi=iabs(itype(i))
6201       xi=c(1,nres+i)
6202       yi=c(2,nres+i)
6203       zi=c(3,nres+i)
6204       dxi=dc_norm(1,nres+i)
6205       dyi=dc_norm(2,nres+i)
6206       dzi=dc_norm(3,nres+i)
6207 c      dsci_inv=dsc_inv(itypi)
6208       dsci_inv=vbld_inv(nres+i)
6209       itypj=iabs(itype(j))
6210 c      dscj_inv=dsc_inv(itypj)
6211       dscj_inv=vbld_inv(nres+j)
6212       xj=c(1,nres+j)-xi
6213       yj=c(2,nres+j)-yi
6214       zj=c(3,nres+j)-zi
6215       dxj=dc_norm(1,nres+j)
6216       dyj=dc_norm(2,nres+j)
6217       dzj=dc_norm(3,nres+j)
6218       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6219       rij=dsqrt(rrij)
6220       erij(1)=xj*rij
6221       erij(2)=yj*rij
6222       erij(3)=zj*rij
6223       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6224       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6225       om12=dxi*dxj+dyi*dyj+dzi*dzj
6226       do k=1,3
6227         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6228         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6229       enddo
6230       rij=1.0d0/rij
6231       deltad=rij-d0cm
6232       deltat1=1.0d0-om1
6233       deltat2=1.0d0+om2
6234       deltat12=om2-om1+2.0d0
6235       cosphi=om12-om1*om2
6236       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6237      &  +akct*deltad*deltat12
6238      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6239 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6240 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6241 c     &  " deltat12",deltat12," eij",eij
6242       ed=2*akcm*deltad+akct*deltat12
6243       pom1=akct*deltad
6244       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6245       eom1=-2*akth*deltat1-pom1-om2*pom2
6246       eom2= 2*akth*deltat2+pom1-om1*pom2
6247       eom12=pom2
6248       do k=1,3
6249         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6250         ghpbx(k,i)=ghpbx(k,i)-ggk
6251      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6252      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6253         ghpbx(k,j)=ghpbx(k,j)+ggk
6254      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6255      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6256         ghpbc(k,i)=ghpbc(k,i)-ggk
6257         ghpbc(k,j)=ghpbc(k,j)+ggk
6258       enddo
6259 C
6260 C Calculate the components of the gradient in DC and X
6261 C
6262 cgrad      do k=i,j-1
6263 cgrad        do l=1,3
6264 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6265 cgrad        enddo
6266 cgrad      enddo
6267       return
6268       end
6269 C--------------------------------------------------------------------------
6270       subroutine ebond(estr)
6271 c
6272 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6273 c
6274       implicit real*8 (a-h,o-z)
6275       include 'DIMENSIONS'
6276       include 'COMMON.LOCAL'
6277       include 'COMMON.GEO'
6278       include 'COMMON.INTERACT'
6279       include 'COMMON.DERIV'
6280       include 'COMMON.VAR'
6281       include 'COMMON.CHAIN'
6282       include 'COMMON.IOUNITS'
6283       include 'COMMON.NAMES'
6284       include 'COMMON.FFIELD'
6285       include 'COMMON.CONTROL'
6286       include 'COMMON.SETUP'
6287       double precision u(3),ud(3)
6288       estr=0.0d0
6289       estr1=0.0d0
6290       do i=ibondp_start,ibondp_end
6291         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6292 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6293 c          do j=1,3
6294 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6295 c     &      *dc(j,i-1)/vbld(i)
6296 c          enddo
6297 c          if (energy_dec) write(iout,*)
6298 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6299 c        else
6300 C       Checking if it involves dummy (NH3+ or COO-) group
6301          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6302 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6303         diff = vbld(i)-vbldpDUM
6304         if (energy_dec) write(iout,*) "dum_bond",i,diff
6305          else
6306 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6307         diff = vbld(i)-vbldp0
6308          endif
6309         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6310      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6311         estr=estr+diff*diff
6312         do j=1,3
6313           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6314         enddo
6315 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6316 c        endif
6317       enddo
6318
6319       estr=0.5d0*AKP*estr+estr1
6320 c
6321 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6322 c
6323       do i=ibond_start,ibond_end
6324         iti=iabs(itype(i))
6325         if (iti.ne.10 .and. iti.ne.ntyp1) then
6326           nbi=nbondterm(iti)
6327           if (nbi.eq.1) then
6328             diff=vbld(i+nres)-vbldsc0(1,iti)
6329             if (energy_dec)  write (iout,*)
6330      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6331      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6332             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6333             do j=1,3
6334               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6335             enddo
6336           else
6337             do j=1,nbi
6338               diff=vbld(i+nres)-vbldsc0(j,iti)
6339             if (energy_dec)  write (iout,*)
6340      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(j,iti),diff,
6341      &      AKSC(j,iti),AKSC(j,iti)*diff*diff
6342               ud(j)=aksc(j,iti)*diff
6343               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6344             enddo
6345             uprod=u(1)
6346             do j=2,nbi
6347               uprod=uprod*u(j)
6348             enddo
6349             usum=0.0d0
6350             usumsqder=0.0d0
6351             do j=1,nbi
6352               uprod1=1.0d0
6353               uprod2=1.0d0
6354               do k=1,nbi
6355                 if (k.ne.j) then
6356                   uprod1=uprod1*u(k)
6357                   uprod2=uprod2*u(k)*u(k)
6358                 endif
6359               enddo
6360               usum=usum+uprod1
6361               usumsqder=usumsqder+ud(j)*uprod2
6362             enddo
6363             estr=estr+uprod/usum
6364             do j=1,3
6365              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6366             enddo
6367           endif
6368         endif
6369       enddo
6370       return
6371       end
6372 #ifdef CRYST_THETA
6373 C--------------------------------------------------------------------------
6374       subroutine ebend(etheta,ethetacnstr)
6375 C
6376 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6377 C angles gamma and its derivatives in consecutive thetas and gammas.
6378 C
6379       implicit real*8 (a-h,o-z)
6380       include 'DIMENSIONS'
6381       include 'COMMON.LOCAL'
6382       include 'COMMON.GEO'
6383       include 'COMMON.INTERACT'
6384       include 'COMMON.DERIV'
6385       include 'COMMON.VAR'
6386       include 'COMMON.CHAIN'
6387       include 'COMMON.IOUNITS'
6388       include 'COMMON.NAMES'
6389       include 'COMMON.FFIELD'
6390       include 'COMMON.CONTROL'
6391       include 'COMMON.TORCNSTR'
6392       common /calcthet/ term1,term2,termm,diffak,ratak,
6393      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6394      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6395       double precision y(2),z(2)
6396       delta=0.02d0*pi
6397 c      time11=dexp(-2*time)
6398 c      time12=1.0d0
6399       etheta=0.0D0
6400      write (*,'(a,i2)') 'EBEND ICG=',icg
6401       do i=ithet_start,ithet_end
6402         if (i.le.2) cycle
6403         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6404      &  .or.itype(i).eq.ntyp1) cycle
6405 C Zero the energy function and its derivative at 0 or pi.
6406         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6407         it=itype(i-1)
6408         ichir1=isign(1,itype(i-2))
6409         ichir2=isign(1,itype(i))
6410          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6411          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6412          if (itype(i-1).eq.10) then
6413           itype1=isign(10,itype(i-2))
6414           ichir11=isign(1,itype(i-2))
6415           ichir12=isign(1,itype(i-2))
6416           itype2=isign(10,itype(i))
6417           ichir21=isign(1,itype(i))
6418           ichir22=isign(1,itype(i))
6419          endif
6420
6421         if (i.gt.3 ) then
6422          if (itype(i-3).ne.ntyp1) then
6423 #ifdef OSF
6424           phii=phi(i)
6425           if (phii.ne.phii) phii=150.0
6426 #else
6427           phii=phi(i)
6428 #endif
6429           y(1)=dcos(phii)
6430           y(2)=dsin(phii)
6431         else
6432           y(1)=0.0D0
6433           y(2)=0.0D0
6434         endif
6435         else
6436           y(1)=0.0D0
6437           y(2)=0.0D0
6438         endif
6439
6440         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6441 #ifdef OSF
6442           phii1=phi(i+1)
6443           if (phii1.ne.phii1) phii1=150.0
6444           phii1=pinorm(phii1)
6445           z(1)=cos(phii1)
6446 #else
6447           phii1=phi(i+1)
6448 #endif
6449           z(1)=dcos(phii1)
6450           z(2)=dsin(phii1)
6451         else
6452           z(1)=0.0D0
6453           z(2)=0.0D0
6454         endif
6455 C Calculate the "mean" value of theta from the part of the distribution
6456 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6457 C In following comments this theta will be referred to as t_c.
6458         thet_pred_mean=0.0d0
6459         do k=1,2
6460             athetk=athet(k,it,ichir1,ichir2)
6461             bthetk=bthet(k,it,ichir1,ichir2)
6462           if (it.eq.10) then
6463              athetk=athet(k,itype1,ichir11,ichir12)
6464              bthetk=bthet(k,itype2,ichir21,ichir22)
6465           endif
6466          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6467 c         write(iout,*) 'chuj tu', y(k),z(k)
6468         enddo
6469         dthett=thet_pred_mean*ssd
6470         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6471 C Derivatives of the "mean" values in gamma1 and gamma2.
6472         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6473      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6474          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6475      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6476          if (it.eq.10) then
6477       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6478      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6479         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6480      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6481          endif
6482         if (theta(i).gt.pi-delta) then
6483           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6484      &         E_tc0)
6485           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6486           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6487           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6488      &        E_theta)
6489           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6490      &        E_tc)
6491         else if (theta(i).lt.delta) then
6492           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6493           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6494           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6495      &        E_theta)
6496           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6497           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6498      &        E_tc)
6499         else
6500           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6501      &        E_theta,E_tc)
6502         endif
6503         etheta=etheta+ethetai
6504         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6505      &      'ebend',i,ethetai,theta(i),itype(i)
6506         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6507         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6508         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6509       enddo
6510       ethetacnstr=0.0d0
6511 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6512       do i=ithetaconstr_start,ithetaconstr_end
6513         itheta=itheta_constr(i)
6514         thetiii=theta(itheta)
6515         difi=pinorm(thetiii-theta_constr0(i))
6516         if (difi.gt.theta_drange(i)) then
6517           difi=difi-theta_drange(i)
6518           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6519           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6520      &    +for_thet_constr(i)*difi**3
6521         else if (difi.lt.-drange(i)) then
6522           difi=difi+drange(i)
6523           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6524           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6525      &    +for_thet_constr(i)*difi**3
6526         else
6527           difi=0.0
6528         endif
6529        if (energy_dec) then
6530         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6531      &    i,itheta,rad2deg*thetiii,
6532      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6533      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6534      &    gloc(itheta+nphi-2,icg)
6535         endif
6536       enddo
6537
6538 C Ufff.... We've done all this!!!
6539       return
6540       end
6541 C---------------------------------------------------------------------------
6542       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6543      &     E_tc)
6544       implicit real*8 (a-h,o-z)
6545       include 'DIMENSIONS'
6546       include 'COMMON.LOCAL'
6547       include 'COMMON.IOUNITS'
6548       common /calcthet/ term1,term2,termm,diffak,ratak,
6549      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6550      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6551 C Calculate the contributions to both Gaussian lobes.
6552 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6553 C The "polynomial part" of the "standard deviation" of this part of
6554 C the distributioni.
6555 ccc        write (iout,*) thetai,thet_pred_mean
6556         sig=polthet(3,it)
6557         do j=2,0,-1
6558           sig=sig*thet_pred_mean+polthet(j,it)
6559         enddo
6560 C Derivative of the "interior part" of the "standard deviation of the"
6561 C gamma-dependent Gaussian lobe in t_c.
6562         sigtc=3*polthet(3,it)
6563         do j=2,1,-1
6564           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6565         enddo
6566         sigtc=sig*sigtc
6567 C Set the parameters of both Gaussian lobes of the distribution.
6568 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6569         fac=sig*sig+sigc0(it)
6570         sigcsq=fac+fac
6571         sigc=1.0D0/sigcsq
6572 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6573         sigsqtc=-4.0D0*sigcsq*sigtc
6574 c       print *,i,sig,sigtc,sigsqtc
6575 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6576         sigtc=-sigtc/(fac*fac)
6577 C Following variable is sigma(t_c)**(-2)
6578         sigcsq=sigcsq*sigcsq
6579         sig0i=sig0(it)
6580         sig0inv=1.0D0/sig0i**2
6581         delthec=thetai-thet_pred_mean
6582         delthe0=thetai-theta0i
6583         term1=-0.5D0*sigcsq*delthec*delthec
6584         term2=-0.5D0*sig0inv*delthe0*delthe0
6585 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6586 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6587 C NaNs in taking the logarithm. We extract the largest exponent which is added
6588 C to the energy (this being the log of the distribution) at the end of energy
6589 C term evaluation for this virtual-bond angle.
6590         if (term1.gt.term2) then
6591           termm=term1
6592           term2=dexp(term2-termm)
6593           term1=1.0d0
6594         else
6595           termm=term2
6596           term1=dexp(term1-termm)
6597           term2=1.0d0
6598         endif
6599 C The ratio between the gamma-independent and gamma-dependent lobes of
6600 C the distribution is a Gaussian function of thet_pred_mean too.
6601         diffak=gthet(2,it)-thet_pred_mean
6602         ratak=diffak/gthet(3,it)**2
6603         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6604 C Let's differentiate it in thet_pred_mean NOW.
6605         aktc=ak*ratak
6606 C Now put together the distribution terms to make complete distribution.
6607         termexp=term1+ak*term2
6608         termpre=sigc+ak*sig0i
6609 C Contribution of the bending energy from this theta is just the -log of
6610 C the sum of the contributions from the two lobes and the pre-exponential
6611 C factor. Simple enough, isn't it?
6612         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6613 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6614 C NOW the derivatives!!!
6615 C 6/6/97 Take into account the deformation.
6616         E_theta=(delthec*sigcsq*term1
6617      &       +ak*delthe0*sig0inv*term2)/termexp
6618         E_tc=((sigtc+aktc*sig0i)/termpre
6619      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6620      &       aktc*term2)/termexp)
6621       return
6622       end
6623 c-----------------------------------------------------------------------------
6624       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6625       implicit real*8 (a-h,o-z)
6626       include 'DIMENSIONS'
6627       include 'COMMON.LOCAL'
6628       include 'COMMON.IOUNITS'
6629       common /calcthet/ term1,term2,termm,diffak,ratak,
6630      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6631      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6632       delthec=thetai-thet_pred_mean
6633       delthe0=thetai-theta0i
6634 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6635       t3 = thetai-thet_pred_mean
6636       t6 = t3**2
6637       t9 = term1
6638       t12 = t3*sigcsq
6639       t14 = t12+t6*sigsqtc
6640       t16 = 1.0d0
6641       t21 = thetai-theta0i
6642       t23 = t21**2
6643       t26 = term2
6644       t27 = t21*t26
6645       t32 = termexp
6646       t40 = t32**2
6647       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6648      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6649      & *(-t12*t9-ak*sig0inv*t27)
6650       return
6651       end
6652 #else
6653 C--------------------------------------------------------------------------
6654       subroutine ebend(etheta,ethetacnstr)
6655 C
6656 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6657 C angles gamma and its derivatives in consecutive thetas and gammas.
6658 C ab initio-derived potentials from
6659 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6660 C
6661       implicit real*8 (a-h,o-z)
6662       include 'DIMENSIONS'
6663       include 'COMMON.LOCAL'
6664       include 'COMMON.GEO'
6665       include 'COMMON.INTERACT'
6666       include 'COMMON.DERIV'
6667       include 'COMMON.VAR'
6668       include 'COMMON.CHAIN'
6669       include 'COMMON.IOUNITS'
6670       include 'COMMON.NAMES'
6671       include 'COMMON.FFIELD'
6672       include 'COMMON.CONTROL'
6673       include 'COMMON.TORCNSTR'
6674       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6675      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6676      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6677      & sinph1ph2(maxdouble,maxdouble)
6678       logical lprn /.false./, lprn1 /.false./
6679       etheta=0.0D0
6680       do i=ithet_start,ithet_end
6681                if (i.le.2) cycle
6682 c        print *,i,itype(i-1),itype(i),itype(i-2)
6683 C        if (itype(i-1).eq.ntyp1) cycle
6684         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6685      &  .or.itype(i).eq.ntyp1) cycle
6686 C        print *,i,theta(i)
6687         if (iabs(itype(i+1)).eq.20) iblock=2
6688         if (iabs(itype(i+1)).ne.20) iblock=1
6689         dethetai=0.0d0
6690         dephii=0.0d0
6691         dephii1=0.0d0
6692         theti2=0.5d0*theta(i)
6693         ityp2=ithetyp((itype(i-1)))
6694         do k=1,nntheterm
6695           coskt(k)=dcos(k*theti2)
6696           sinkt(k)=dsin(k*theti2)
6697         enddo
6698 C        print *,ethetai
6699         if (i.gt.3) then
6700          if (itype(i-3).ne.ntyp1) then
6701 #ifdef OSF
6702           phii=phi(i)
6703           if (phii.ne.phii) phii=150.0
6704 #else
6705           phii=phi(i)
6706 #endif
6707           ityp1=ithetyp((itype(i-2)))
6708 C propagation of chirality for glycine type
6709           do k=1,nsingle
6710             cosph1(k)=dcos(k*phii)
6711             sinph1(k)=dsin(k*phii)
6712           enddo
6713         else
6714           phii=0.0d0
6715           do k=1,nsingle
6716           ityp1=ithetyp((itype(i-2)))
6717             cosph1(k)=0.0d0
6718             sinph1(k)=0.0d0
6719           enddo
6720         endif
6721         else
6722           phii=0.0d0
6723           do k=1,nsingle
6724           ityp1=ithetyp((itype(i-2)))
6725             cosph1(k)=0.0d0
6726             sinph1(k)=0.0d0
6727           enddo
6728         endif
6729
6730         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6731 #ifdef OSF
6732           phii1=phi(i+1)
6733           if (phii1.ne.phii1) phii1=150.0
6734           phii1=pinorm(phii1)
6735 #else
6736           phii1=phi(i+1)
6737 #endif
6738           ityp3=ithetyp((itype(i)))
6739           do k=1,nsingle
6740             cosph2(k)=dcos(k*phii1)
6741             sinph2(k)=dsin(k*phii1)
6742           enddo
6743         else
6744           phii1=0.0d0
6745           ityp3=ithetyp((itype(i)))
6746           do k=1,nsingle
6747             cosph2(k)=0.0d0
6748             sinph2(k)=0.0d0
6749           enddo
6750         endif
6751         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6752         do k=1,ndouble
6753           do l=1,k-1
6754             ccl=cosph1(l)*cosph2(k-l)
6755             ssl=sinph1(l)*sinph2(k-l)
6756             scl=sinph1(l)*cosph2(k-l)
6757             csl=cosph1(l)*sinph2(k-l)
6758             cosph1ph2(l,k)=ccl-ssl
6759             cosph1ph2(k,l)=ccl+ssl
6760             sinph1ph2(l,k)=scl+csl
6761             sinph1ph2(k,l)=scl-csl
6762           enddo
6763         enddo
6764         if (lprn) then
6765         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6766      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6767         write (iout,*) "coskt and sinkt"
6768         do k=1,nntheterm
6769           write (iout,*) k,coskt(k),sinkt(k)
6770         enddo
6771         endif
6772         do k=1,ntheterm
6773           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6774           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6775      &      *coskt(k)
6776           if (lprn)
6777      &    write (iout,*) "k",k,"
6778      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6779      &     " ethetai",ethetai
6780         enddo
6781         if (lprn) then
6782         write (iout,*) "cosph and sinph"
6783         do k=1,nsingle
6784           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6785         enddo
6786         write (iout,*) "cosph1ph2 and sinph2ph2"
6787         do k=2,ndouble
6788           do l=1,k-1
6789             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6790      &         sinph1ph2(l,k),sinph1ph2(k,l)
6791           enddo
6792         enddo
6793         write(iout,*) "ethetai",ethetai
6794         endif
6795 C       print *,ethetai
6796         do m=1,ntheterm2
6797           do k=1,nsingle
6798             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6799      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6800      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6801      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6802             ethetai=ethetai+sinkt(m)*aux
6803             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6804             dephii=dephii+k*sinkt(m)*(
6805      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6806      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6807             dephii1=dephii1+k*sinkt(m)*(
6808      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6809      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6810             if (lprn)
6811      &      write (iout,*) "m",m," k",k," bbthet",
6812      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6813      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6814      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6815      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6816 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6817           enddo
6818         enddo
6819 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6820 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6821 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6822 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6823         if (lprn)
6824      &  write(iout,*) "ethetai",ethetai
6825 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6826         do m=1,ntheterm3
6827           do k=2,ndouble
6828             do l=1,k-1
6829               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6830      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6831      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6832      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6833               ethetai=ethetai+sinkt(m)*aux
6834               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6835               dephii=dephii+l*sinkt(m)*(
6836      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6837      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6838      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6839      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6840               dephii1=dephii1+(k-l)*sinkt(m)*(
6841      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6842      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6843      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6844      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6845               if (lprn) then
6846               write (iout,*) "m",m," k",k," l",l," ffthet",
6847      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6848      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6849      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6850      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6851      &            " ethetai",ethetai
6852               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6853      &            cosph1ph2(k,l)*sinkt(m),
6854      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6855               endif
6856             enddo
6857           enddo
6858         enddo
6859 10      continue
6860 c        lprn1=.true.
6861 C        print *,ethetai
6862         if (lprn1)
6863      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6864      &   i,theta(i)*rad2deg,phii*rad2deg,
6865      &   phii1*rad2deg,ethetai
6866 c        lprn1=.false.
6867         etheta=etheta+ethetai
6868         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6869         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6870         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6871       enddo
6872 C now constrains
6873       ethetacnstr=0.0d0
6874 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6875       do i=ithetaconstr_start,ithetaconstr_end
6876         itheta=itheta_constr(i)
6877         thetiii=theta(itheta)
6878         difi=pinorm(thetiii-theta_constr0(i))
6879         if (difi.gt.theta_drange(i)) then
6880           difi=difi-theta_drange(i)
6881           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6882           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6883      &    +for_thet_constr(i)*difi**3
6884         else if (difi.lt.-drange(i)) then
6885           difi=difi+drange(i)
6886           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6887           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6888      &    +for_thet_constr(i)*difi**3
6889         else
6890           difi=0.0
6891         endif
6892        if (energy_dec) then
6893         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6894      &    i,itheta,rad2deg*thetiii,
6895      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6896      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6897      &    gloc(itheta+nphi-2,icg)
6898         endif
6899       enddo
6900
6901       return
6902       end
6903 #endif
6904 #ifdef CRYST_SC
6905 c-----------------------------------------------------------------------------
6906       subroutine esc(escloc)
6907 C Calculate the local energy of a side chain and its derivatives in the
6908 C corresponding virtual-bond valence angles THETA and the spherical angles
6909 C ALPHA and OMEGA.
6910       implicit real*8 (a-h,o-z)
6911       include 'DIMENSIONS'
6912       include 'COMMON.GEO'
6913       include 'COMMON.LOCAL'
6914       include 'COMMON.VAR'
6915       include 'COMMON.INTERACT'
6916       include 'COMMON.DERIV'
6917       include 'COMMON.CHAIN'
6918       include 'COMMON.IOUNITS'
6919       include 'COMMON.NAMES'
6920       include 'COMMON.FFIELD'
6921       include 'COMMON.CONTROL'
6922       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6923      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6924       common /sccalc/ time11,time12,time112,theti,it,nlobit
6925       delta=0.02d0*pi
6926       escloc=0.0D0
6927 c     write (iout,'(a)') 'ESC'
6928       do i=loc_start,loc_end
6929         it=itype(i)
6930         if (it.eq.ntyp1) cycle
6931         if (it.eq.10) goto 1
6932         nlobit=nlob(iabs(it))
6933 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6934 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6935         theti=theta(i+1)-pipol
6936         x(1)=dtan(theti)
6937         x(2)=alph(i)
6938         x(3)=omeg(i)
6939
6940         if (x(2).gt.pi-delta) then
6941           xtemp(1)=x(1)
6942           xtemp(2)=pi-delta
6943           xtemp(3)=x(3)
6944           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6945           xtemp(2)=pi
6946           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6947           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6948      &        escloci,dersc(2))
6949           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6950      &        ddersc0(1),dersc(1))
6951           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6952      &        ddersc0(3),dersc(3))
6953           xtemp(2)=pi-delta
6954           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6955           xtemp(2)=pi
6956           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6957           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6958      &            dersc0(2),esclocbi,dersc02)
6959           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6960      &            dersc12,dersc01)
6961           call splinthet(x(2),0.5d0*delta,ss,ssd)
6962           dersc0(1)=dersc01
6963           dersc0(2)=dersc02
6964           dersc0(3)=0.0d0
6965           do k=1,3
6966             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6967           enddo
6968           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6969 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6970 c    &             esclocbi,ss,ssd
6971           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6972 c         escloci=esclocbi
6973 c         write (iout,*) escloci
6974         else if (x(2).lt.delta) then
6975           xtemp(1)=x(1)
6976           xtemp(2)=delta
6977           xtemp(3)=x(3)
6978           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6979           xtemp(2)=0.0d0
6980           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6981           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6982      &        escloci,dersc(2))
6983           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6984      &        ddersc0(1),dersc(1))
6985           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6986      &        ddersc0(3),dersc(3))
6987           xtemp(2)=delta
6988           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6989           xtemp(2)=0.0d0
6990           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6991           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6992      &            dersc0(2),esclocbi,dersc02)
6993           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6994      &            dersc12,dersc01)
6995           dersc0(1)=dersc01
6996           dersc0(2)=dersc02
6997           dersc0(3)=0.0d0
6998           call splinthet(x(2),0.5d0*delta,ss,ssd)
6999           do k=1,3
7000             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
7001           enddo
7002           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
7003 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
7004 c    &             esclocbi,ss,ssd
7005           escloci=ss*escloci+(1.0d0-ss)*esclocbi
7006 c         write (iout,*) escloci
7007         else
7008           call enesc(x,escloci,dersc,ddummy,.false.)
7009         endif
7010
7011         escloc=escloc+escloci
7012         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7013      &     'escloc',i,escloci
7014 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
7015
7016         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
7017      &   wscloc*dersc(1)
7018         gloc(ialph(i,1),icg)=wscloc*dersc(2)
7019         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
7020     1   continue
7021       enddo
7022       return
7023       end
7024 C---------------------------------------------------------------------------
7025       subroutine enesc(x,escloci,dersc,ddersc,mixed)
7026       implicit real*8 (a-h,o-z)
7027       include 'DIMENSIONS'
7028       include 'COMMON.GEO'
7029       include 'COMMON.LOCAL'
7030       include 'COMMON.IOUNITS'
7031       common /sccalc/ time11,time12,time112,theti,it,nlobit
7032       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7033       double precision contr(maxlob,-1:1)
7034       logical mixed
7035 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7036         escloc_i=0.0D0
7037         do j=1,3
7038           dersc(j)=0.0D0
7039           if (mixed) ddersc(j)=0.0d0
7040         enddo
7041         x3=x(3)
7042
7043 C Because of periodicity of the dependence of the SC energy in omega we have
7044 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7045 C To avoid underflows, first compute & store the exponents.
7046
7047         do iii=-1,1
7048
7049           x(3)=x3+iii*dwapi
7050
7051           do j=1,nlobit
7052             do k=1,3
7053               z(k)=x(k)-censc(k,j,it)
7054             enddo
7055             do k=1,3
7056               Axk=0.0D0
7057               do l=1,3
7058                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7059               enddo
7060               Ax(k,j,iii)=Axk
7061             enddo
7062             expfac=0.0D0
7063             do k=1,3
7064               expfac=expfac+Ax(k,j,iii)*z(k)
7065             enddo
7066             contr(j,iii)=expfac
7067           enddo ! j
7068
7069         enddo ! iii
7070
7071         x(3)=x3
7072 C As in the case of ebend, we want to avoid underflows in exponentiation and
7073 C subsequent NaNs and INFs in energy calculation.
7074 C Find the largest exponent
7075         emin=contr(1,-1)
7076         do iii=-1,1
7077           do j=1,nlobit
7078             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7079           enddo
7080         enddo
7081         emin=0.5D0*emin
7082 cd      print *,'it=',it,' emin=',emin
7083
7084 C Compute the contribution to SC energy and derivatives
7085         do iii=-1,1
7086
7087           do j=1,nlobit
7088 #ifdef OSF
7089             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7090             if(adexp.ne.adexp) adexp=1.0
7091             expfac=dexp(adexp)
7092 #else
7093             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7094 #endif
7095 cd          print *,'j=',j,' expfac=',expfac
7096             escloc_i=escloc_i+expfac
7097             do k=1,3
7098               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7099             enddo
7100             if (mixed) then
7101               do k=1,3,2
7102                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7103      &            +gaussc(k,2,j,it))*expfac
7104               enddo
7105             endif
7106           enddo
7107
7108         enddo ! iii
7109
7110         dersc(1)=dersc(1)/cos(theti)**2
7111         ddersc(1)=ddersc(1)/cos(theti)**2
7112         ddersc(3)=ddersc(3)
7113
7114         escloci=-(dlog(escloc_i)-emin)
7115         do j=1,3
7116           dersc(j)=dersc(j)/escloc_i
7117         enddo
7118         if (mixed) then
7119           do j=1,3,2
7120             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7121           enddo
7122         endif
7123       return
7124       end
7125 C------------------------------------------------------------------------------
7126       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7127       implicit real*8 (a-h,o-z)
7128       include 'DIMENSIONS'
7129       include 'COMMON.GEO'
7130       include 'COMMON.LOCAL'
7131       include 'COMMON.IOUNITS'
7132       common /sccalc/ time11,time12,time112,theti,it,nlobit
7133       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7134       double precision contr(maxlob)
7135       logical mixed
7136
7137       escloc_i=0.0D0
7138
7139       do j=1,3
7140         dersc(j)=0.0D0
7141       enddo
7142
7143       do j=1,nlobit
7144         do k=1,2
7145           z(k)=x(k)-censc(k,j,it)
7146         enddo
7147         z(3)=dwapi
7148         do k=1,3
7149           Axk=0.0D0
7150           do l=1,3
7151             Axk=Axk+gaussc(l,k,j,it)*z(l)
7152           enddo
7153           Ax(k,j)=Axk
7154         enddo
7155         expfac=0.0D0
7156         do k=1,3
7157           expfac=expfac+Ax(k,j)*z(k)
7158         enddo
7159         contr(j)=expfac
7160       enddo ! j
7161
7162 C As in the case of ebend, we want to avoid underflows in exponentiation and
7163 C subsequent NaNs and INFs in energy calculation.
7164 C Find the largest exponent
7165       emin=contr(1)
7166       do j=1,nlobit
7167         if (emin.gt.contr(j)) emin=contr(j)
7168       enddo
7169       emin=0.5D0*emin
7170
7171 C Compute the contribution to SC energy and derivatives
7172
7173       dersc12=0.0d0
7174       do j=1,nlobit
7175         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7176         escloc_i=escloc_i+expfac
7177         do k=1,2
7178           dersc(k)=dersc(k)+Ax(k,j)*expfac
7179         enddo
7180         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7181      &            +gaussc(1,2,j,it))*expfac
7182         dersc(3)=0.0d0
7183       enddo
7184
7185       dersc(1)=dersc(1)/cos(theti)**2
7186       dersc12=dersc12/cos(theti)**2
7187       escloci=-(dlog(escloc_i)-emin)
7188       do j=1,2
7189         dersc(j)=dersc(j)/escloc_i
7190       enddo
7191       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7192       return
7193       end
7194 #else
7195 c----------------------------------------------------------------------------------
7196       subroutine esc(escloc)
7197 C Calculate the local energy of a side chain and its derivatives in the
7198 C corresponding virtual-bond valence angles THETA and the spherical angles
7199 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7200 C added by Urszula Kozlowska. 07/11/2007
7201 C
7202       implicit real*8 (a-h,o-z)
7203       include 'DIMENSIONS'
7204       include 'COMMON.GEO'
7205       include 'COMMON.LOCAL'
7206       include 'COMMON.VAR'
7207       include 'COMMON.SCROT'
7208       include 'COMMON.INTERACT'
7209       include 'COMMON.DERIV'
7210       include 'COMMON.CHAIN'
7211       include 'COMMON.IOUNITS'
7212       include 'COMMON.NAMES'
7213       include 'COMMON.FFIELD'
7214       include 'COMMON.CONTROL'
7215       include 'COMMON.VECTORS'
7216       double precision x_prime(3),y_prime(3),z_prime(3)
7217      &    , sumene,dsc_i,dp2_i,x(65),
7218      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7219      &    de_dxx,de_dyy,de_dzz,de_dt
7220       double precision s1_t,s1_6_t,s2_t,s2_6_t
7221       double precision
7222      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7223      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7224      & dt_dCi(3),dt_dCi1(3)
7225       common /sccalc/ time11,time12,time112,theti,it,nlobit
7226       delta=0.02d0*pi
7227       escloc=0.0D0
7228       do i=loc_start,loc_end
7229         if (itype(i).eq.ntyp1) cycle
7230         costtab(i+1) =dcos(theta(i+1))
7231         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7232         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7233         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7234         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7235         cosfac=dsqrt(cosfac2)
7236         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7237         sinfac=dsqrt(sinfac2)
7238         it=iabs(itype(i))
7239         if (it.eq.10) goto 1
7240 c
7241 C  Compute the axes of tghe local cartesian coordinates system; store in
7242 c   x_prime, y_prime and z_prime
7243 c
7244         do j=1,3
7245           x_prime(j) = 0.00
7246           y_prime(j) = 0.00
7247           z_prime(j) = 0.00
7248         enddo
7249 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7250 C     &   dc_norm(3,i+nres)
7251         do j = 1,3
7252           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7253           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7254         enddo
7255         do j = 1,3
7256           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7257         enddo
7258 c       write (2,*) "i",i
7259 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7260 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7261 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7262 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7263 c      & " xy",scalar(x_prime(1),y_prime(1)),
7264 c      & " xz",scalar(x_prime(1),z_prime(1)),
7265 c      & " yy",scalar(y_prime(1),y_prime(1)),
7266 c      & " yz",scalar(y_prime(1),z_prime(1)),
7267 c      & " zz",scalar(z_prime(1),z_prime(1))
7268 c
7269 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7270 C to local coordinate system. Store in xx, yy, zz.
7271 c
7272         xx=0.0d0
7273         yy=0.0d0
7274         zz=0.0d0
7275         do j = 1,3
7276           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7277           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7278           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7279         enddo
7280
7281         xxtab(i)=xx
7282         yytab(i)=yy
7283         zztab(i)=zz
7284 C
7285 C Compute the energy of the ith side cbain
7286 C
7287 c        write (2,*) "xx",xx," yy",yy," zz",zz
7288         it=iabs(itype(i))
7289         do j = 1,65
7290           x(j) = sc_parmin(j,it)
7291         enddo
7292 #ifdef CHECK_COORD
7293 Cc diagnostics - remove later
7294         xx1 = dcos(alph(2))
7295         yy1 = dsin(alph(2))*dcos(omeg(2))
7296         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7297         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7298      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7299      &    xx1,yy1,zz1
7300 C,"  --- ", xx_w,yy_w,zz_w
7301 c end diagnostics
7302 #endif
7303         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7304      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7305      &   + x(10)*yy*zz
7306         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7307      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7308      & + x(20)*yy*zz
7309         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7310      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7311      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7312      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7313      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7314      &  +x(40)*xx*yy*zz
7315         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7316      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7317      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7318      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7319      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7320      &  +x(60)*xx*yy*zz
7321         dsc_i   = 0.743d0+x(61)
7322         dp2_i   = 1.9d0+x(62)
7323         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7324      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7325         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7326      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7327         s1=(1+x(63))/(0.1d0 + dscp1)
7328         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7329         s2=(1+x(65))/(0.1d0 + dscp2)
7330         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7331         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7332      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7333 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7334 c     &   sumene4,
7335 c     &   dscp1,dscp2,sumene
7336 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7337         escloc = escloc + sumene
7338 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7339 c     & ,zz,xx,yy
7340 c#define DEBUG
7341 #ifdef DEBUG
7342 C
7343 C This section to check the numerical derivatives of the energy of ith side
7344 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7345 C #define DEBUG in the code to turn it on.
7346 C
7347         write (2,*) "sumene               =",sumene
7348         aincr=1.0d-7
7349         xxsave=xx
7350         xx=xx+aincr
7351         write (2,*) xx,yy,zz
7352         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7353         de_dxx_num=(sumenep-sumene)/aincr
7354         xx=xxsave
7355         write (2,*) "xx+ sumene from enesc=",sumenep
7356         yysave=yy
7357         yy=yy+aincr
7358         write (2,*) xx,yy,zz
7359         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7360         de_dyy_num=(sumenep-sumene)/aincr
7361         yy=yysave
7362         write (2,*) "yy+ sumene from enesc=",sumenep
7363         zzsave=zz
7364         zz=zz+aincr
7365         write (2,*) xx,yy,zz
7366         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7367         de_dzz_num=(sumenep-sumene)/aincr
7368         zz=zzsave
7369         write (2,*) "zz+ sumene from enesc=",sumenep
7370         costsave=cost2tab(i+1)
7371         sintsave=sint2tab(i+1)
7372         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7373         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7374         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7375         de_dt_num=(sumenep-sumene)/aincr
7376         write (2,*) " t+ sumene from enesc=",sumenep
7377         cost2tab(i+1)=costsave
7378         sint2tab(i+1)=sintsave
7379 C End of diagnostics section.
7380 #endif
7381 C
7382 C Compute the gradient of esc
7383 C
7384 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7385         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7386         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7387         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7388         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7389         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7390         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7391         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7392         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7393         pom1=(sumene3*sint2tab(i+1)+sumene1)
7394      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7395         pom2=(sumene4*cost2tab(i+1)+sumene2)
7396      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7397         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7398         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7399      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7400      &  +x(40)*yy*zz
7401         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7402         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7403      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7404      &  +x(60)*yy*zz
7405         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7406      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7407      &        +(pom1+pom2)*pom_dx
7408 #ifdef DEBUG
7409         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7410 #endif
7411 C
7412         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7413         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7414      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7415      &  +x(40)*xx*zz
7416         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7417         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7418      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7419      &  +x(59)*zz**2 +x(60)*xx*zz
7420         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7421      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7422      &        +(pom1-pom2)*pom_dy
7423 #ifdef DEBUG
7424         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7425 #endif
7426 C
7427         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7428      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7429      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7430      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7431      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7432      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7433      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7434      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7435 #ifdef DEBUG
7436         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7437 #endif
7438 C
7439         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7440      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7441      &  +pom1*pom_dt1+pom2*pom_dt2
7442 #ifdef DEBUG
7443         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7444 #endif
7445 c#undef DEBUG
7446 c
7447 C
7448        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7449        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7450        cosfac2xx=cosfac2*xx
7451        sinfac2yy=sinfac2*yy
7452        do k = 1,3
7453          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7454      &      vbld_inv(i+1)
7455          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7456      &      vbld_inv(i)
7457          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7458          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7459 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7460 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7461 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7462 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7463          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7464          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7465          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7466          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7467          dZZ_Ci1(k)=0.0d0
7468          dZZ_Ci(k)=0.0d0
7469          do j=1,3
7470            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7471      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7472            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7473      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7474          enddo
7475
7476          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7477          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7478          dZZ_XYZ(k)=vbld_inv(i+nres)*
7479      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7480 c
7481          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7482          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7483        enddo
7484
7485        do k=1,3
7486          dXX_Ctab(k,i)=dXX_Ci(k)
7487          dXX_C1tab(k,i)=dXX_Ci1(k)
7488          dYY_Ctab(k,i)=dYY_Ci(k)
7489          dYY_C1tab(k,i)=dYY_Ci1(k)
7490          dZZ_Ctab(k,i)=dZZ_Ci(k)
7491          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7492          dXX_XYZtab(k,i)=dXX_XYZ(k)
7493          dYY_XYZtab(k,i)=dYY_XYZ(k)
7494          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7495        enddo
7496
7497        do k = 1,3
7498 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7499 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7500 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7501 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7502 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7503 c     &    dt_dci(k)
7504 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7505 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7506          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7507      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7508          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7509      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7510          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7511      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7512        enddo
7513 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7514 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7515
7516 C to check gradient call subroutine check_grad
7517
7518     1 continue
7519       enddo
7520       return
7521       end
7522 c------------------------------------------------------------------------------
7523       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7524       implicit none
7525       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7526      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7527       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7528      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7529      &   + x(10)*yy*zz
7530       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7531      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7532      & + x(20)*yy*zz
7533       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7534      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7535      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7536      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7537      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7538      &  +x(40)*xx*yy*zz
7539       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7540      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7541      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7542      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7543      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7544      &  +x(60)*xx*yy*zz
7545       dsc_i   = 0.743d0+x(61)
7546       dp2_i   = 1.9d0+x(62)
7547       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7548      &          *(xx*cost2+yy*sint2))
7549       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7550      &          *(xx*cost2-yy*sint2))
7551       s1=(1+x(63))/(0.1d0 + dscp1)
7552       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7553       s2=(1+x(65))/(0.1d0 + dscp2)
7554       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7555       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7556      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7557       enesc=sumene
7558       return
7559       end
7560 #endif
7561 c------------------------------------------------------------------------------
7562       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7563 C
7564 C This procedure calculates two-body contact function g(rij) and its derivative:
7565 C
7566 C           eps0ij                                     !       x < -1
7567 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7568 C            0                                         !       x > 1
7569 C
7570 C where x=(rij-r0ij)/delta
7571 C
7572 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7573 C
7574       implicit none
7575       double precision rij,r0ij,eps0ij,fcont,fprimcont
7576       double precision x,x2,x4,delta
7577 c     delta=0.02D0*r0ij
7578 c      delta=0.2D0*r0ij
7579       x=(rij-r0ij)/delta
7580       if (x.lt.-1.0D0) then
7581         fcont=eps0ij
7582         fprimcont=0.0D0
7583       else if (x.le.1.0D0) then
7584         x2=x*x
7585         x4=x2*x2
7586         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7587         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7588       else
7589         fcont=0.0D0
7590         fprimcont=0.0D0
7591       endif
7592       return
7593       end
7594 c------------------------------------------------------------------------------
7595       subroutine splinthet(theti,delta,ss,ssder)
7596       implicit real*8 (a-h,o-z)
7597       include 'DIMENSIONS'
7598       include 'COMMON.VAR'
7599       include 'COMMON.GEO'
7600       thetup=pi-delta
7601       thetlow=delta
7602       if (theti.gt.pipol) then
7603         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7604       else
7605         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7606         ssder=-ssder
7607       endif
7608       return
7609       end
7610 c------------------------------------------------------------------------------
7611       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7612       implicit none
7613       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7614       double precision ksi,ksi2,ksi3,a1,a2,a3
7615       a1=fprim0*delta/(f1-f0)
7616       a2=3.0d0-2.0d0*a1
7617       a3=a1-2.0d0
7618       ksi=(x-x0)/delta
7619       ksi2=ksi*ksi
7620       ksi3=ksi2*ksi
7621       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7622       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7623       return
7624       end
7625 c------------------------------------------------------------------------------
7626       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7627       implicit none
7628       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7629       double precision ksi,ksi2,ksi3,a1,a2,a3
7630       ksi=(x-x0)/delta
7631       ksi2=ksi*ksi
7632       ksi3=ksi2*ksi
7633       a1=fprim0x*delta
7634       a2=3*(f1x-f0x)-2*fprim0x*delta
7635       a3=fprim0x*delta-2*(f1x-f0x)
7636       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7637       return
7638       end
7639 C-----------------------------------------------------------------------------
7640 #ifdef CRYST_TOR
7641 C-----------------------------------------------------------------------------
7642       subroutine etor(etors,edihcnstr)
7643       implicit real*8 (a-h,o-z)
7644       include 'DIMENSIONS'
7645       include 'COMMON.VAR'
7646       include 'COMMON.GEO'
7647       include 'COMMON.LOCAL'
7648       include 'COMMON.TORSION'
7649       include 'COMMON.INTERACT'
7650       include 'COMMON.DERIV'
7651       include 'COMMON.CHAIN'
7652       include 'COMMON.NAMES'
7653       include 'COMMON.IOUNITS'
7654       include 'COMMON.FFIELD'
7655       include 'COMMON.TORCNSTR'
7656       include 'COMMON.CONTROL'
7657       logical lprn
7658 C Set lprn=.true. for debugging
7659       lprn=.false.
7660 c      lprn=.true.
7661       etors=0.0D0
7662       do i=iphi_start,iphi_end
7663       etors_ii=0.0D0
7664         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7665      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7666         itori=itortyp(itype(i-2))
7667         itori1=itortyp(itype(i-1))
7668         phii=phi(i)
7669         gloci=0.0D0
7670 C Proline-Proline pair is a special case...
7671         if (itori.eq.3 .and. itori1.eq.3) then
7672           if (phii.gt.-dwapi3) then
7673             cosphi=dcos(3*phii)
7674             fac=1.0D0/(1.0D0-cosphi)
7675             etorsi=v1(1,3,3)*fac
7676             etorsi=etorsi+etorsi
7677             etors=etors+etorsi-v1(1,3,3)
7678             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7679             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7680           endif
7681           do j=1,3
7682             v1ij=v1(j+1,itori,itori1)
7683             v2ij=v2(j+1,itori,itori1)
7684             cosphi=dcos(j*phii)
7685             sinphi=dsin(j*phii)
7686             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7687             if (energy_dec) etors_ii=etors_ii+
7688      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7689             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7690           enddo
7691         else
7692           do j=1,nterm_old
7693             v1ij=v1(j,itori,itori1)
7694             v2ij=v2(j,itori,itori1)
7695             cosphi=dcos(j*phii)
7696             sinphi=dsin(j*phii)
7697             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7698             if (energy_dec) etors_ii=etors_ii+
7699      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7700             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7701           enddo
7702         endif
7703         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7704              'etor',i,etors_ii
7705         if (lprn)
7706      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7707      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7708      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7709         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7710 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7711       enddo
7712 ! 6/20/98 - dihedral angle constraints
7713       edihcnstr=0.0d0
7714       do i=1,ndih_constr
7715         itori=idih_constr(i)
7716         phii=phi(itori)
7717         difi=phii-phi0(i)
7718         if (difi.gt.drange(i)) then
7719           difi=difi-drange(i)
7720           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7721           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7722         else if (difi.lt.-drange(i)) then
7723           difi=difi+drange(i)
7724           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7725           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7726         endif
7727 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7728 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7729       enddo
7730 !      write (iout,*) 'edihcnstr',edihcnstr
7731       return
7732       end
7733 c------------------------------------------------------------------------------
7734       subroutine etor_d(etors_d)
7735       etors_d=0.0d0
7736       return
7737       end
7738 c----------------------------------------------------------------------------
7739 #else
7740       subroutine etor(etors,edihcnstr)
7741       implicit real*8 (a-h,o-z)
7742       include 'DIMENSIONS'
7743       include 'COMMON.VAR'
7744       include 'COMMON.GEO'
7745       include 'COMMON.LOCAL'
7746       include 'COMMON.TORSION'
7747       include 'COMMON.INTERACT'
7748       include 'COMMON.DERIV'
7749       include 'COMMON.CHAIN'
7750       include 'COMMON.NAMES'
7751       include 'COMMON.IOUNITS'
7752       include 'COMMON.FFIELD'
7753       include 'COMMON.TORCNSTR'
7754       include 'COMMON.CONTROL'
7755       logical lprn
7756 C Set lprn=.true. for debugging
7757       lprn=.false.
7758 c     lprn=.true.
7759       etors=0.0D0
7760       do i=iphi_start,iphi_end
7761 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7762 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7763 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7764 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7765         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7766      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7767 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7768 C For introducing the NH3+ and COO- group please check the etor_d for reference
7769 C and guidance
7770         etors_ii=0.0D0
7771          if (iabs(itype(i)).eq.20) then
7772          iblock=2
7773          else
7774          iblock=1
7775          endif
7776         itori=itortyp(itype(i-2))
7777         itori1=itortyp(itype(i-1))
7778         phii=phi(i)
7779         gloci=0.0D0
7780 C Regular cosine and sine terms
7781         do j=1,nterm(itori,itori1,iblock)
7782           v1ij=v1(j,itori,itori1,iblock)
7783           v2ij=v2(j,itori,itori1,iblock)
7784           cosphi=dcos(j*phii)
7785           sinphi=dsin(j*phii)
7786           etors=etors+v1ij*cosphi+v2ij*sinphi
7787           if (energy_dec) etors_ii=etors_ii+
7788      &                v1ij*cosphi+v2ij*sinphi
7789           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7790         enddo
7791 C Lorentz terms
7792 C                         v1
7793 C  E = SUM ----------------------------------- - v1
7794 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7795 C
7796         cosphi=dcos(0.5d0*phii)
7797         sinphi=dsin(0.5d0*phii)
7798         do j=1,nlor(itori,itori1,iblock)
7799           vl1ij=vlor1(j,itori,itori1)
7800           vl2ij=vlor2(j,itori,itori1)
7801           vl3ij=vlor3(j,itori,itori1)
7802           pom=vl2ij*cosphi+vl3ij*sinphi
7803           pom1=1.0d0/(pom*pom+1.0d0)
7804           etors=etors+vl1ij*pom1
7805           if (energy_dec) etors_ii=etors_ii+
7806      &                vl1ij*pom1
7807           pom=-pom*pom1*pom1
7808           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7809         enddo
7810 C Subtract the constant term
7811         etors=etors-v0(itori,itori1,iblock)
7812           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7813      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7814         if (lprn)
7815      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7816      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7817      &  (v1(j,itori,itori1,iblock),j=1,6),
7818      &  (v2(j,itori,itori1,iblock),j=1,6)
7819         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7820 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7821       enddo
7822 ! 6/20/98 - dihedral angle constraints
7823       edihcnstr=0.0d0
7824 c      do i=1,ndih_constr
7825       do i=idihconstr_start,idihconstr_end
7826         itori=idih_constr(i)
7827         phii=phi(itori)
7828         difi=pinorm(phii-phi0(i))
7829         if (difi.gt.drange(i)) then
7830           difi=difi-drange(i)
7831           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7832           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7833         else if (difi.lt.-drange(i)) then
7834           difi=difi+drange(i)
7835           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7836           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7837         else
7838           difi=0.0
7839         endif
7840        if (energy_dec) then
7841         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7842      &    i,itori,rad2deg*phii,
7843      &    rad2deg*phi0(i),  rad2deg*drange(i),
7844      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7845         endif
7846       enddo
7847 cd       write (iout,*) 'edihcnstr',edihcnstr
7848       return
7849       end
7850 c----------------------------------------------------------------------------
7851       subroutine etor_d(etors_d)
7852 C 6/23/01 Compute double torsional energy
7853       implicit real*8 (a-h,o-z)
7854       include 'DIMENSIONS'
7855       include 'COMMON.VAR'
7856       include 'COMMON.GEO'
7857       include 'COMMON.LOCAL'
7858       include 'COMMON.TORSION'
7859       include 'COMMON.INTERACT'
7860       include 'COMMON.DERIV'
7861       include 'COMMON.CHAIN'
7862       include 'COMMON.NAMES'
7863       include 'COMMON.IOUNITS'
7864       include 'COMMON.FFIELD'
7865       include 'COMMON.TORCNSTR'
7866       logical lprn
7867 C Set lprn=.true. for debugging
7868       lprn=.false.
7869 c     lprn=.true.
7870       etors_d=0.0D0
7871 c      write(iout,*) "a tu??"
7872       do i=iphid_start,iphid_end
7873 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7874 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7875 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7876 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7877 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7878          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7879      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7880      &  (itype(i+1).eq.ntyp1)) cycle
7881 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7882         itori=itortyp(itype(i-2))
7883         itori1=itortyp(itype(i-1))
7884         itori2=itortyp(itype(i))
7885         phii=phi(i)
7886         phii1=phi(i+1)
7887         gloci1=0.0D0
7888         gloci2=0.0D0
7889         iblock=1
7890         if (iabs(itype(i+1)).eq.20) iblock=2
7891 C Iblock=2 Proline type
7892 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7893 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7894 C        if (itype(i+1).eq.ntyp1) iblock=3
7895 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7896 C IS or IS NOT need for this
7897 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7898 C        is (itype(i-3).eq.ntyp1) ntblock=2
7899 C        ntblock is N-terminal blocking group
7900
7901 C Regular cosine and sine terms
7902         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7903 C Example of changes for NH3+ blocking group
7904 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7905 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7906           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7907           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7908           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7909           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7910           cosphi1=dcos(j*phii)
7911           sinphi1=dsin(j*phii)
7912           cosphi2=dcos(j*phii1)
7913           sinphi2=dsin(j*phii1)
7914           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7915      &     v2cij*cosphi2+v2sij*sinphi2
7916           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7917           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7918         enddo
7919         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7920           do l=1,k-1
7921             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7922             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7923             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7924             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7925             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7926             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7927             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7928             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7929             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7930      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7931             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7932      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7933             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7934      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7935           enddo
7936         enddo
7937         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7938         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7939       enddo
7940       return
7941       end
7942 #endif
7943 C----------------------------------------------------------------------------------
7944 C The rigorous attempt to derive energy function
7945       subroutine etor_kcc(etors,edihcnstr)
7946       implicit real*8 (a-h,o-z)
7947       include 'DIMENSIONS'
7948       include 'COMMON.VAR'
7949       include 'COMMON.GEO'
7950       include 'COMMON.LOCAL'
7951       include 'COMMON.TORSION'
7952       include 'COMMON.INTERACT'
7953       include 'COMMON.DERIV'
7954       include 'COMMON.CHAIN'
7955       include 'COMMON.NAMES'
7956       include 'COMMON.IOUNITS'
7957       include 'COMMON.FFIELD'
7958       include 'COMMON.TORCNSTR'
7959       include 'COMMON.CONTROL'
7960       logical lprn
7961 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7962 C Set lprn=.true. for debugging
7963       lprn=.false.
7964 c     lprn=.true.
7965 C      print *,"wchodze kcc"
7966       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7967       if (tor_mode.ne.2) then
7968       etors=0.0D0
7969       endif
7970       do i=iphi_start,iphi_end
7971 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7972 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7973 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7974 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7975         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7976      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7977         itori=itortyp_kcc(itype(i-2))
7978         itori1=itortyp_kcc(itype(i-1))
7979         phii=phi(i)
7980         glocig=0.0D0
7981         glocit1=0.0d0
7982         glocit2=0.0d0
7983         sumnonchebyshev=0.0d0
7984         sumchebyshev=0.0d0
7985 C to avoid multiple devision by 2
7986 c        theti22=0.5d0*theta(i)
7987 C theta 12 is the theta_1 /2
7988 C theta 22 is theta_2 /2
7989 c        theti12=0.5d0*theta(i-1)
7990 C and appropriate sinus function
7991         sinthet1=dsin(theta(i-1))
7992         sinthet2=dsin(theta(i))
7993         costhet1=dcos(theta(i-1))
7994         costhet2=dcos(theta(i))
7995 c Cosines of halves thetas
7996         costheti12=0.5d0*(1.0d0+costhet1)
7997         costheti22=0.5d0*(1.0d0+costhet2)
7998 C to speed up lets store its mutliplication
7999         sint1t2=sinthet2*sinthet1
8000         sint1t2n=1.0d0
8001 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
8002 C +d_n*sin(n*gamma)) *
8003 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
8004 C we have two sum 1) Non-Chebyshev which is with n and gamma
8005         etori=0.0d0
8006         do j=1,nterm_kcc(itori,itori1)
8007
8008           nval=nterm_kcc_Tb(itori,itori1)
8009           v1ij=v1_kcc(j,itori,itori1)
8010           v2ij=v2_kcc(j,itori,itori1)
8011 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
8012 C v1ij is c_n and d_n in euation above
8013           cosphi=dcos(j*phii)
8014           sinphi=dsin(j*phii)
8015           sint1t2n1=sint1t2n
8016           sint1t2n=sint1t2n*sint1t2
8017           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
8018      &        costheti12)
8019           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8020      &        v11_chyb(1,j,itori,itori1),costheti12)
8021 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
8022 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
8023           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
8024      &        costheti22)
8025           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8026      &        v21_chyb(1,j,itori,itori1),costheti22)
8027 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
8028 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
8029           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
8030      &        costheti12)
8031           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8032      &        v12_chyb(1,j,itori,itori1),costheti12)
8033 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8034 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8035           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8036      &        costheti22)
8037           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8038      &        v22_chyb(1,j,itori,itori1),costheti22)
8039 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8040 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8041 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8042 C          if (energy_dec) etors_ii=etors_ii+
8043 C     &                v1ij*cosphi+v2ij*sinphi
8044 C glocig is the gradient local i site in gamma
8045           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8046           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8047           etori=etori+sint1t2n*(actval1+actval2)
8048           glocig=glocig+
8049      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8050      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8051 C now gradient over theta_1
8052           glocit1=glocit1+
8053      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8054      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8055           glocit2=glocit2+
8056      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8057      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8058
8059 C now the Czebyshev polinominal sum
8060 c        do k=1,nterm_kcc_Tb(itori,itori1)
8061 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
8062 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
8063 C         thybt1(k)=0.0
8064 C         thybt2(k)=0.0
8065 c        enddo
8066 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8067 C     &         gradtschebyshev
8068 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8069 C     &         dcos(theti22)**2),
8070 C     &         dsin(theti22)
8071
8072 C now overal sumation
8073 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8074         enddo ! j
8075         etors=etors+etori
8076 C derivative over gamma
8077         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8078 C derivative over theta1
8079         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8080 C now derivative over theta2
8081         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8082         if (lprn)
8083      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8084      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8085       enddo
8086 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8087 ! 6/20/98 - dihedral angle constraints
8088       if (tor_mode.ne.2) then
8089       edihcnstr=0.0d0
8090 c      do i=1,ndih_constr
8091       do i=idihconstr_start,idihconstr_end
8092         itori=idih_constr(i)
8093         phii=phi(itori)
8094         difi=pinorm(phii-phi0(i))
8095         if (difi.gt.drange(i)) then
8096           difi=difi-drange(i)
8097           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8098           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8099         else if (difi.lt.-drange(i)) then
8100           difi=difi+drange(i)
8101           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8102           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8103         else
8104           difi=0.0
8105         endif
8106        enddo
8107        endif
8108       return
8109       end
8110
8111 C The rigorous attempt to derive energy function
8112       subroutine ebend_kcc(etheta,ethetacnstr)
8113
8114       implicit real*8 (a-h,o-z)
8115       include 'DIMENSIONS'
8116       include 'COMMON.VAR'
8117       include 'COMMON.GEO'
8118       include 'COMMON.LOCAL'
8119       include 'COMMON.TORSION'
8120       include 'COMMON.INTERACT'
8121       include 'COMMON.DERIV'
8122       include 'COMMON.CHAIN'
8123       include 'COMMON.NAMES'
8124       include 'COMMON.IOUNITS'
8125       include 'COMMON.FFIELD'
8126       include 'COMMON.TORCNSTR'
8127       include 'COMMON.CONTROL'
8128       logical lprn
8129       double precision thybt1(maxtermkcc)
8130 C Set lprn=.true. for debugging
8131       lprn=.false.
8132 c     lprn=.true.
8133 C      print *,"wchodze kcc"
8134       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8135       if (tor_mode.ne.2) etheta=0.0D0
8136       do i=ithet_start,ithet_end
8137 c        print *,i,itype(i-1),itype(i),itype(i-2)
8138         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8139      &  .or.itype(i).eq.ntyp1) cycle
8140          iti=itortyp_kcc(itype(i-1))
8141         sinthet=dsin(theta(i)/2.0d0)
8142         costhet=dcos(theta(i)/2.0d0)
8143          do j=1,nbend_kcc_Tb(iti)
8144           thybt1(j)=v1bend_chyb(j,iti)
8145          enddo
8146          sumth1thyb=tschebyshev
8147      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8148         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8149      &    sumth1thyb
8150         ihelp=nbend_kcc_Tb(iti)-1
8151         gradthybt1=gradtschebyshev
8152      &         (0,ihelp,thybt1(1),costhet)
8153         etheta=etheta+sumth1thyb
8154 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8155         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8156      &   gradthybt1*sinthet*(-0.5d0)
8157       enddo
8158       if (tor_mode.ne.2) then
8159       ethetacnstr=0.0d0
8160 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8161       do i=ithetaconstr_start,ithetaconstr_end
8162         itheta=itheta_constr(i)
8163         thetiii=theta(itheta)
8164         difi=pinorm(thetiii-theta_constr0(i))
8165         if (difi.gt.theta_drange(i)) then
8166           difi=difi-theta_drange(i)
8167           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8168           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8169      &    +for_thet_constr(i)*difi**3
8170         else if (difi.lt.-drange(i)) then
8171           difi=difi+drange(i)
8172           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8173           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8174      &    +for_thet_constr(i)*difi**3
8175         else
8176           difi=0.0
8177         endif
8178        if (energy_dec) then
8179         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8180      &    i,itheta,rad2deg*thetiii,
8181      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8182      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8183      &    gloc(itheta+nphi-2,icg)
8184         endif
8185       enddo
8186       endif
8187       return
8188       end
8189 c------------------------------------------------------------------------------
8190       subroutine eback_sc_corr(esccor)
8191 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8192 c        conformational states; temporarily implemented as differences
8193 c        between UNRES torsional potentials (dependent on three types of
8194 c        residues) and the torsional potentials dependent on all 20 types
8195 c        of residues computed from AM1  energy surfaces of terminally-blocked
8196 c        amino-acid residues.
8197       implicit real*8 (a-h,o-z)
8198       include 'DIMENSIONS'
8199       include 'COMMON.VAR'
8200       include 'COMMON.GEO'
8201       include 'COMMON.LOCAL'
8202       include 'COMMON.TORSION'
8203       include 'COMMON.SCCOR'
8204       include 'COMMON.INTERACT'
8205       include 'COMMON.DERIV'
8206       include 'COMMON.CHAIN'
8207       include 'COMMON.NAMES'
8208       include 'COMMON.IOUNITS'
8209       include 'COMMON.FFIELD'
8210       include 'COMMON.CONTROL'
8211       logical lprn
8212 C Set lprn=.true. for debugging
8213       lprn=.false.
8214 c      lprn=.true.
8215 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8216       esccor=0.0D0
8217       do i=itau_start,itau_end
8218         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8219         esccor_ii=0.0D0
8220         isccori=isccortyp(itype(i-2))
8221         isccori1=isccortyp(itype(i-1))
8222 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8223         phii=phi(i)
8224         do intertyp=1,3 !intertyp
8225 cc Added 09 May 2012 (Adasko)
8226 cc  Intertyp means interaction type of backbone mainchain correlation:
8227 c   1 = SC...Ca...Ca...Ca
8228 c   2 = Ca...Ca...Ca...SC
8229 c   3 = SC...Ca...Ca...SCi
8230         gloci=0.0D0
8231         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8232      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8233      &      (itype(i-1).eq.ntyp1)))
8234      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8235      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8236      &     .or.(itype(i).eq.ntyp1)))
8237      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8238      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8239      &      (itype(i-3).eq.ntyp1)))) cycle
8240         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8241         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8242      & cycle
8243        do j=1,nterm_sccor(isccori,isccori1)
8244           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8245           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8246           cosphi=dcos(j*tauangle(intertyp,i))
8247           sinphi=dsin(j*tauangle(intertyp,i))
8248           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8249           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8250         enddo
8251         if (energy_dec) write(iout,'(a9,2i4,f8.3,3i4)') "esccor",i,j,
8252      & esccor,intertyp,
8253      & isccori, isccori1
8254 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8255         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8256         if (lprn)
8257      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8258      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8259      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8260      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8261         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8262        enddo !intertyp
8263       enddo
8264
8265       return
8266       end
8267 c----------------------------------------------------------------------------
8268       subroutine multibody(ecorr)
8269 C This subroutine calculates multi-body contributions to energy following
8270 C the idea of Skolnick et al. If side chains I and J make a contact and
8271 C at the same time side chains I+1 and J+1 make a contact, an extra
8272 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8273       implicit real*8 (a-h,o-z)
8274       include 'DIMENSIONS'
8275       include 'COMMON.IOUNITS'
8276       include 'COMMON.DERIV'
8277       include 'COMMON.INTERACT'
8278       include 'COMMON.CONTACTS'
8279       double precision gx(3),gx1(3)
8280       logical lprn
8281
8282 C Set lprn=.true. for debugging
8283       lprn=.false.
8284
8285       if (lprn) then
8286         write (iout,'(a)') 'Contact function values:'
8287         do i=nnt,nct-2
8288           write (iout,'(i2,20(1x,i2,f10.5))')
8289      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8290         enddo
8291       endif
8292       ecorr=0.0D0
8293       do i=nnt,nct
8294         do j=1,3
8295           gradcorr(j,i)=0.0D0
8296           gradxorr(j,i)=0.0D0
8297         enddo
8298       enddo
8299       do i=nnt,nct-2
8300
8301         DO ISHIFT = 3,4
8302
8303         i1=i+ishift
8304         num_conti=num_cont(i)
8305         num_conti1=num_cont(i1)
8306         do jj=1,num_conti
8307           j=jcont(jj,i)
8308           do kk=1,num_conti1
8309             j1=jcont(kk,i1)
8310             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8311 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8312 cd   &                   ' ishift=',ishift
8313 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8314 C The system gains extra energy.
8315               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8316             endif   ! j1==j+-ishift
8317           enddo     ! kk
8318         enddo       ! jj
8319
8320         ENDDO ! ISHIFT
8321
8322       enddo         ! i
8323       return
8324       end
8325 c------------------------------------------------------------------------------
8326       double precision function esccorr(i,j,k,l,jj,kk)
8327       implicit real*8 (a-h,o-z)
8328       include 'DIMENSIONS'
8329       include 'COMMON.IOUNITS'
8330       include 'COMMON.DERIV'
8331       include 'COMMON.INTERACT'
8332       include 'COMMON.CONTACTS'
8333       include 'COMMON.SHIELD'
8334       double precision gx(3),gx1(3)
8335       logical lprn
8336       lprn=.false.
8337       eij=facont(jj,i)
8338       ekl=facont(kk,k)
8339 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8340 C Calculate the multi-body contribution to energy.
8341 C Calculate multi-body contributions to the gradient.
8342 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8343 cd   & k,l,(gacont(m,kk,k),m=1,3)
8344       do m=1,3
8345         gx(m) =ekl*gacont(m,jj,i)
8346         gx1(m)=eij*gacont(m,kk,k)
8347         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8348         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8349         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8350         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8351       enddo
8352       do m=i,j-1
8353         do ll=1,3
8354           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8355         enddo
8356       enddo
8357       do m=k,l-1
8358         do ll=1,3
8359           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8360         enddo
8361       enddo
8362       esccorr=-eij*ekl
8363       return
8364       end
8365 c------------------------------------------------------------------------------
8366       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8367 C This subroutine calculates multi-body contributions to hydrogen-bonding
8368       implicit real*8 (a-h,o-z)
8369       include 'DIMENSIONS'
8370       include 'COMMON.IOUNITS'
8371 #ifdef MPI
8372       include "mpif.h"
8373       parameter (max_cont=maxconts)
8374       parameter (max_dim=26)
8375       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8376       double precision zapas(max_dim,maxconts,max_fg_procs),
8377      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8378       common /przechowalnia/ zapas
8379       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8380      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8381 #endif
8382       include 'COMMON.SETUP'
8383       include 'COMMON.FFIELD'
8384       include 'COMMON.DERIV'
8385       include 'COMMON.INTERACT'
8386       include 'COMMON.CONTACTS'
8387       include 'COMMON.CONTROL'
8388       include 'COMMON.LOCAL'
8389       double precision gx(3),gx1(3),time00
8390       logical lprn,ldone
8391
8392 C Set lprn=.true. for debugging
8393       lprn=.false.
8394 #ifdef MPI
8395       n_corr=0
8396       n_corr1=0
8397       if (nfgtasks.le.1) goto 30
8398       if (lprn) then
8399         write (iout,'(a)') 'Contact function values before RECEIVE:'
8400         do i=nnt,nct-2
8401           write (iout,'(2i3,50(1x,i2,f5.2))')
8402      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8403      &    j=1,num_cont_hb(i))
8404         enddo
8405       endif
8406       call flush(iout)
8407       do i=1,ntask_cont_from
8408         ncont_recv(i)=0
8409       enddo
8410       do i=1,ntask_cont_to
8411         ncont_sent(i)=0
8412       enddo
8413 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8414 c     & ntask_cont_to
8415 C Make the list of contacts to send to send to other procesors
8416 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8417 c      call flush(iout)
8418       do i=iturn3_start,iturn3_end
8419 c        write (iout,*) "make contact list turn3",i," num_cont",
8420 c     &    num_cont_hb(i)
8421         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8422       enddo
8423       do i=iturn4_start,iturn4_end
8424 c        write (iout,*) "make contact list turn4",i," num_cont",
8425 c     &   num_cont_hb(i)
8426         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8427       enddo
8428       do ii=1,nat_sent
8429         i=iat_sent(ii)
8430 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8431 c     &    num_cont_hb(i)
8432         do j=1,num_cont_hb(i)
8433         do k=1,4
8434           jjc=jcont_hb(j,i)
8435           iproc=iint_sent_local(k,jjc,ii)
8436 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8437           if (iproc.gt.0) then
8438             ncont_sent(iproc)=ncont_sent(iproc)+1
8439             nn=ncont_sent(iproc)
8440             zapas(1,nn,iproc)=i
8441             zapas(2,nn,iproc)=jjc
8442             zapas(3,nn,iproc)=facont_hb(j,i)
8443             zapas(4,nn,iproc)=ees0p(j,i)
8444             zapas(5,nn,iproc)=ees0m(j,i)
8445             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8446             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8447             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8448             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8449             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8450             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8451             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8452             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8453             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8454             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8455             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8456             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8457             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8458             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8459             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8460             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8461             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8462             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8463             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8464             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8465             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8466           endif
8467         enddo
8468         enddo
8469       enddo
8470       if (lprn) then
8471       write (iout,*)
8472      &  "Numbers of contacts to be sent to other processors",
8473      &  (ncont_sent(i),i=1,ntask_cont_to)
8474       write (iout,*) "Contacts sent"
8475       do ii=1,ntask_cont_to
8476         nn=ncont_sent(ii)
8477         iproc=itask_cont_to(ii)
8478         write (iout,*) nn," contacts to processor",iproc,
8479      &   " of CONT_TO_COMM group"
8480         do i=1,nn
8481           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8482         enddo
8483       enddo
8484       call flush(iout)
8485       endif
8486       CorrelType=477
8487       CorrelID=fg_rank+1
8488       CorrelType1=478
8489       CorrelID1=nfgtasks+fg_rank+1
8490       ireq=0
8491 C Receive the numbers of needed contacts from other processors
8492       do ii=1,ntask_cont_from
8493         iproc=itask_cont_from(ii)
8494         ireq=ireq+1
8495         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8496      &    FG_COMM,req(ireq),IERR)
8497       enddo
8498 c      write (iout,*) "IRECV ended"
8499 c      call flush(iout)
8500 C Send the number of contacts needed by other processors
8501       do ii=1,ntask_cont_to
8502         iproc=itask_cont_to(ii)
8503         ireq=ireq+1
8504         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8505      &    FG_COMM,req(ireq),IERR)
8506       enddo
8507 c      write (iout,*) "ISEND ended"
8508 c      write (iout,*) "number of requests (nn)",ireq
8509       call flush(iout)
8510       if (ireq.gt.0)
8511      &  call MPI_Waitall(ireq,req,status_array,ierr)
8512 c      write (iout,*)
8513 c     &  "Numbers of contacts to be received from other processors",
8514 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8515 c      call flush(iout)
8516 C Receive contacts
8517       ireq=0
8518       do ii=1,ntask_cont_from
8519         iproc=itask_cont_from(ii)
8520         nn=ncont_recv(ii)
8521 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8522 c     &   " of CONT_TO_COMM group"
8523         call flush(iout)
8524         if (nn.gt.0) then
8525           ireq=ireq+1
8526           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8527      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8528 c          write (iout,*) "ireq,req",ireq,req(ireq)
8529         endif
8530       enddo
8531 C Send the contacts to processors that need them
8532       do ii=1,ntask_cont_to
8533         iproc=itask_cont_to(ii)
8534         nn=ncont_sent(ii)
8535 c        write (iout,*) nn," contacts to processor",iproc,
8536 c     &   " of CONT_TO_COMM group"
8537         if (nn.gt.0) then
8538           ireq=ireq+1
8539           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8540      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8541 c          write (iout,*) "ireq,req",ireq,req(ireq)
8542 c          do i=1,nn
8543 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8544 c          enddo
8545         endif
8546       enddo
8547 c      write (iout,*) "number of requests (contacts)",ireq
8548 c      write (iout,*) "req",(req(i),i=1,4)
8549 c      call flush(iout)
8550       if (ireq.gt.0)
8551      & call MPI_Waitall(ireq,req,status_array,ierr)
8552       do iii=1,ntask_cont_from
8553         iproc=itask_cont_from(iii)
8554         nn=ncont_recv(iii)
8555         if (lprn) then
8556         write (iout,*) "Received",nn," contacts from processor",iproc,
8557      &   " of CONT_FROM_COMM group"
8558         call flush(iout)
8559         do i=1,nn
8560           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8561         enddo
8562         call flush(iout)
8563         endif
8564         do i=1,nn
8565           ii=zapas_recv(1,i,iii)
8566 c Flag the received contacts to prevent double-counting
8567           jj=-zapas_recv(2,i,iii)
8568 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8569 c          call flush(iout)
8570           nnn=num_cont_hb(ii)+1
8571           num_cont_hb(ii)=nnn
8572           jcont_hb(nnn,ii)=jj
8573           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8574           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8575           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8576           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8577           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8578           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8579           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8580           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8581           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8582           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8583           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8584           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8585           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8586           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8587           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8588           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8589           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8590           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8591           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8592           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8593           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8594           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8595           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8596           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8597         enddo
8598       enddo
8599       call flush(iout)
8600       if (lprn) then
8601         write (iout,'(a)') 'Contact function values after receive:'
8602         do i=nnt,nct-2
8603           write (iout,'(2i3,50(1x,i3,f5.2))')
8604      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8605      &    j=1,num_cont_hb(i))
8606         enddo
8607         call flush(iout)
8608       endif
8609    30 continue
8610 #endif
8611       if (lprn) then
8612         write (iout,'(a)') 'Contact function values:'
8613         do i=nnt,nct-2
8614           write (iout,'(2i3,50(1x,i3,f5.2))')
8615      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8616      &    j=1,num_cont_hb(i))
8617         enddo
8618       endif
8619       ecorr=0.0D0
8620 C Remove the loop below after debugging !!!
8621       do i=nnt,nct
8622         do j=1,3
8623           gradcorr(j,i)=0.0D0
8624           gradxorr(j,i)=0.0D0
8625         enddo
8626       enddo
8627 C Calculate the local-electrostatic correlation terms
8628       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8629         i1=i+1
8630         num_conti=num_cont_hb(i)
8631         num_conti1=num_cont_hb(i+1)
8632         do jj=1,num_conti
8633           j=jcont_hb(jj,i)
8634           jp=iabs(j)
8635           do kk=1,num_conti1
8636             j1=jcont_hb(kk,i1)
8637             jp1=iabs(j1)
8638 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8639 c     &         ' jj=',jj,' kk=',kk
8640             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8641      &          .or. j.lt.0 .and. j1.gt.0) .and.
8642      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8643 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8644 C The system gains extra energy.
8645               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8646               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8647      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8648               n_corr=n_corr+1
8649             else if (j1.eq.j) then
8650 C Contacts I-J and I-(J+1) occur simultaneously.
8651 C The system loses extra energy.
8652 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8653             endif
8654           enddo ! kk
8655           do kk=1,num_conti
8656             j1=jcont_hb(kk,i)
8657 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8658 c    &         ' jj=',jj,' kk=',kk
8659             if (j1.eq.j+1) then
8660 C Contacts I-J and (I+1)-J occur simultaneously.
8661 C The system loses extra energy.
8662 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8663             endif ! j1==j+1
8664           enddo ! kk
8665         enddo ! jj
8666       enddo ! i
8667       return
8668       end
8669 c------------------------------------------------------------------------------
8670       subroutine add_hb_contact(ii,jj,itask)
8671       implicit real*8 (a-h,o-z)
8672       include "DIMENSIONS"
8673       include "COMMON.IOUNITS"
8674       integer max_cont
8675       integer max_dim
8676       parameter (max_cont=maxconts)
8677       parameter (max_dim=26)
8678       include "COMMON.CONTACTS"
8679       double precision zapas(max_dim,maxconts,max_fg_procs),
8680      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8681       common /przechowalnia/ zapas
8682       integer i,j,ii,jj,iproc,itask(4),nn
8683 c      write (iout,*) "itask",itask
8684       do i=1,2
8685         iproc=itask(i)
8686         if (iproc.gt.0) then
8687           do j=1,num_cont_hb(ii)
8688             jjc=jcont_hb(j,ii)
8689 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8690             if (jjc.eq.jj) then
8691               ncont_sent(iproc)=ncont_sent(iproc)+1
8692               nn=ncont_sent(iproc)
8693               zapas(1,nn,iproc)=ii
8694               zapas(2,nn,iproc)=jjc
8695               zapas(3,nn,iproc)=facont_hb(j,ii)
8696               zapas(4,nn,iproc)=ees0p(j,ii)
8697               zapas(5,nn,iproc)=ees0m(j,ii)
8698               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8699               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8700               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8701               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8702               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8703               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8704               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8705               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8706               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8707               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8708               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8709               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8710               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8711               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8712               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8713               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8714               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8715               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8716               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8717               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8718               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8719               exit
8720             endif
8721           enddo
8722         endif
8723       enddo
8724       return
8725       end
8726 c------------------------------------------------------------------------------
8727       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8728      &  n_corr1)
8729 C This subroutine calculates multi-body contributions to hydrogen-bonding
8730       implicit real*8 (a-h,o-z)
8731       include 'DIMENSIONS'
8732       include 'COMMON.IOUNITS'
8733 #ifdef MPI
8734       include "mpif.h"
8735       parameter (max_cont=maxconts)
8736       parameter (max_dim=70)
8737       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8738       double precision zapas(max_dim,maxconts,max_fg_procs),
8739      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8740       common /przechowalnia/ zapas
8741       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8742      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8743 #endif
8744       include 'COMMON.SETUP'
8745       include 'COMMON.FFIELD'
8746       include 'COMMON.DERIV'
8747       include 'COMMON.LOCAL'
8748       include 'COMMON.INTERACT'
8749       include 'COMMON.CONTACTS'
8750       include 'COMMON.CHAIN'
8751       include 'COMMON.CONTROL'
8752       include 'COMMON.SHIELD'
8753       double precision gx(3),gx1(3)
8754       integer num_cont_hb_old(maxres)
8755       logical lprn,ldone
8756       double precision eello4,eello5,eelo6,eello_turn6
8757       external eello4,eello5,eello6,eello_turn6
8758 C Set lprn=.true. for debugging
8759       lprn=.false.
8760       eturn6=0.0d0
8761 #ifdef MPI
8762       do i=1,nres
8763         num_cont_hb_old(i)=num_cont_hb(i)
8764       enddo
8765       n_corr=0
8766       n_corr1=0
8767       if (nfgtasks.le.1) goto 30
8768       if (lprn) then
8769         write (iout,'(a)') 'Contact function values before RECEIVE:'
8770         do i=nnt,nct-2
8771           write (iout,'(2i3,50(1x,i2,f5.2))')
8772      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8773      &    j=1,num_cont_hb(i))
8774         enddo
8775       endif
8776       call flush(iout)
8777       do i=1,ntask_cont_from
8778         ncont_recv(i)=0
8779       enddo
8780       do i=1,ntask_cont_to
8781         ncont_sent(i)=0
8782       enddo
8783 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8784 c     & ntask_cont_to
8785 C Make the list of contacts to send to send to other procesors
8786       do i=iturn3_start,iturn3_end
8787 c        write (iout,*) "make contact list turn3",i," num_cont",
8788 c     &    num_cont_hb(i)
8789         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8790       enddo
8791       do i=iturn4_start,iturn4_end
8792 c        write (iout,*) "make contact list turn4",i," num_cont",
8793 c     &   num_cont_hb(i)
8794         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8795       enddo
8796       do ii=1,nat_sent
8797         i=iat_sent(ii)
8798 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8799 c     &    num_cont_hb(i)
8800         do j=1,num_cont_hb(i)
8801         do k=1,4
8802           jjc=jcont_hb(j,i)
8803           iproc=iint_sent_local(k,jjc,ii)
8804 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8805           if (iproc.ne.0) then
8806             ncont_sent(iproc)=ncont_sent(iproc)+1
8807             nn=ncont_sent(iproc)
8808             zapas(1,nn,iproc)=i
8809             zapas(2,nn,iproc)=jjc
8810             zapas(3,nn,iproc)=d_cont(j,i)
8811             ind=3
8812             do kk=1,3
8813               ind=ind+1
8814               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8815             enddo
8816             do kk=1,2
8817               do ll=1,2
8818                 ind=ind+1
8819                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8820               enddo
8821             enddo
8822             do jj=1,5
8823               do kk=1,3
8824                 do ll=1,2
8825                   do mm=1,2
8826                     ind=ind+1
8827                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8828                   enddo
8829                 enddo
8830               enddo
8831             enddo
8832           endif
8833         enddo
8834         enddo
8835       enddo
8836       if (lprn) then
8837       write (iout,*)
8838      &  "Numbers of contacts to be sent to other processors",
8839      &  (ncont_sent(i),i=1,ntask_cont_to)
8840       write (iout,*) "Contacts sent"
8841       do ii=1,ntask_cont_to
8842         nn=ncont_sent(ii)
8843         iproc=itask_cont_to(ii)
8844         write (iout,*) nn," contacts to processor",iproc,
8845      &   " of CONT_TO_COMM group"
8846         do i=1,nn
8847           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8848         enddo
8849       enddo
8850       call flush(iout)
8851       endif
8852       CorrelType=477
8853       CorrelID=fg_rank+1
8854       CorrelType1=478
8855       CorrelID1=nfgtasks+fg_rank+1
8856       ireq=0
8857 C Receive the numbers of needed contacts from other processors
8858       do ii=1,ntask_cont_from
8859         iproc=itask_cont_from(ii)
8860         ireq=ireq+1
8861         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8862      &    FG_COMM,req(ireq),IERR)
8863       enddo
8864 c      write (iout,*) "IRECV ended"
8865 c      call flush(iout)
8866 C Send the number of contacts needed by other processors
8867       do ii=1,ntask_cont_to
8868         iproc=itask_cont_to(ii)
8869         ireq=ireq+1
8870         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8871      &    FG_COMM,req(ireq),IERR)
8872       enddo
8873 c      write (iout,*) "ISEND ended"
8874 c      write (iout,*) "number of requests (nn)",ireq
8875       call flush(iout)
8876       if (ireq.gt.0)
8877      &  call MPI_Waitall(ireq,req,status_array,ierr)
8878 c      write (iout,*)
8879 c     &  "Numbers of contacts to be received from other processors",
8880 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8881 c      call flush(iout)
8882 C Receive contacts
8883       ireq=0
8884       do ii=1,ntask_cont_from
8885         iproc=itask_cont_from(ii)
8886         nn=ncont_recv(ii)
8887 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8888 c     &   " of CONT_TO_COMM group"
8889         call flush(iout)
8890         if (nn.gt.0) then
8891           ireq=ireq+1
8892           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8893      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8894 c          write (iout,*) "ireq,req",ireq,req(ireq)
8895         endif
8896       enddo
8897 C Send the contacts to processors that need them
8898       do ii=1,ntask_cont_to
8899         iproc=itask_cont_to(ii)
8900         nn=ncont_sent(ii)
8901 c        write (iout,*) nn," contacts to processor",iproc,
8902 c     &   " of CONT_TO_COMM group"
8903         if (nn.gt.0) then
8904           ireq=ireq+1
8905           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8906      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8907 c          write (iout,*) "ireq,req",ireq,req(ireq)
8908 c          do i=1,nn
8909 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8910 c          enddo
8911         endif
8912       enddo
8913 c      write (iout,*) "number of requests (contacts)",ireq
8914 c      write (iout,*) "req",(req(i),i=1,4)
8915 c      call flush(iout)
8916       if (ireq.gt.0)
8917      & call MPI_Waitall(ireq,req,status_array,ierr)
8918       do iii=1,ntask_cont_from
8919         iproc=itask_cont_from(iii)
8920         nn=ncont_recv(iii)
8921         if (lprn) then
8922         write (iout,*) "Received",nn," contacts from processor",iproc,
8923      &   " of CONT_FROM_COMM group"
8924         call flush(iout)
8925         do i=1,nn
8926           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8927         enddo
8928         call flush(iout)
8929         endif
8930         do i=1,nn
8931           ii=zapas_recv(1,i,iii)
8932 c Flag the received contacts to prevent double-counting
8933           jj=-zapas_recv(2,i,iii)
8934 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8935 c          call flush(iout)
8936           nnn=num_cont_hb(ii)+1
8937           num_cont_hb(ii)=nnn
8938           jcont_hb(nnn,ii)=jj
8939           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8940           ind=3
8941           do kk=1,3
8942             ind=ind+1
8943             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8944           enddo
8945           do kk=1,2
8946             do ll=1,2
8947               ind=ind+1
8948               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8949             enddo
8950           enddo
8951           do jj=1,5
8952             do kk=1,3
8953               do ll=1,2
8954                 do mm=1,2
8955                   ind=ind+1
8956                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8957                 enddo
8958               enddo
8959             enddo
8960           enddo
8961         enddo
8962       enddo
8963       call flush(iout)
8964       if (lprn) then
8965         write (iout,'(a)') 'Contact function values after receive:'
8966         do i=nnt,nct-2
8967           write (iout,'(2i3,50(1x,i3,5f6.3))')
8968      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8969      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8970         enddo
8971         call flush(iout)
8972       endif
8973    30 continue
8974 #endif
8975       if (lprn) then
8976         write (iout,'(a)') 'Contact function values:'
8977         do i=nnt,nct-2
8978           write (iout,'(2i3,50(1x,i2,5f6.3))')
8979      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8980      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8981         enddo
8982       endif
8983       ecorr=0.0D0
8984       ecorr5=0.0d0
8985       ecorr6=0.0d0
8986 C Remove the loop below after debugging !!!
8987       do i=nnt,nct
8988         do j=1,3
8989           gradcorr(j,i)=0.0D0
8990           gradxorr(j,i)=0.0D0
8991         enddo
8992       enddo
8993 C Calculate the dipole-dipole interaction energies
8994       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8995       do i=iatel_s,iatel_e+1
8996         num_conti=num_cont_hb(i)
8997         do jj=1,num_conti
8998           j=jcont_hb(jj,i)
8999 #ifdef MOMENT
9000           call dipole(i,j,jj)
9001 #endif
9002         enddo
9003       enddo
9004       endif
9005 C Calculate the local-electrostatic correlation terms
9006 c                write (iout,*) "gradcorr5 in eello5 before loop"
9007 c                do iii=1,nres
9008 c                  write (iout,'(i5,3f10.5)')
9009 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9010 c                enddo
9011       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9012 c        write (iout,*) "corr loop i",i
9013         i1=i+1
9014         num_conti=num_cont_hb(i)
9015         num_conti1=num_cont_hb(i+1)
9016         do jj=1,num_conti
9017           j=jcont_hb(jj,i)
9018           jp=iabs(j)
9019           do kk=1,num_conti1
9020             j1=jcont_hb(kk,i1)
9021             jp1=iabs(j1)
9022 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9023 c     &         ' jj=',jj,' kk=',kk
9024 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9025             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9026      &          .or. j.lt.0 .and. j1.gt.0) .and.
9027      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9028 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9029 C The system gains extra energy.
9030               n_corr=n_corr+1
9031               sqd1=dsqrt(d_cont(jj,i))
9032               sqd2=dsqrt(d_cont(kk,i1))
9033               sred_geom = sqd1*sqd2
9034               IF (sred_geom.lt.cutoff_corr) THEN
9035                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9036      &            ekont,fprimcont)
9037 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9038 cd     &         ' jj=',jj,' kk=',kk
9039                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9040                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9041                 do l=1,3
9042                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9043                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9044                 enddo
9045                 n_corr1=n_corr1+1
9046 cd               write (iout,*) 'sred_geom=',sred_geom,
9047 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9048 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9049 cd               write (iout,*) "g_contij",g_contij
9050 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9051 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9052                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9053                 if (wcorr4.gt.0.0d0)
9054      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9055 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9056                   if (energy_dec.and.wcorr4.gt.0.0d0)
9057      1                 write (iout,'(a6,4i5,0pf7.3)')
9058      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9059 c                write (iout,*) "gradcorr5 before eello5"
9060 c                do iii=1,nres
9061 c                  write (iout,'(i5,3f10.5)')
9062 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9063 c                enddo
9064                 if (wcorr5.gt.0.0d0)
9065      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9066 c                write (iout,*) "gradcorr5 after eello5"
9067 c                do iii=1,nres
9068 c                  write (iout,'(i5,3f10.5)')
9069 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9070 c                enddo
9071                   if (energy_dec.and.wcorr5.gt.0.0d0)
9072      1                 write (iout,'(a6,4i5,0pf7.3)')
9073      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9074 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9075 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9076                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9077      &               .or. wturn6.eq.0.0d0))then
9078 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9079                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9080                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9081      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9082 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9083 cd     &            'ecorr6=',ecorr6
9084 cd                write (iout,'(4e15.5)') sred_geom,
9085 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9086 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9087 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9088                 else if (wturn6.gt.0.0d0
9089      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9090 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9091                   eturn6=eturn6+eello_turn6(i,jj,kk)
9092                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9093      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9094 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9095                 endif
9096               ENDIF
9097 1111          continue
9098             endif
9099           enddo ! kk
9100         enddo ! jj
9101       enddo ! i
9102       do i=1,nres
9103         num_cont_hb(i)=num_cont_hb_old(i)
9104       enddo
9105 c                write (iout,*) "gradcorr5 in eello5"
9106 c                do iii=1,nres
9107 c                  write (iout,'(i5,3f10.5)')
9108 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9109 c                enddo
9110       return
9111       end
9112 c------------------------------------------------------------------------------
9113       subroutine add_hb_contact_eello(ii,jj,itask)
9114       implicit real*8 (a-h,o-z)
9115       include "DIMENSIONS"
9116       include "COMMON.IOUNITS"
9117       integer max_cont
9118       integer max_dim
9119       parameter (max_cont=maxconts)
9120       parameter (max_dim=70)
9121       include "COMMON.CONTACTS"
9122       double precision zapas(max_dim,maxconts,max_fg_procs),
9123      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9124       common /przechowalnia/ zapas
9125       integer i,j,ii,jj,iproc,itask(4),nn
9126 c      write (iout,*) "itask",itask
9127       do i=1,2
9128         iproc=itask(i)
9129         if (iproc.gt.0) then
9130           do j=1,num_cont_hb(ii)
9131             jjc=jcont_hb(j,ii)
9132 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9133             if (jjc.eq.jj) then
9134               ncont_sent(iproc)=ncont_sent(iproc)+1
9135               nn=ncont_sent(iproc)
9136               zapas(1,nn,iproc)=ii
9137               zapas(2,nn,iproc)=jjc
9138               zapas(3,nn,iproc)=d_cont(j,ii)
9139               ind=3
9140               do kk=1,3
9141                 ind=ind+1
9142                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9143               enddo
9144               do kk=1,2
9145                 do ll=1,2
9146                   ind=ind+1
9147                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9148                 enddo
9149               enddo
9150               do jj=1,5
9151                 do kk=1,3
9152                   do ll=1,2
9153                     do mm=1,2
9154                       ind=ind+1
9155                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9156                     enddo
9157                   enddo
9158                 enddo
9159               enddo
9160               exit
9161             endif
9162           enddo
9163         endif
9164       enddo
9165       return
9166       end
9167 c------------------------------------------------------------------------------
9168       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9169       implicit real*8 (a-h,o-z)
9170       include 'DIMENSIONS'
9171       include 'COMMON.IOUNITS'
9172       include 'COMMON.DERIV'
9173       include 'COMMON.INTERACT'
9174       include 'COMMON.CONTACTS'
9175       include 'COMMON.SHIELD'
9176       include 'COMMON.CONTROL'
9177       double precision gx(3),gx1(3)
9178       logical lprn
9179       lprn=.false.
9180 C      print *,"wchodze",fac_shield(i),shield_mode
9181       eij=facont_hb(jj,i)
9182       ekl=facont_hb(kk,k)
9183       ees0pij=ees0p(jj,i)
9184       ees0pkl=ees0p(kk,k)
9185       ees0mij=ees0m(jj,i)
9186       ees0mkl=ees0m(kk,k)
9187       ekont=eij*ekl
9188       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9189 C*
9190 C     & fac_shield(i)**2*fac_shield(j)**2
9191 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9192 C Following 4 lines for diagnostics.
9193 cd    ees0pkl=0.0D0
9194 cd    ees0pij=1.0D0
9195 cd    ees0mkl=0.0D0
9196 cd    ees0mij=1.0D0
9197 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9198 c     & 'Contacts ',i,j,
9199 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9200 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9201 c     & 'gradcorr_long'
9202 C Calculate the multi-body contribution to energy.
9203 C      ecorr=ecorr+ekont*ees
9204 C Calculate multi-body contributions to the gradient.
9205       coeffpees0pij=coeffp*ees0pij
9206       coeffmees0mij=coeffm*ees0mij
9207       coeffpees0pkl=coeffp*ees0pkl
9208       coeffmees0mkl=coeffm*ees0mkl
9209       do ll=1,3
9210 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9211         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9212      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9213      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9214         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9215      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9216      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9217 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9218         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9219      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9220      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9221         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9222      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9223      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9224         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9225      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9226      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9227         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9228         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9229         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9230      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9231      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9232         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9233         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9234 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9235       enddo
9236 c      write (iout,*)
9237 cgrad      do m=i+1,j-1
9238 cgrad        do ll=1,3
9239 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9240 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9241 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9242 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9243 cgrad        enddo
9244 cgrad      enddo
9245 cgrad      do m=k+1,l-1
9246 cgrad        do ll=1,3
9247 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9248 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9249 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9250 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9251 cgrad        enddo
9252 cgrad      enddo
9253 c      write (iout,*) "ehbcorr",ekont*ees
9254 C      print *,ekont,ees,i,k
9255       ehbcorr=ekont*ees
9256 C now gradient over shielding
9257 C      return
9258       if (shield_mode.gt.0) then
9259        j=ees0plist(jj,i)
9260        l=ees0plist(kk,k)
9261 C        print *,i,j,fac_shield(i),fac_shield(j),
9262 C     &fac_shield(k),fac_shield(l)
9263         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9264      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9265           do ilist=1,ishield_list(i)
9266            iresshield=shield_list(ilist,i)
9267            do m=1,3
9268            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9269 C     &      *2.0
9270            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9271      &              rlocshield
9272      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9273             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9274      &+rlocshield
9275            enddo
9276           enddo
9277           do ilist=1,ishield_list(j)
9278            iresshield=shield_list(ilist,j)
9279            do m=1,3
9280            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9281 C     &     *2.0
9282            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9283      &              rlocshield
9284      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9285            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9286      &     +rlocshield
9287            enddo
9288           enddo
9289
9290           do ilist=1,ishield_list(k)
9291            iresshield=shield_list(ilist,k)
9292            do m=1,3
9293            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9294 C     &     *2.0
9295            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9296      &              rlocshield
9297      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9298            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9299      &     +rlocshield
9300            enddo
9301           enddo
9302           do ilist=1,ishield_list(l)
9303            iresshield=shield_list(ilist,l)
9304            do m=1,3
9305            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9306 C     &     *2.0
9307            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9308      &              rlocshield
9309      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9310            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9311      &     +rlocshield
9312            enddo
9313           enddo
9314 C          print *,gshieldx(m,iresshield)
9315           do m=1,3
9316             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9317      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9318             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9319      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9320             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9321      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9322             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9323      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9324
9325             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9326      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9327             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9328      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9329             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9330      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9331             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9332      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9333
9334            enddo
9335       endif
9336       endif
9337       return
9338       end
9339 #ifdef MOMENT
9340 C---------------------------------------------------------------------------
9341       subroutine dipole(i,j,jj)
9342       implicit real*8 (a-h,o-z)
9343       include 'DIMENSIONS'
9344       include 'COMMON.IOUNITS'
9345       include 'COMMON.CHAIN'
9346       include 'COMMON.FFIELD'
9347       include 'COMMON.DERIV'
9348       include 'COMMON.INTERACT'
9349       include 'COMMON.CONTACTS'
9350       include 'COMMON.TORSION'
9351       include 'COMMON.VAR'
9352       include 'COMMON.GEO'
9353       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9354      &  auxmat(2,2)
9355       iti1 = itortyp(itype(i+1))
9356       if (j.lt.nres-1) then
9357         itj1 = itype2loc(itype(j+1))
9358       else
9359         itj1=nloctyp
9360       endif
9361       do iii=1,2
9362         dipi(iii,1)=Ub2(iii,i)
9363         dipderi(iii)=Ub2der(iii,i)
9364         dipi(iii,2)=b1(iii,i+1)
9365         dipj(iii,1)=Ub2(iii,j)
9366         dipderj(iii)=Ub2der(iii,j)
9367         dipj(iii,2)=b1(iii,j+1)
9368       enddo
9369       kkk=0
9370       do iii=1,2
9371         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9372         do jjj=1,2
9373           kkk=kkk+1
9374           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9375         enddo
9376       enddo
9377       do kkk=1,5
9378         do lll=1,3
9379           mmm=0
9380           do iii=1,2
9381             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9382      &        auxvec(1))
9383             do jjj=1,2
9384               mmm=mmm+1
9385               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9386             enddo
9387           enddo
9388         enddo
9389       enddo
9390       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9391       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9392       do iii=1,2
9393         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9394       enddo
9395       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9396       do iii=1,2
9397         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9398       enddo
9399       return
9400       end
9401 #endif
9402 C---------------------------------------------------------------------------
9403       subroutine calc_eello(i,j,k,l,jj,kk)
9404 C
9405 C This subroutine computes matrices and vectors needed to calculate
9406 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9407 C
9408       implicit real*8 (a-h,o-z)
9409       include 'DIMENSIONS'
9410       include 'COMMON.IOUNITS'
9411       include 'COMMON.CHAIN'
9412       include 'COMMON.DERIV'
9413       include 'COMMON.INTERACT'
9414       include 'COMMON.CONTACTS'
9415       include 'COMMON.TORSION'
9416       include 'COMMON.VAR'
9417       include 'COMMON.GEO'
9418       include 'COMMON.FFIELD'
9419       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9420      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9421       logical lprn
9422       common /kutas/ lprn
9423 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9424 cd     & ' jj=',jj,' kk=',kk
9425 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9426 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9427 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9428       do iii=1,2
9429         do jjj=1,2
9430           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9431           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9432         enddo
9433       enddo
9434       call transpose2(aa1(1,1),aa1t(1,1))
9435       call transpose2(aa2(1,1),aa2t(1,1))
9436       do kkk=1,5
9437         do lll=1,3
9438           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9439      &      aa1tder(1,1,lll,kkk))
9440           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9441      &      aa2tder(1,1,lll,kkk))
9442         enddo
9443       enddo
9444       if (l.eq.j+1) then
9445 C parallel orientation of the two CA-CA-CA frames.
9446         if (i.gt.1) then
9447           iti=itype2loc(itype(i))
9448         else
9449           iti=nloctyp
9450         endif
9451         itk1=itype2loc(itype(k+1))
9452         itj=itype2loc(itype(j))
9453         if (l.lt.nres-1) then
9454           itl1=itype2loc(itype(l+1))
9455         else
9456           itl1=nloctyp
9457         endif
9458 C A1 kernel(j+1) A2T
9459 cd        do iii=1,2
9460 cd          write (iout,'(3f10.5,5x,3f10.5)')
9461 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9462 cd        enddo
9463         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9464      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9465      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9466 C Following matrices are needed only for 6-th order cumulants
9467         IF (wcorr6.gt.0.0d0) THEN
9468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9469      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9470      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9471         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9472      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9473      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9474      &   ADtEAderx(1,1,1,1,1,1))
9475         lprn=.false.
9476         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9477      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9478      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9479      &   ADtEA1derx(1,1,1,1,1,1))
9480         ENDIF
9481 C End 6-th order cumulants
9482 cd        lprn=.false.
9483 cd        if (lprn) then
9484 cd        write (2,*) 'In calc_eello6'
9485 cd        do iii=1,2
9486 cd          write (2,*) 'iii=',iii
9487 cd          do kkk=1,5
9488 cd            write (2,*) 'kkk=',kkk
9489 cd            do jjj=1,2
9490 cd              write (2,'(3(2f10.5),5x)')
9491 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9492 cd            enddo
9493 cd          enddo
9494 cd        enddo
9495 cd        endif
9496         call transpose2(EUgder(1,1,k),auxmat(1,1))
9497         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9498         call transpose2(EUg(1,1,k),auxmat(1,1))
9499         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9500         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9501         do iii=1,2
9502           do kkk=1,5
9503             do lll=1,3
9504               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9505      &          EAEAderx(1,1,lll,kkk,iii,1))
9506             enddo
9507           enddo
9508         enddo
9509 C A1T kernel(i+1) A2
9510         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9511      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9512      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9513 C Following matrices are needed only for 6-th order cumulants
9514         IF (wcorr6.gt.0.0d0) THEN
9515         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9516      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9517      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9518         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9519      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9520      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9521      &   ADtEAderx(1,1,1,1,1,2))
9522         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9523      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9524      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9525      &   ADtEA1derx(1,1,1,1,1,2))
9526         ENDIF
9527 C End 6-th order cumulants
9528         call transpose2(EUgder(1,1,l),auxmat(1,1))
9529         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9530         call transpose2(EUg(1,1,l),auxmat(1,1))
9531         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9532         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9533         do iii=1,2
9534           do kkk=1,5
9535             do lll=1,3
9536               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9537      &          EAEAderx(1,1,lll,kkk,iii,2))
9538             enddo
9539           enddo
9540         enddo
9541 C AEAb1 and AEAb2
9542 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9543 C They are needed only when the fifth- or the sixth-order cumulants are
9544 C indluded.
9545         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9546         call transpose2(AEA(1,1,1),auxmat(1,1))
9547         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9548         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9549         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9550         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9551         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9552         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9553         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9554         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9555         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9556         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9557         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9558         call transpose2(AEA(1,1,2),auxmat(1,1))
9559         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9560         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9561         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9562         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9563         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9564         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9565         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9566         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9567         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9568         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9569         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9570 C Calculate the Cartesian derivatives of the vectors.
9571         do iii=1,2
9572           do kkk=1,5
9573             do lll=1,3
9574               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9575               call matvec2(auxmat(1,1),b1(1,i),
9576      &          AEAb1derx(1,lll,kkk,iii,1,1))
9577               call matvec2(auxmat(1,1),Ub2(1,i),
9578      &          AEAb2derx(1,lll,kkk,iii,1,1))
9579               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9580      &          AEAb1derx(1,lll,kkk,iii,2,1))
9581               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9582      &          AEAb2derx(1,lll,kkk,iii,2,1))
9583               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9584               call matvec2(auxmat(1,1),b1(1,j),
9585      &          AEAb1derx(1,lll,kkk,iii,1,2))
9586               call matvec2(auxmat(1,1),Ub2(1,j),
9587      &          AEAb2derx(1,lll,kkk,iii,1,2))
9588               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9589      &          AEAb1derx(1,lll,kkk,iii,2,2))
9590               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9591      &          AEAb2derx(1,lll,kkk,iii,2,2))
9592             enddo
9593           enddo
9594         enddo
9595         ENDIF
9596 C End vectors
9597       else
9598 C Antiparallel orientation of the two CA-CA-CA frames.
9599         if (i.gt.1) then
9600           iti=itype2loc(itype(i))
9601         else
9602           iti=nloctyp
9603         endif
9604         itk1=itype2loc(itype(k+1))
9605         itl=itype2loc(itype(l))
9606         itj=itype2loc(itype(j))
9607         if (j.lt.nres-1) then
9608           itj1=itype2loc(itype(j+1))
9609         else
9610           itj1=nloctyp
9611         endif
9612 C A2 kernel(j-1)T A1T
9613         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9614      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9615      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9616 C Following matrices are needed only for 6-th order cumulants
9617         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9618      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9619         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9620      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9621      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9622         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9623      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9624      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9625      &   ADtEAderx(1,1,1,1,1,1))
9626         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9627      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9628      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9629      &   ADtEA1derx(1,1,1,1,1,1))
9630         ENDIF
9631 C End 6-th order cumulants
9632         call transpose2(EUgder(1,1,k),auxmat(1,1))
9633         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9634         call transpose2(EUg(1,1,k),auxmat(1,1))
9635         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9636         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9637         do iii=1,2
9638           do kkk=1,5
9639             do lll=1,3
9640               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9641      &          EAEAderx(1,1,lll,kkk,iii,1))
9642             enddo
9643           enddo
9644         enddo
9645 C A2T kernel(i+1)T A1
9646         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9647      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9648      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9649 C Following matrices are needed only for 6-th order cumulants
9650         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9651      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9652         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9653      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9654      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9655         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9656      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9657      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9658      &   ADtEAderx(1,1,1,1,1,2))
9659         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9660      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9661      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9662      &   ADtEA1derx(1,1,1,1,1,2))
9663         ENDIF
9664 C End 6-th order cumulants
9665         call transpose2(EUgder(1,1,j),auxmat(1,1))
9666         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9667         call transpose2(EUg(1,1,j),auxmat(1,1))
9668         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9669         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9670         do iii=1,2
9671           do kkk=1,5
9672             do lll=1,3
9673               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9674      &          EAEAderx(1,1,lll,kkk,iii,2))
9675             enddo
9676           enddo
9677         enddo
9678 C AEAb1 and AEAb2
9679 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9680 C They are needed only when the fifth- or the sixth-order cumulants are
9681 C indluded.
9682         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9683      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9684         call transpose2(AEA(1,1,1),auxmat(1,1))
9685         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9686         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9687         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9688         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9689         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9690         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9691         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9692         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9693         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9694         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9695         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9696         call transpose2(AEA(1,1,2),auxmat(1,1))
9697         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9698         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9699         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9700         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9701         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9702         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9703         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9704         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9705         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9706         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9707         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9708 C Calculate the Cartesian derivatives of the vectors.
9709         do iii=1,2
9710           do kkk=1,5
9711             do lll=1,3
9712               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9713               call matvec2(auxmat(1,1),b1(1,i),
9714      &          AEAb1derx(1,lll,kkk,iii,1,1))
9715               call matvec2(auxmat(1,1),Ub2(1,i),
9716      &          AEAb2derx(1,lll,kkk,iii,1,1))
9717               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9718      &          AEAb1derx(1,lll,kkk,iii,2,1))
9719               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9720      &          AEAb2derx(1,lll,kkk,iii,2,1))
9721               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9722               call matvec2(auxmat(1,1),b1(1,l),
9723      &          AEAb1derx(1,lll,kkk,iii,1,2))
9724               call matvec2(auxmat(1,1),Ub2(1,l),
9725      &          AEAb2derx(1,lll,kkk,iii,1,2))
9726               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9727      &          AEAb1derx(1,lll,kkk,iii,2,2))
9728               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9729      &          AEAb2derx(1,lll,kkk,iii,2,2))
9730             enddo
9731           enddo
9732         enddo
9733         ENDIF
9734 C End vectors
9735       endif
9736       return
9737       end
9738 C---------------------------------------------------------------------------
9739       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9740      &  KK,KKderg,AKA,AKAderg,AKAderx)
9741       implicit none
9742       integer nderg
9743       logical transp
9744       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9745      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9746      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9747       integer iii,kkk,lll
9748       integer jjj,mmm
9749       logical lprn
9750       common /kutas/ lprn
9751       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9752       do iii=1,nderg
9753         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9754      &    AKAderg(1,1,iii))
9755       enddo
9756 cd      if (lprn) write (2,*) 'In kernel'
9757       do kkk=1,5
9758 cd        if (lprn) write (2,*) 'kkk=',kkk
9759         do lll=1,3
9760           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9761      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9762 cd          if (lprn) then
9763 cd            write (2,*) 'lll=',lll
9764 cd            write (2,*) 'iii=1'
9765 cd            do jjj=1,2
9766 cd              write (2,'(3(2f10.5),5x)')
9767 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9768 cd            enddo
9769 cd          endif
9770           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9771      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9772 cd          if (lprn) then
9773 cd            write (2,*) 'lll=',lll
9774 cd            write (2,*) 'iii=2'
9775 cd            do jjj=1,2
9776 cd              write (2,'(3(2f10.5),5x)')
9777 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9778 cd            enddo
9779 cd          endif
9780         enddo
9781       enddo
9782       return
9783       end
9784 C---------------------------------------------------------------------------
9785       double precision function eello4(i,j,k,l,jj,kk)
9786       implicit real*8 (a-h,o-z)
9787       include 'DIMENSIONS'
9788       include 'COMMON.IOUNITS'
9789       include 'COMMON.CHAIN'
9790       include 'COMMON.DERIV'
9791       include 'COMMON.INTERACT'
9792       include 'COMMON.CONTACTS'
9793       include 'COMMON.TORSION'
9794       include 'COMMON.VAR'
9795       include 'COMMON.GEO'
9796       double precision pizda(2,2),ggg1(3),ggg2(3)
9797 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9798 cd        eello4=0.0d0
9799 cd        return
9800 cd      endif
9801 cd      print *,'eello4:',i,j,k,l,jj,kk
9802 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9803 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9804 cold      eij=facont_hb(jj,i)
9805 cold      ekl=facont_hb(kk,k)
9806 cold      ekont=eij*ekl
9807       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9808 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9809       gcorr_loc(k-1)=gcorr_loc(k-1)
9810      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9811       if (l.eq.j+1) then
9812         gcorr_loc(l-1)=gcorr_loc(l-1)
9813      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9814       else
9815         gcorr_loc(j-1)=gcorr_loc(j-1)
9816      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9817       endif
9818       do iii=1,2
9819         do kkk=1,5
9820           do lll=1,3
9821             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9822      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9823 cd            derx(lll,kkk,iii)=0.0d0
9824           enddo
9825         enddo
9826       enddo
9827 cd      gcorr_loc(l-1)=0.0d0
9828 cd      gcorr_loc(j-1)=0.0d0
9829 cd      gcorr_loc(k-1)=0.0d0
9830 cd      eel4=1.0d0
9831 cd      write (iout,*)'Contacts have occurred for peptide groups',
9832 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9833 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9834       if (j.lt.nres-1) then
9835         j1=j+1
9836         j2=j-1
9837       else
9838         j1=j-1
9839         j2=j-2
9840       endif
9841       if (l.lt.nres-1) then
9842         l1=l+1
9843         l2=l-1
9844       else
9845         l1=l-1
9846         l2=l-2
9847       endif
9848       do ll=1,3
9849 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9850 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9851         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9852         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9853 cgrad        ghalf=0.5d0*ggg1(ll)
9854         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9855         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9856         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9857         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9858         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9859         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9860 cgrad        ghalf=0.5d0*ggg2(ll)
9861         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9862         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9863         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9864         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9865         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9866         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9867       enddo
9868 cgrad      do m=i+1,j-1
9869 cgrad        do ll=1,3
9870 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9871 cgrad        enddo
9872 cgrad      enddo
9873 cgrad      do m=k+1,l-1
9874 cgrad        do ll=1,3
9875 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9876 cgrad        enddo
9877 cgrad      enddo
9878 cgrad      do m=i+2,j2
9879 cgrad        do ll=1,3
9880 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9881 cgrad        enddo
9882 cgrad      enddo
9883 cgrad      do m=k+2,l2
9884 cgrad        do ll=1,3
9885 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9886 cgrad        enddo
9887 cgrad      enddo
9888 cd      do iii=1,nres-3
9889 cd        write (2,*) iii,gcorr_loc(iii)
9890 cd      enddo
9891       eello4=ekont*eel4
9892 cd      write (2,*) 'ekont',ekont
9893 cd      write (iout,*) 'eello4',ekont*eel4
9894       return
9895       end
9896 C---------------------------------------------------------------------------
9897       double precision function eello5(i,j,k,l,jj,kk)
9898       implicit real*8 (a-h,o-z)
9899       include 'DIMENSIONS'
9900       include 'COMMON.IOUNITS'
9901       include 'COMMON.CHAIN'
9902       include 'COMMON.DERIV'
9903       include 'COMMON.INTERACT'
9904       include 'COMMON.CONTACTS'
9905       include 'COMMON.TORSION'
9906       include 'COMMON.VAR'
9907       include 'COMMON.GEO'
9908       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9909       double precision ggg1(3),ggg2(3)
9910 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9911 C                                                                              C
9912 C                            Parallel chains                                   C
9913 C                                                                              C
9914 C          o             o                   o             o                   C
9915 C         /l\           / \             \   / \           / \   /              C
9916 C        /   \         /   \             \ /   \         /   \ /               C
9917 C       j| o |l1       | o |              o| o |         | o |o                C
9918 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9919 C      \i/   \         /   \ /             /   \         /   \                 C
9920 C       o    k1             o                                                  C
9921 C         (I)          (II)                (III)          (IV)                 C
9922 C                                                                              C
9923 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9924 C                                                                              C
9925 C                            Antiparallel chains                               C
9926 C                                                                              C
9927 C          o             o                   o             o                   C
9928 C         /j\           / \             \   / \           / \   /              C
9929 C        /   \         /   \             \ /   \         /   \ /               C
9930 C      j1| o |l        | o |              o| o |         | o |o                C
9931 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9932 C      \i/   \         /   \ /             /   \         /   \                 C
9933 C       o     k1            o                                                  C
9934 C         (I)          (II)                (III)          (IV)                 C
9935 C                                                                              C
9936 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9937 C                                                                              C
9938 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9939 C                                                                              C
9940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9941 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9942 cd        eello5=0.0d0
9943 cd        return
9944 cd      endif
9945 cd      write (iout,*)
9946 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9947 cd     &   ' and',k,l
9948       itk=itype2loc(itype(k))
9949       itl=itype2loc(itype(l))
9950       itj=itype2loc(itype(j))
9951       eello5_1=0.0d0
9952       eello5_2=0.0d0
9953       eello5_3=0.0d0
9954       eello5_4=0.0d0
9955 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9956 cd     &   eel5_3_num,eel5_4_num)
9957       do iii=1,2
9958         do kkk=1,5
9959           do lll=1,3
9960             derx(lll,kkk,iii)=0.0d0
9961           enddo
9962         enddo
9963       enddo
9964 cd      eij=facont_hb(jj,i)
9965 cd      ekl=facont_hb(kk,k)
9966 cd      ekont=eij*ekl
9967 cd      write (iout,*)'Contacts have occurred for peptide groups',
9968 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9969 cd      goto 1111
9970 C Contribution from the graph I.
9971 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9972 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9973       call transpose2(EUg(1,1,k),auxmat(1,1))
9974       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9975       vv(1)=pizda(1,1)-pizda(2,2)
9976       vv(2)=pizda(1,2)+pizda(2,1)
9977       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9978      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9979 C Explicit gradient in virtual-dihedral angles.
9980       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9981      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9982      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9983       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9984       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9985       vv(1)=pizda(1,1)-pizda(2,2)
9986       vv(2)=pizda(1,2)+pizda(2,1)
9987       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9988      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9989      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9990       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9991       vv(1)=pizda(1,1)-pizda(2,2)
9992       vv(2)=pizda(1,2)+pizda(2,1)
9993       if (l.eq.j+1) then
9994         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9995      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9996      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9997       else
9998         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9999      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10000      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10001       endif
10002 C Cartesian gradient
10003       do iii=1,2
10004         do kkk=1,5
10005           do lll=1,3
10006             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10007      &        pizda(1,1))
10008             vv(1)=pizda(1,1)-pizda(2,2)
10009             vv(2)=pizda(1,2)+pizda(2,1)
10010             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10011      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10012      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10013           enddo
10014         enddo
10015       enddo
10016 c      goto 1112
10017 c1111  continue
10018 C Contribution from graph II
10019       call transpose2(EE(1,1,k),auxmat(1,1))
10020       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10021       vv(1)=pizda(1,1)+pizda(2,2)
10022       vv(2)=pizda(2,1)-pizda(1,2)
10023       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10024      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10025 C Explicit gradient in virtual-dihedral angles.
10026       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10027      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10028       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10029       vv(1)=pizda(1,1)+pizda(2,2)
10030       vv(2)=pizda(2,1)-pizda(1,2)
10031       if (l.eq.j+1) then
10032         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10033      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10034      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10035       else
10036         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10037      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10038      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10039       endif
10040 C Cartesian gradient
10041       do iii=1,2
10042         do kkk=1,5
10043           do lll=1,3
10044             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10045      &        pizda(1,1))
10046             vv(1)=pizda(1,1)+pizda(2,2)
10047             vv(2)=pizda(2,1)-pizda(1,2)
10048             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10049      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10050      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10051           enddo
10052         enddo
10053       enddo
10054 cd      goto 1112
10055 cd1111  continue
10056       if (l.eq.j+1) then
10057 cd        goto 1110
10058 C Parallel orientation
10059 C Contribution from graph III
10060         call transpose2(EUg(1,1,l),auxmat(1,1))
10061         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10062         vv(1)=pizda(1,1)-pizda(2,2)
10063         vv(2)=pizda(1,2)+pizda(2,1)
10064         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10065      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10066 C Explicit gradient in virtual-dihedral angles.
10067         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10068      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10069      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10070         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10071         vv(1)=pizda(1,1)-pizda(2,2)
10072         vv(2)=pizda(1,2)+pizda(2,1)
10073         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10074      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10075      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10076         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10077         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10078         vv(1)=pizda(1,1)-pizda(2,2)
10079         vv(2)=pizda(1,2)+pizda(2,1)
10080         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10081      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10082      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10083 C Cartesian gradient
10084         do iii=1,2
10085           do kkk=1,5
10086             do lll=1,3
10087               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10088      &          pizda(1,1))
10089               vv(1)=pizda(1,1)-pizda(2,2)
10090               vv(2)=pizda(1,2)+pizda(2,1)
10091               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10092      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10093      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10094             enddo
10095           enddo
10096         enddo
10097 cd        goto 1112
10098 C Contribution from graph IV
10099 cd1110    continue
10100         call transpose2(EE(1,1,l),auxmat(1,1))
10101         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10102         vv(1)=pizda(1,1)+pizda(2,2)
10103         vv(2)=pizda(2,1)-pizda(1,2)
10104         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10105      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10106 C Explicit gradient in virtual-dihedral angles.
10107         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10108      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10109         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10110         vv(1)=pizda(1,1)+pizda(2,2)
10111         vv(2)=pizda(2,1)-pizda(1,2)
10112         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10113      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10114      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10115 C Cartesian gradient
10116         do iii=1,2
10117           do kkk=1,5
10118             do lll=1,3
10119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10120      &          pizda(1,1))
10121               vv(1)=pizda(1,1)+pizda(2,2)
10122               vv(2)=pizda(2,1)-pizda(1,2)
10123               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10124      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10125      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10126             enddo
10127           enddo
10128         enddo
10129       else
10130 C Antiparallel orientation
10131 C Contribution from graph III
10132 c        goto 1110
10133         call transpose2(EUg(1,1,j),auxmat(1,1))
10134         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10135         vv(1)=pizda(1,1)-pizda(2,2)
10136         vv(2)=pizda(1,2)+pizda(2,1)
10137         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10138      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10139 C Explicit gradient in virtual-dihedral angles.
10140         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10141      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10142      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10143         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10144         vv(1)=pizda(1,1)-pizda(2,2)
10145         vv(2)=pizda(1,2)+pizda(2,1)
10146         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10147      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10148      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10149         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10150         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10151         vv(1)=pizda(1,1)-pizda(2,2)
10152         vv(2)=pizda(1,2)+pizda(2,1)
10153         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10154      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10155      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10156 C Cartesian gradient
10157         do iii=1,2
10158           do kkk=1,5
10159             do lll=1,3
10160               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10161      &          pizda(1,1))
10162               vv(1)=pizda(1,1)-pizda(2,2)
10163               vv(2)=pizda(1,2)+pizda(2,1)
10164               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10165      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10166      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10167             enddo
10168           enddo
10169         enddo
10170 cd        goto 1112
10171 C Contribution from graph IV
10172 1110    continue
10173         call transpose2(EE(1,1,j),auxmat(1,1))
10174         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10175         vv(1)=pizda(1,1)+pizda(2,2)
10176         vv(2)=pizda(2,1)-pizda(1,2)
10177         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10178      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10179 C Explicit gradient in virtual-dihedral angles.
10180         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10181      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10182         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10183         vv(1)=pizda(1,1)+pizda(2,2)
10184         vv(2)=pizda(2,1)-pizda(1,2)
10185         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10186      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10187      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10188 C Cartesian gradient
10189         do iii=1,2
10190           do kkk=1,5
10191             do lll=1,3
10192               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10193      &          pizda(1,1))
10194               vv(1)=pizda(1,1)+pizda(2,2)
10195               vv(2)=pizda(2,1)-pizda(1,2)
10196               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10197      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10198      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10199             enddo
10200           enddo
10201         enddo
10202       endif
10203 1112  continue
10204       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10205 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10206 cd        write (2,*) 'ijkl',i,j,k,l
10207 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10208 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10209 cd      endif
10210 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10211 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10212 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10213 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10214       if (j.lt.nres-1) then
10215         j1=j+1
10216         j2=j-1
10217       else
10218         j1=j-1
10219         j2=j-2
10220       endif
10221       if (l.lt.nres-1) then
10222         l1=l+1
10223         l2=l-1
10224       else
10225         l1=l-1
10226         l2=l-2
10227       endif
10228 cd      eij=1.0d0
10229 cd      ekl=1.0d0
10230 cd      ekont=1.0d0
10231 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10232 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10233 C        summed up outside the subrouine as for the other subroutines
10234 C        handling long-range interactions. The old code is commented out
10235 C        with "cgrad" to keep track of changes.
10236       do ll=1,3
10237 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10238 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10239         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10240         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10241 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10242 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10243 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10244 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10245 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10246 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10247 c     &   gradcorr5ij,
10248 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10249 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10250 cgrad        ghalf=0.5d0*ggg1(ll)
10251 cd        ghalf=0.0d0
10252         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10253         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10254         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10255         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10256         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10257         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10258 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10259 cgrad        ghalf=0.5d0*ggg2(ll)
10260 cd        ghalf=0.0d0
10261         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10262         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10263         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10264         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10265         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10266         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10267       enddo
10268 cd      goto 1112
10269 cgrad      do m=i+1,j-1
10270 cgrad        do ll=1,3
10271 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10272 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10273 cgrad        enddo
10274 cgrad      enddo
10275 cgrad      do m=k+1,l-1
10276 cgrad        do ll=1,3
10277 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10278 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10279 cgrad        enddo
10280 cgrad      enddo
10281 c1112  continue
10282 cgrad      do m=i+2,j2
10283 cgrad        do ll=1,3
10284 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10285 cgrad        enddo
10286 cgrad      enddo
10287 cgrad      do m=k+2,l2
10288 cgrad        do ll=1,3
10289 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10290 cgrad        enddo
10291 cgrad      enddo
10292 cd      do iii=1,nres-3
10293 cd        write (2,*) iii,g_corr5_loc(iii)
10294 cd      enddo
10295       eello5=ekont*eel5
10296 cd      write (2,*) 'ekont',ekont
10297 cd      write (iout,*) 'eello5',ekont*eel5
10298       return
10299       end
10300 c--------------------------------------------------------------------------
10301       double precision function eello6(i,j,k,l,jj,kk)
10302       implicit real*8 (a-h,o-z)
10303       include 'DIMENSIONS'
10304       include 'COMMON.IOUNITS'
10305       include 'COMMON.CHAIN'
10306       include 'COMMON.DERIV'
10307       include 'COMMON.INTERACT'
10308       include 'COMMON.CONTACTS'
10309       include 'COMMON.TORSION'
10310       include 'COMMON.VAR'
10311       include 'COMMON.GEO'
10312       include 'COMMON.FFIELD'
10313       double precision ggg1(3),ggg2(3)
10314 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10315 cd        eello6=0.0d0
10316 cd        return
10317 cd      endif
10318 cd      write (iout,*)
10319 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10320 cd     &   ' and',k,l
10321       eello6_1=0.0d0
10322       eello6_2=0.0d0
10323       eello6_3=0.0d0
10324       eello6_4=0.0d0
10325       eello6_5=0.0d0
10326       eello6_6=0.0d0
10327 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10328 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10329       do iii=1,2
10330         do kkk=1,5
10331           do lll=1,3
10332             derx(lll,kkk,iii)=0.0d0
10333           enddo
10334         enddo
10335       enddo
10336 cd      eij=facont_hb(jj,i)
10337 cd      ekl=facont_hb(kk,k)
10338 cd      ekont=eij*ekl
10339 cd      eij=1.0d0
10340 cd      ekl=1.0d0
10341 cd      ekont=1.0d0
10342       if (l.eq.j+1) then
10343         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10344         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10345         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10346         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10347         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10348         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10349       else
10350         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10351         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10352         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10353         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10354         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10355           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10356         else
10357           eello6_5=0.0d0
10358         endif
10359         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10360       endif
10361 C If turn contributions are considered, they will be handled separately.
10362       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10363 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10364 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10365 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10366 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10367 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10368 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10369 cd      goto 1112
10370       if (j.lt.nres-1) then
10371         j1=j+1
10372         j2=j-1
10373       else
10374         j1=j-1
10375         j2=j-2
10376       endif
10377       if (l.lt.nres-1) then
10378         l1=l+1
10379         l2=l-1
10380       else
10381         l1=l-1
10382         l2=l-2
10383       endif
10384       do ll=1,3
10385 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10386 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10387 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10388 cgrad        ghalf=0.5d0*ggg1(ll)
10389 cd        ghalf=0.0d0
10390         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10391         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10392         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10393         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10394         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10395         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10396         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10397         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10398 cgrad        ghalf=0.5d0*ggg2(ll)
10399 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10400 cd        ghalf=0.0d0
10401         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10402         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10403         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10404         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10405         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10406         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10407       enddo
10408 cd      goto 1112
10409 cgrad      do m=i+1,j-1
10410 cgrad        do ll=1,3
10411 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10412 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10413 cgrad        enddo
10414 cgrad      enddo
10415 cgrad      do m=k+1,l-1
10416 cgrad        do ll=1,3
10417 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10418 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10419 cgrad        enddo
10420 cgrad      enddo
10421 cgrad1112  continue
10422 cgrad      do m=i+2,j2
10423 cgrad        do ll=1,3
10424 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10425 cgrad        enddo
10426 cgrad      enddo
10427 cgrad      do m=k+2,l2
10428 cgrad        do ll=1,3
10429 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10430 cgrad        enddo
10431 cgrad      enddo
10432 cd      do iii=1,nres-3
10433 cd        write (2,*) iii,g_corr6_loc(iii)
10434 cd      enddo
10435       eello6=ekont*eel6
10436 cd      write (2,*) 'ekont',ekont
10437 cd      write (iout,*) 'eello6',ekont*eel6
10438       return
10439       end
10440 c--------------------------------------------------------------------------
10441       double precision function eello6_graph1(i,j,k,l,imat,swap)
10442       implicit real*8 (a-h,o-z)
10443       include 'DIMENSIONS'
10444       include 'COMMON.IOUNITS'
10445       include 'COMMON.CHAIN'
10446       include 'COMMON.DERIV'
10447       include 'COMMON.INTERACT'
10448       include 'COMMON.CONTACTS'
10449       include 'COMMON.TORSION'
10450       include 'COMMON.VAR'
10451       include 'COMMON.GEO'
10452       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10453       logical swap
10454       logical lprn
10455       common /kutas/ lprn
10456 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10457 C                                                                              C
10458 C      Parallel       Antiparallel                                             C
10459 C                                                                              C
10460 C          o             o                                                     C
10461 C         /l\           /j\                                                    C
10462 C        /   \         /   \                                                   C
10463 C       /| o |         | o |\                                                  C
10464 C     \ j|/k\|  /   \  |/k\|l /                                                C
10465 C      \ /   \ /     \ /   \ /                                                 C
10466 C       o     o       o     o                                                  C
10467 C       i             i                                                        C
10468 C                                                                              C
10469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10470       itk=itype2loc(itype(k))
10471       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10472       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10473       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10474       call transpose2(EUgC(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       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10479       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10480       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10481       s5=scalar2(vv(1),Dtobr2(1,i))
10482 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10483       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10484       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10485      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10486      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10487      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10488      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10489      & +scalar2(vv(1),Dtobr2der(1,i)))
10490       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10491       vv1(1)=pizda1(1,1)-pizda1(2,2)
10492       vv1(2)=pizda1(1,2)+pizda1(2,1)
10493       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10494       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10495       if (l.eq.j+1) then
10496         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10497      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10498      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10499      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10500      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10501       else
10502         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10503      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10504      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10505      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10506      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10507       endif
10508       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10509       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10510       vv1(1)=pizda1(1,1)-pizda1(2,2)
10511       vv1(2)=pizda1(1,2)+pizda1(2,1)
10512       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10513      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10514      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10515      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10516       do iii=1,2
10517         if (swap) then
10518           ind=3-iii
10519         else
10520           ind=iii
10521         endif
10522         do kkk=1,5
10523           do lll=1,3
10524             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10525             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10526             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10527             call transpose2(EUgC(1,1,k),auxmat(1,1))
10528             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10529      &        pizda1(1,1))
10530             vv1(1)=pizda1(1,1)-pizda1(2,2)
10531             vv1(2)=pizda1(1,2)+pizda1(2,1)
10532             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10533             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10534      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10535             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10536      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10537             s5=scalar2(vv(1),Dtobr2(1,i))
10538             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10539           enddo
10540         enddo
10541       enddo
10542       return
10543       end
10544 c----------------------------------------------------------------------------
10545       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10546       implicit real*8 (a-h,o-z)
10547       include 'DIMENSIONS'
10548       include 'COMMON.IOUNITS'
10549       include 'COMMON.CHAIN'
10550       include 'COMMON.DERIV'
10551       include 'COMMON.INTERACT'
10552       include 'COMMON.CONTACTS'
10553       include 'COMMON.TORSION'
10554       include 'COMMON.VAR'
10555       include 'COMMON.GEO'
10556       logical swap
10557       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10558      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10559       logical lprn
10560       common /kutas/ lprn
10561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10562 C                                                                              C
10563 C      Parallel       Antiparallel                                             C
10564 C                                                                              C
10565 C          o             o                                                     C
10566 C     \   /l\           /j\   /                                                C
10567 C      \ /   \         /   \ /                                                 C
10568 C       o| o |         | o |o                                                  C
10569 C     \ j|/k\|      \  |/k\|l                                                  C
10570 C      \ /   \       \ /   \                                                   C
10571 C       o             o                                                        C
10572 C       i             i                                                        C
10573 C                                                                              C
10574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10575 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10576 C AL 7/4/01 s1 would occur in the sixth-order moment,
10577 C           but not in a cluster cumulant
10578 #ifdef MOMENT
10579       s1=dip(1,jj,i)*dip(1,kk,k)
10580 #endif
10581       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10582       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10583       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10584       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10585       call transpose2(EUg(1,1,k),auxmat(1,1))
10586       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10587       vv(1)=pizda(1,1)-pizda(2,2)
10588       vv(2)=pizda(1,2)+pizda(2,1)
10589       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10590 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10591 #ifdef MOMENT
10592       eello6_graph2=-(s1+s2+s3+s4)
10593 #else
10594       eello6_graph2=-(s2+s3+s4)
10595 #endif
10596 c      eello6_graph2=-s3
10597 C Derivatives in gamma(i-1)
10598       if (i.gt.1) then
10599 #ifdef MOMENT
10600         s1=dipderg(1,jj,i)*dip(1,kk,k)
10601 #endif
10602         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10603         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10604         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10605         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10606 #ifdef MOMENT
10607         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10608 #else
10609         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10610 #endif
10611 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10612       endif
10613 C Derivatives in gamma(k-1)
10614 #ifdef MOMENT
10615       s1=dip(1,jj,i)*dipderg(1,kk,k)
10616 #endif
10617       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10618       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10619       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10620       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10621       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10622       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10623       vv(1)=pizda(1,1)-pizda(2,2)
10624       vv(2)=pizda(1,2)+pizda(2,1)
10625       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10626 #ifdef MOMENT
10627       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10628 #else
10629       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10630 #endif
10631 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10632 C Derivatives in gamma(j-1) or gamma(l-1)
10633       if (j.gt.1) then
10634 #ifdef MOMENT
10635         s1=dipderg(3,jj,i)*dip(1,kk,k)
10636 #endif
10637         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10638         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10639         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10640         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10641         vv(1)=pizda(1,1)-pizda(2,2)
10642         vv(2)=pizda(1,2)+pizda(2,1)
10643         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10644 #ifdef MOMENT
10645         if (swap) then
10646           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10647         else
10648           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10649         endif
10650 #endif
10651         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10652 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10653       endif
10654 C Derivatives in gamma(l-1) or gamma(j-1)
10655       if (l.gt.1) then
10656 #ifdef MOMENT
10657         s1=dip(1,jj,i)*dipderg(3,kk,k)
10658 #endif
10659         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10660         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10661         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10662         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10663         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10664         vv(1)=pizda(1,1)-pizda(2,2)
10665         vv(2)=pizda(1,2)+pizda(2,1)
10666         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10667 #ifdef MOMENT
10668         if (swap) then
10669           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10670         else
10671           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10672         endif
10673 #endif
10674         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10675 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10676       endif
10677 C Cartesian derivatives.
10678       if (lprn) then
10679         write (2,*) 'In eello6_graph2'
10680         do iii=1,2
10681           write (2,*) 'iii=',iii
10682           do kkk=1,5
10683             write (2,*) 'kkk=',kkk
10684             do jjj=1,2
10685               write (2,'(3(2f10.5),5x)')
10686      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10687             enddo
10688           enddo
10689         enddo
10690       endif
10691       do iii=1,2
10692         do kkk=1,5
10693           do lll=1,3
10694 #ifdef MOMENT
10695             if (iii.eq.1) then
10696               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10697             else
10698               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10699             endif
10700 #endif
10701             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10702      &        auxvec(1))
10703             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10704             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10705      &        auxvec(1))
10706             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10707             call transpose2(EUg(1,1,k),auxmat(1,1))
10708             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10709      &        pizda(1,1))
10710             vv(1)=pizda(1,1)-pizda(2,2)
10711             vv(2)=pizda(1,2)+pizda(2,1)
10712             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10713 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10714 #ifdef MOMENT
10715             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10716 #else
10717             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10718 #endif
10719             if (swap) then
10720               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10721             else
10722               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10723             endif
10724           enddo
10725         enddo
10726       enddo
10727       return
10728       end
10729 c----------------------------------------------------------------------------
10730       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10731       implicit real*8 (a-h,o-z)
10732       include 'DIMENSIONS'
10733       include 'COMMON.IOUNITS'
10734       include 'COMMON.CHAIN'
10735       include 'COMMON.DERIV'
10736       include 'COMMON.INTERACT'
10737       include 'COMMON.CONTACTS'
10738       include 'COMMON.TORSION'
10739       include 'COMMON.VAR'
10740       include 'COMMON.GEO'
10741       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10742       logical swap
10743 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10744 C                                                                              C
10745 C      Parallel       Antiparallel                                             C
10746 C                                                                              C
10747 C          o             o                                                     C
10748 C         /l\   /   \   /j\                                                    C
10749 C        /   \ /     \ /   \                                                   C
10750 C       /| o |o       o| o |\                                                  C
10751 C       j|/k\|  /      |/k\|l /                                                C
10752 C        /   \ /       /   \ /                                                 C
10753 C       /     o       /     o                                                  C
10754 C       i             i                                                        C
10755 C                                                                              C
10756 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10757 C
10758 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10759 C           energy moment and not to the cluster cumulant.
10760       iti=itortyp(itype(i))
10761       if (j.lt.nres-1) then
10762         itj1=itype2loc(itype(j+1))
10763       else
10764         itj1=nloctyp
10765       endif
10766       itk=itype2loc(itype(k))
10767       itk1=itype2loc(itype(k+1))
10768       if (l.lt.nres-1) then
10769         itl1=itype2loc(itype(l+1))
10770       else
10771         itl1=nloctyp
10772       endif
10773 #ifdef MOMENT
10774       s1=dip(4,jj,i)*dip(4,kk,k)
10775 #endif
10776       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10777       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10778       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10779       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10780       call transpose2(EE(1,1,k),auxmat(1,1))
10781       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10782       vv(1)=pizda(1,1)+pizda(2,2)
10783       vv(2)=pizda(2,1)-pizda(1,2)
10784       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10785 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10786 cd     & "sum",-(s2+s3+s4)
10787 #ifdef MOMENT
10788       eello6_graph3=-(s1+s2+s3+s4)
10789 #else
10790       eello6_graph3=-(s2+s3+s4)
10791 #endif
10792 c      eello6_graph3=-s4
10793 C Derivatives in gamma(k-1)
10794       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10795       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10796       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10797       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10798 C Derivatives in gamma(l-1)
10799       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10800       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10801       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10802       vv(1)=pizda(1,1)+pizda(2,2)
10803       vv(2)=pizda(2,1)-pizda(1,2)
10804       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10805       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10806 C Cartesian derivatives.
10807       do iii=1,2
10808         do kkk=1,5
10809           do lll=1,3
10810 #ifdef MOMENT
10811             if (iii.eq.1) then
10812               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10813             else
10814               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10815             endif
10816 #endif
10817             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10818      &        auxvec(1))
10819             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10820             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10821      &        auxvec(1))
10822             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10823             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10824      &        pizda(1,1))
10825             vv(1)=pizda(1,1)+pizda(2,2)
10826             vv(2)=pizda(2,1)-pizda(1,2)
10827             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10828 #ifdef MOMENT
10829             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10830 #else
10831             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10832 #endif
10833             if (swap) then
10834               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10835             else
10836               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10837             endif
10838 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10839           enddo
10840         enddo
10841       enddo
10842       return
10843       end
10844 c----------------------------------------------------------------------------
10845       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10846       implicit real*8 (a-h,o-z)
10847       include 'DIMENSIONS'
10848       include 'COMMON.IOUNITS'
10849       include 'COMMON.CHAIN'
10850       include 'COMMON.DERIV'
10851       include 'COMMON.INTERACT'
10852       include 'COMMON.CONTACTS'
10853       include 'COMMON.TORSION'
10854       include 'COMMON.VAR'
10855       include 'COMMON.GEO'
10856       include 'COMMON.FFIELD'
10857       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10858      & auxvec1(2),auxmat1(2,2)
10859       logical swap
10860 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10861 C                                                                              C
10862 C      Parallel       Antiparallel                                             C
10863 C                                                                              C
10864 C          o             o                                                     C
10865 C         /l\   /   \   /j\                                                    C
10866 C        /   \ /     \ /   \                                                   C
10867 C       /| o |o       o| o |\                                                  C
10868 C     \ j|/k\|      \  |/k\|l                                                  C
10869 C      \ /   \       \ /   \                                                   C
10870 C       o     \       o     \                                                  C
10871 C       i             i                                                        C
10872 C                                                                              C
10873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10874 C
10875 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10876 C           energy moment and not to the cluster cumulant.
10877 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10878       iti=itype2loc(itype(i))
10879       itj=itype2loc(itype(j))
10880       if (j.lt.nres-1) then
10881         itj1=itype2loc(itype(j+1))
10882       else
10883         itj1=nloctyp
10884       endif
10885       itk=itype2loc(itype(k))
10886       if (k.lt.nres-1) then
10887         itk1=itype2loc(itype(k+1))
10888       else
10889         itk1=nloctyp
10890       endif
10891       itl=itype2loc(itype(l))
10892       if (l.lt.nres-1) then
10893         itl1=itype2loc(itype(l+1))
10894       else
10895         itl1=nloctyp
10896       endif
10897 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10898 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10899 cd     & ' itl',itl,' itl1',itl1
10900 #ifdef MOMENT
10901       if (imat.eq.1) then
10902         s1=dip(3,jj,i)*dip(3,kk,k)
10903       else
10904         s1=dip(2,jj,j)*dip(2,kk,l)
10905       endif
10906 #endif
10907       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10908       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10909       if (j.eq.l+1) then
10910         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10911         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10912       else
10913         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10914         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10915       endif
10916       call transpose2(EUg(1,1,k),auxmat(1,1))
10917       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10918       vv(1)=pizda(1,1)-pizda(2,2)
10919       vv(2)=pizda(2,1)+pizda(1,2)
10920       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10921 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10922 #ifdef MOMENT
10923       eello6_graph4=-(s1+s2+s3+s4)
10924 #else
10925       eello6_graph4=-(s2+s3+s4)
10926 #endif
10927 C Derivatives in gamma(i-1)
10928       if (i.gt.1) then
10929 #ifdef MOMENT
10930         if (imat.eq.1) then
10931           s1=dipderg(2,jj,i)*dip(3,kk,k)
10932         else
10933           s1=dipderg(4,jj,j)*dip(2,kk,l)
10934         endif
10935 #endif
10936         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10937         if (j.eq.l+1) then
10938           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10939           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10940         else
10941           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10942           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10943         endif
10944         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10945         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10946 cd          write (2,*) 'turn6 derivatives'
10947 #ifdef MOMENT
10948           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10949 #else
10950           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10951 #endif
10952         else
10953 #ifdef MOMENT
10954           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10955 #else
10956           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10957 #endif
10958         endif
10959       endif
10960 C Derivatives in gamma(k-1)
10961 #ifdef MOMENT
10962       if (imat.eq.1) then
10963         s1=dip(3,jj,i)*dipderg(2,kk,k)
10964       else
10965         s1=dip(2,jj,j)*dipderg(4,kk,l)
10966       endif
10967 #endif
10968       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10969       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10970       if (j.eq.l+1) then
10971         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10972         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10973       else
10974         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10975         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10976       endif
10977       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10978       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10979       vv(1)=pizda(1,1)-pizda(2,2)
10980       vv(2)=pizda(2,1)+pizda(1,2)
10981       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10982       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10983 #ifdef MOMENT
10984         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10985 #else
10986         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10987 #endif
10988       else
10989 #ifdef MOMENT
10990         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10991 #else
10992         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10993 #endif
10994       endif
10995 C Derivatives in gamma(j-1) or gamma(l-1)
10996       if (l.eq.j+1 .and. l.gt.1) then
10997         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10998         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10999         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11000         vv(1)=pizda(1,1)-pizda(2,2)
11001         vv(2)=pizda(2,1)+pizda(1,2)
11002         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11003         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11004       else if (j.gt.1) then
11005         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11006         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11007         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11008         vv(1)=pizda(1,1)-pizda(2,2)
11009         vv(2)=pizda(2,1)+pizda(1,2)
11010         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11011         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11012           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11013         else
11014           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11015         endif
11016       endif
11017 C Cartesian derivatives.
11018       do iii=1,2
11019         do kkk=1,5
11020           do lll=1,3
11021 #ifdef MOMENT
11022             if (iii.eq.1) then
11023               if (imat.eq.1) then
11024                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11025               else
11026                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11027               endif
11028             else
11029               if (imat.eq.1) then
11030                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11031               else
11032                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11033               endif
11034             endif
11035 #endif
11036             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11037      &        auxvec(1))
11038             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11039             if (j.eq.l+1) then
11040               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11041      &          b1(1,j+1),auxvec(1))
11042               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11043             else
11044               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11045      &          b1(1,l+1),auxvec(1))
11046               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11047             endif
11048             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11049      &        pizda(1,1))
11050             vv(1)=pizda(1,1)-pizda(2,2)
11051             vv(2)=pizda(2,1)+pizda(1,2)
11052             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11053             if (swap) then
11054               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11055 #ifdef MOMENT
11056                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11057      &             -(s1+s2+s4)
11058 #else
11059                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11060      &             -(s2+s4)
11061 #endif
11062                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11063               else
11064 #ifdef MOMENT
11065                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11066 #else
11067                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11068 #endif
11069                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11070               endif
11071             else
11072 #ifdef MOMENT
11073               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11074 #else
11075               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11076 #endif
11077               if (l.eq.j+1) then
11078                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11079               else
11080                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11081               endif
11082             endif
11083           enddo
11084         enddo
11085       enddo
11086       return
11087       end
11088 c----------------------------------------------------------------------------
11089       double precision function eello_turn6(i,jj,kk)
11090       implicit real*8 (a-h,o-z)
11091       include 'DIMENSIONS'
11092       include 'COMMON.IOUNITS'
11093       include 'COMMON.CHAIN'
11094       include 'COMMON.DERIV'
11095       include 'COMMON.INTERACT'
11096       include 'COMMON.CONTACTS'
11097       include 'COMMON.TORSION'
11098       include 'COMMON.VAR'
11099       include 'COMMON.GEO'
11100       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11101      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11102      &  ggg1(3),ggg2(3)
11103       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11104      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11105 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11106 C           the respective energy moment and not to the cluster cumulant.
11107       s1=0.0d0
11108       s8=0.0d0
11109       s13=0.0d0
11110 c
11111       eello_turn6=0.0d0
11112       j=i+4
11113       k=i+1
11114       l=i+3
11115       iti=itype2loc(itype(i))
11116       itk=itype2loc(itype(k))
11117       itk1=itype2loc(itype(k+1))
11118       itl=itype2loc(itype(l))
11119       itj=itype2loc(itype(j))
11120 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11121 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11122 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11123 cd        eello6=0.0d0
11124 cd        return
11125 cd      endif
11126 cd      write (iout,*)
11127 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11128 cd     &   ' and',k,l
11129 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11130       do iii=1,2
11131         do kkk=1,5
11132           do lll=1,3
11133             derx_turn(lll,kkk,iii)=0.0d0
11134           enddo
11135         enddo
11136       enddo
11137 cd      eij=1.0d0
11138 cd      ekl=1.0d0
11139 cd      ekont=1.0d0
11140       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11141 cd      eello6_5=0.0d0
11142 cd      write (2,*) 'eello6_5',eello6_5
11143 #ifdef MOMENT
11144       call transpose2(AEA(1,1,1),auxmat(1,1))
11145       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11146       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11147       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11148 #endif
11149       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11150       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11151       s2 = scalar2(b1(1,k),vtemp1(1))
11152 #ifdef MOMENT
11153       call transpose2(AEA(1,1,2),atemp(1,1))
11154       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11155       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11156       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11157 #endif
11158       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11159       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11160       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11161 #ifdef MOMENT
11162       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11163       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11164       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11165       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11166       ss13 = scalar2(b1(1,k),vtemp4(1))
11167       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11168 #endif
11169 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11170 c      s1=0.0d0
11171 c      s2=0.0d0
11172 c      s8=0.0d0
11173 c      s12=0.0d0
11174 c      s13=0.0d0
11175       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11176 C Derivatives in gamma(i+2)
11177       s1d =0.0d0
11178       s8d =0.0d0
11179 #ifdef MOMENT
11180       call transpose2(AEA(1,1,1),auxmatd(1,1))
11181       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11182       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11183       call transpose2(AEAderg(1,1,2),atempd(1,1))
11184       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11185       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11186 #endif
11187       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11188       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11189       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11190 c      s1d=0.0d0
11191 c      s2d=0.0d0
11192 c      s8d=0.0d0
11193 c      s12d=0.0d0
11194 c      s13d=0.0d0
11195       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11196 C Derivatives in gamma(i+3)
11197 #ifdef MOMENT
11198       call transpose2(AEA(1,1,1),auxmatd(1,1))
11199       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11200       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11201       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11202 #endif
11203       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11204       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11205       s2d = scalar2(b1(1,k),vtemp1d(1))
11206 #ifdef MOMENT
11207       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11208       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11209 #endif
11210       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11211 #ifdef MOMENT
11212       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11213       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11214       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11215 #endif
11216 c      s1d=0.0d0
11217 c      s2d=0.0d0
11218 c      s8d=0.0d0
11219 c      s12d=0.0d0
11220 c      s13d=0.0d0
11221 #ifdef MOMENT
11222       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11223      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11224 #else
11225       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11226      &               -0.5d0*ekont*(s2d+s12d)
11227 #endif
11228 C Derivatives in gamma(i+4)
11229       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11230       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11231       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11232 #ifdef MOMENT
11233       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11234       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11235       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11236 #endif
11237 c      s1d=0.0d0
11238 c      s2d=0.0d0
11239 c      s8d=0.0d0
11240 C      s12d=0.0d0
11241 c      s13d=0.0d0
11242 #ifdef MOMENT
11243       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11244 #else
11245       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11246 #endif
11247 C Derivatives in gamma(i+5)
11248 #ifdef MOMENT
11249       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11250       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11251       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11252 #endif
11253       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11254       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11255       s2d = scalar2(b1(1,k),vtemp1d(1))
11256 #ifdef MOMENT
11257       call transpose2(AEA(1,1,2),atempd(1,1))
11258       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11259       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11260 #endif
11261       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11262       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11263 #ifdef MOMENT
11264       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11265       ss13d = scalar2(b1(1,k),vtemp4d(1))
11266       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11267 #endif
11268 c      s1d=0.0d0
11269 c      s2d=0.0d0
11270 c      s8d=0.0d0
11271 c      s12d=0.0d0
11272 c      s13d=0.0d0
11273 #ifdef MOMENT
11274       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11275      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11276 #else
11277       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11278      &               -0.5d0*ekont*(s2d+s12d)
11279 #endif
11280 C Cartesian derivatives
11281       do iii=1,2
11282         do kkk=1,5
11283           do lll=1,3
11284 #ifdef MOMENT
11285             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11286             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11287             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11288 #endif
11289             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11290             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11291      &          vtemp1d(1))
11292             s2d = scalar2(b1(1,k),vtemp1d(1))
11293 #ifdef MOMENT
11294             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11295             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11296             s8d = -(atempd(1,1)+atempd(2,2))*
11297      &           scalar2(cc(1,1,itl),vtemp2(1))
11298 #endif
11299             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11300      &           auxmatd(1,1))
11301             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11302             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11303 c      s1d=0.0d0
11304 c      s2d=0.0d0
11305 c      s8d=0.0d0
11306 c      s12d=0.0d0
11307 c      s13d=0.0d0
11308 #ifdef MOMENT
11309             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11310      &        - 0.5d0*(s1d+s2d)
11311 #else
11312             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11313      &        - 0.5d0*s2d
11314 #endif
11315 #ifdef MOMENT
11316             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11317      &        - 0.5d0*(s8d+s12d)
11318 #else
11319             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11320      &        - 0.5d0*s12d
11321 #endif
11322           enddo
11323         enddo
11324       enddo
11325 #ifdef MOMENT
11326       do kkk=1,5
11327         do lll=1,3
11328           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11329      &      achuj_tempd(1,1))
11330           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11331           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11332           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11333           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11334           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11335      &      vtemp4d(1))
11336           ss13d = scalar2(b1(1,k),vtemp4d(1))
11337           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11338           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11339         enddo
11340       enddo
11341 #endif
11342 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11343 cd     &  16*eel_turn6_num
11344 cd      goto 1112
11345       if (j.lt.nres-1) then
11346         j1=j+1
11347         j2=j-1
11348       else
11349         j1=j-1
11350         j2=j-2
11351       endif
11352       if (l.lt.nres-1) then
11353         l1=l+1
11354         l2=l-1
11355       else
11356         l1=l-1
11357         l2=l-2
11358       endif
11359       do ll=1,3
11360 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11361 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11362 cgrad        ghalf=0.5d0*ggg1(ll)
11363 cd        ghalf=0.0d0
11364         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11365         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11366         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11367      &    +ekont*derx_turn(ll,2,1)
11368         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11369         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11370      &    +ekont*derx_turn(ll,4,1)
11371         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11372         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11373         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11374 cgrad        ghalf=0.5d0*ggg2(ll)
11375 cd        ghalf=0.0d0
11376         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11377      &    +ekont*derx_turn(ll,2,2)
11378         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11379         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11380      &    +ekont*derx_turn(ll,4,2)
11381         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11382         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11383         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11384       enddo
11385 cd      goto 1112
11386 cgrad      do m=i+1,j-1
11387 cgrad        do ll=1,3
11388 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11389 cgrad        enddo
11390 cgrad      enddo
11391 cgrad      do m=k+1,l-1
11392 cgrad        do ll=1,3
11393 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11394 cgrad        enddo
11395 cgrad      enddo
11396 cgrad1112  continue
11397 cgrad      do m=i+2,j2
11398 cgrad        do ll=1,3
11399 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11400 cgrad        enddo
11401 cgrad      enddo
11402 cgrad      do m=k+2,l2
11403 cgrad        do ll=1,3
11404 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11405 cgrad        enddo
11406 cgrad      enddo
11407 cd      do iii=1,nres-3
11408 cd        write (2,*) iii,g_corr6_loc(iii)
11409 cd      enddo
11410       eello_turn6=ekont*eel_turn6
11411 cd      write (2,*) 'ekont',ekont
11412 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11413       return
11414       end
11415
11416 C-----------------------------------------------------------------------------
11417       double precision function scalar(u,v)
11418 !DIR$ INLINEALWAYS scalar
11419 #ifndef OSF
11420 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11421 #endif
11422       implicit none
11423       double precision u(3),v(3)
11424 cd      double precision sc
11425 cd      integer i
11426 cd      sc=0.0d0
11427 cd      do i=1,3
11428 cd        sc=sc+u(i)*v(i)
11429 cd      enddo
11430 cd      scalar=sc
11431
11432       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11433       return
11434       end
11435 crc-------------------------------------------------
11436       SUBROUTINE MATVEC2(A1,V1,V2)
11437 !DIR$ INLINEALWAYS MATVEC2
11438 #ifndef OSF
11439 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11440 #endif
11441       implicit real*8 (a-h,o-z)
11442       include 'DIMENSIONS'
11443       DIMENSION A1(2,2),V1(2),V2(2)
11444 c      DO 1 I=1,2
11445 c        VI=0.0
11446 c        DO 3 K=1,2
11447 c    3     VI=VI+A1(I,K)*V1(K)
11448 c        Vaux(I)=VI
11449 c    1 CONTINUE
11450
11451       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11452       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11453
11454       v2(1)=vaux1
11455       v2(2)=vaux2
11456       END
11457 C---------------------------------------
11458       SUBROUTINE MATMAT2(A1,A2,A3)
11459 #ifndef OSF
11460 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11461 #endif
11462       implicit real*8 (a-h,o-z)
11463       include 'DIMENSIONS'
11464       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11465 c      DIMENSION AI3(2,2)
11466 c        DO  J=1,2
11467 c          A3IJ=0.0
11468 c          DO K=1,2
11469 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11470 c          enddo
11471 c          A3(I,J)=A3IJ
11472 c       enddo
11473 c      enddo
11474
11475       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11476       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11477       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11478       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11479
11480       A3(1,1)=AI3_11
11481       A3(2,1)=AI3_21
11482       A3(1,2)=AI3_12
11483       A3(2,2)=AI3_22
11484       END
11485
11486 c-------------------------------------------------------------------------
11487       double precision function scalar2(u,v)
11488 !DIR$ INLINEALWAYS scalar2
11489       implicit none
11490       double precision u(2),v(2)
11491       double precision sc
11492       integer i
11493       scalar2=u(1)*v(1)+u(2)*v(2)
11494       return
11495       end
11496
11497 C-----------------------------------------------------------------------------
11498
11499       subroutine transpose2(a,at)
11500 !DIR$ INLINEALWAYS transpose2
11501 #ifndef OSF
11502 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11503 #endif
11504       implicit none
11505       double precision a(2,2),at(2,2)
11506       at(1,1)=a(1,1)
11507       at(1,2)=a(2,1)
11508       at(2,1)=a(1,2)
11509       at(2,2)=a(2,2)
11510       return
11511       end
11512 c--------------------------------------------------------------------------
11513       subroutine transpose(n,a,at)
11514       implicit none
11515       integer n,i,j
11516       double precision a(n,n),at(n,n)
11517       do i=1,n
11518         do j=1,n
11519           at(j,i)=a(i,j)
11520         enddo
11521       enddo
11522       return
11523       end
11524 C---------------------------------------------------------------------------
11525       subroutine prodmat3(a1,a2,kk,transp,prod)
11526 !DIR$ INLINEALWAYS prodmat3
11527 #ifndef OSF
11528 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11529 #endif
11530       implicit none
11531       integer i,j
11532       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11533       logical transp
11534 crc      double precision auxmat(2,2),prod_(2,2)
11535
11536       if (transp) then
11537 crc        call transpose2(kk(1,1),auxmat(1,1))
11538 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11539 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11540
11541            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11542      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11543            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11544      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11545            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11546      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11547            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11548      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11549
11550       else
11551 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11552 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11553
11554            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11555      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11556            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11557      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11558            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11559      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11560            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11561      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11562
11563       endif
11564 c      call transpose2(a2(1,1),a2t(1,1))
11565
11566 crc      print *,transp
11567 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11568 crc      print *,((prod(i,j),i=1,2),j=1,2)
11569
11570       return
11571       end
11572 CCC----------------------------------------------
11573       subroutine Eliptransfer(eliptran)
11574       implicit real*8 (a-h,o-z)
11575       include 'DIMENSIONS'
11576       include 'COMMON.GEO'
11577       include 'COMMON.VAR'
11578       include 'COMMON.LOCAL'
11579       include 'COMMON.CHAIN'
11580       include 'COMMON.DERIV'
11581       include 'COMMON.NAMES'
11582       include 'COMMON.INTERACT'
11583       include 'COMMON.IOUNITS'
11584       include 'COMMON.CALC'
11585       include 'COMMON.CONTROL'
11586       include 'COMMON.SPLITELE'
11587       include 'COMMON.SBRIDGE'
11588 C this is done by Adasko
11589 C      print *,"wchodze"
11590 C structure of box:
11591 C      water
11592 C--bordliptop-- buffore starts
11593 C--bufliptop--- here true lipid starts
11594 C      lipid
11595 C--buflipbot--- lipid ends buffore starts
11596 C--bordlipbot--buffore ends
11597       eliptran=0.0
11598       do i=ilip_start,ilip_end
11599 C       do i=1,1
11600         if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1).or.(i.eq.nres))
11601      &    cycle
11602
11603         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11604         if (positi.le.0.0) positi=positi+boxzsize
11605 C        print *,i
11606 C first for peptide groups
11607 c for each residue check if it is in lipid or lipid water border area
11608        if ((positi.gt.bordlipbot)
11609      &.and.(positi.lt.bordliptop)) then
11610 C the energy transfer exist
11611         if (positi.lt.buflipbot) then
11612 C what fraction I am in
11613          fracinbuf=1.0d0-
11614      &        ((positi-bordlipbot)/lipbufthick)
11615 C lipbufthick is thickenes of lipid buffore
11616          sslip=sscalelip(fracinbuf)
11617          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11618          eliptran=eliptran+sslip*pepliptran
11619          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11620          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11621 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11622
11623 C        print *,"doing sccale for lower part"
11624 C         print *,i,sslip,fracinbuf,ssgradlip
11625         elseif (positi.gt.bufliptop) then
11626          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11627          sslip=sscalelip(fracinbuf)
11628          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11629          eliptran=eliptran+sslip*pepliptran
11630          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11631          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11632 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11633 C          print *, "doing sscalefor top part"
11634 C         print *,i,sslip,fracinbuf,ssgradlip
11635         else
11636          eliptran=eliptran+pepliptran
11637 C         print *,"I am in true lipid"
11638         endif
11639 C       else
11640 C       eliptran=elpitran+0.0 ! I am in water
11641        endif
11642        enddo
11643 C       print *, "nic nie bylo w lipidzie?"
11644 C now multiply all by the peptide group transfer factor
11645 C       eliptran=eliptran*pepliptran
11646 C now the same for side chains
11647 CV       do i=1,1
11648        do i=ilip_start,ilip_end
11649         if (itype(i).eq.ntyp1) cycle
11650         positi=(mod(c(3,i+nres),boxzsize))
11651         if (positi.le.0) positi=positi+boxzsize
11652 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11653 c for each residue check if it is in lipid or lipid water border area
11654 C       respos=mod(c(3,i+nres),boxzsize)
11655 C       print *,positi,bordlipbot,buflipbot
11656        if ((positi.gt.bordlipbot)
11657      & .and.(positi.lt.bordliptop)) then
11658 C the energy transfer exist
11659         if (positi.lt.buflipbot) then
11660          fracinbuf=1.0d0-
11661      &     ((positi-bordlipbot)/lipbufthick)
11662 C lipbufthick is thickenes of lipid buffore
11663          sslip=sscalelip(fracinbuf)
11664          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11665          eliptran=eliptran+sslip*liptranene(itype(i))
11666          gliptranx(3,i)=gliptranx(3,i)
11667      &+ssgradlip*liptranene(itype(i))
11668          gliptranc(3,i-1)= gliptranc(3,i-1)
11669      &+ssgradlip*liptranene(itype(i))
11670 C         print *,"doing sccale for lower part"
11671         elseif (positi.gt.bufliptop) then
11672          fracinbuf=1.0d0-
11673      &((bordliptop-positi)/lipbufthick)
11674          sslip=sscalelip(fracinbuf)
11675          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11676          eliptran=eliptran+sslip*liptranene(itype(i))
11677          gliptranx(3,i)=gliptranx(3,i)
11678      &+ssgradlip*liptranene(itype(i))
11679          gliptranc(3,i-1)= gliptranc(3,i-1)
11680      &+ssgradlip*liptranene(itype(i))
11681 C          print *, "doing sscalefor top part",sslip,fracinbuf
11682         else
11683          eliptran=eliptran+liptranene(itype(i))
11684 C         print *,"I am in true lipid"
11685         endif
11686         endif ! if in lipid or buffor
11687 C       else
11688 C       eliptran=elpitran+0.0 ! I am in water
11689        enddo
11690        return
11691        end
11692 C---------------------------------------------------------
11693 C AFM soubroutine for constant force
11694        subroutine AFMforce(Eafmforce)
11695        implicit real*8 (a-h,o-z)
11696       include 'DIMENSIONS'
11697       include 'COMMON.GEO'
11698       include 'COMMON.VAR'
11699       include 'COMMON.LOCAL'
11700       include 'COMMON.CHAIN'
11701       include 'COMMON.DERIV'
11702       include 'COMMON.NAMES'
11703       include 'COMMON.INTERACT'
11704       include 'COMMON.IOUNITS'
11705       include 'COMMON.CALC'
11706       include 'COMMON.CONTROL'
11707       include 'COMMON.SPLITELE'
11708       include 'COMMON.SBRIDGE'
11709       real*8 diffafm(3)
11710       dist=0.0d0
11711       Eafmforce=0.0d0
11712       do i=1,3
11713       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11714       dist=dist+diffafm(i)**2
11715       enddo
11716       dist=dsqrt(dist)
11717       Eafmforce=-forceAFMconst*(dist-distafminit)
11718       do i=1,3
11719       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11720       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11721       enddo
11722 C      print *,'AFM',Eafmforce
11723       return
11724       end
11725 C---------------------------------------------------------
11726 C AFM subroutine with pseudoconstant velocity
11727        subroutine AFMvel(Eafmforce)
11728        implicit real*8 (a-h,o-z)
11729       include 'DIMENSIONS'
11730       include 'COMMON.GEO'
11731       include 'COMMON.VAR'
11732       include 'COMMON.LOCAL'
11733       include 'COMMON.CHAIN'
11734       include 'COMMON.DERIV'
11735       include 'COMMON.NAMES'
11736       include 'COMMON.INTERACT'
11737       include 'COMMON.IOUNITS'
11738       include 'COMMON.CALC'
11739       include 'COMMON.CONTROL'
11740       include 'COMMON.SPLITELE'
11741       include 'COMMON.SBRIDGE'
11742       real*8 diffafm(3)
11743 C Only for check grad COMMENT if not used for checkgrad
11744 C      totT=3.0d0
11745 C--------------------------------------------------------
11746 C      print *,"wchodze"
11747       dist=0.0d0
11748       Eafmforce=0.0d0
11749       do i=1,3
11750       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11751       dist=dist+diffafm(i)**2
11752       enddo
11753       dist=dsqrt(dist)
11754       Eafmforce=0.5d0*forceAFMconst
11755      & *(distafminit+totTafm*velAFMconst-dist)**2
11756 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11757       do i=1,3
11758       gradafm(i,afmend-1)=-forceAFMconst*
11759      &(distafminit+totTafm*velAFMconst-dist)
11760      &*diffafm(i)/dist
11761       gradafm(i,afmbeg-1)=forceAFMconst*
11762      &(distafminit+totTafm*velAFMconst-dist)
11763      &*diffafm(i)/dist
11764       enddo
11765 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11766       return
11767       end
11768 C-----------------------------------------------------------
11769 C first for shielding is setting of function of side-chains
11770        subroutine set_shield_fac
11771       implicit real*8 (a-h,o-z)
11772       include 'DIMENSIONS'
11773       include 'COMMON.CHAIN'
11774       include 'COMMON.DERIV'
11775       include 'COMMON.IOUNITS'
11776       include 'COMMON.SHIELD'
11777       include 'COMMON.INTERACT'
11778 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11779       double precision div77_81/0.974996043d0/,
11780      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11781
11782 C the vector between center of side_chain and peptide group
11783        double precision pep_side(3),long,side_calf(3),
11784      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11785      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11786 C the line belowe needs to be changed for FGPROC>1
11787       do i=1,nres-1
11788       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11789       ishield_list(i)=0
11790 Cif there two consequtive dummy atoms there is no peptide group between them
11791 C the line below has to be changed for FGPROC>1
11792       VolumeTotal=0.0
11793       do k=1,nres
11794        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11795        dist_pep_side=0.0
11796        dist_side_calf=0.0
11797        do j=1,3
11798 C first lets set vector conecting the ithe side-chain with kth side-chain
11799       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11800 C      pep_side(j)=2.0d0
11801 C and vector conecting the side-chain with its proper calfa
11802       side_calf(j)=c(j,k+nres)-c(j,k)
11803 C      side_calf(j)=2.0d0
11804       pept_group(j)=c(j,i)-c(j,i+1)
11805 C lets have their lenght
11806       dist_pep_side=pep_side(j)**2+dist_pep_side
11807       dist_side_calf=dist_side_calf+side_calf(j)**2
11808       dist_pept_group=dist_pept_group+pept_group(j)**2
11809       enddo
11810        dist_pep_side=dsqrt(dist_pep_side)
11811        dist_pept_group=dsqrt(dist_pept_group)
11812        dist_side_calf=dsqrt(dist_side_calf)
11813       do j=1,3
11814         pep_side_norm(j)=pep_side(j)/dist_pep_side
11815         side_calf_norm(j)=dist_side_calf
11816       enddo
11817 C now sscale fraction
11818        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11819 C       print *,buff_shield,"buff"
11820 C now sscale
11821         if (sh_frac_dist.le.0.0) cycle
11822 C If we reach here it means that this side chain reaches the shielding sphere
11823 C Lets add him to the list for gradient
11824         ishield_list(i)=ishield_list(i)+1
11825 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11826 C this list is essential otherwise problem would be O3
11827         shield_list(ishield_list(i),i)=k
11828 C Lets have the sscale value
11829         if (sh_frac_dist.gt.1.0) then
11830          scale_fac_dist=1.0d0
11831          do j=1,3
11832          sh_frac_dist_grad(j)=0.0d0
11833          enddo
11834         else
11835          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11836      &                   *(2.0*sh_frac_dist-3.0d0)
11837          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11838      &                  /dist_pep_side/buff_shield*0.5
11839 C remember for the final gradient multiply sh_frac_dist_grad(j)
11840 C for side_chain by factor -2 !
11841          do j=1,3
11842          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11843 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11844 C     &                    sh_frac_dist_grad(j)
11845          enddo
11846         endif
11847 C        if ((i.eq.3).and.(k.eq.2)) then
11848 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11849 C     & ,"TU"
11850 C        endif
11851
11852 C this is what is now we have the distance scaling now volume...
11853       short=short_r_sidechain(itype(k))
11854       long=long_r_sidechain(itype(k))
11855       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11856 C now costhet_grad
11857 C       costhet=0.0d0
11858        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11859 C       costhet_fac=0.0d0
11860        do j=1,3
11861          costhet_grad(j)=costhet_fac*pep_side(j)
11862        enddo
11863 C remember for the final gradient multiply costhet_grad(j)
11864 C for side_chain by factor -2 !
11865 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11866 C pep_side0pept_group is vector multiplication
11867       pep_side0pept_group=0.0
11868       do j=1,3
11869       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11870       enddo
11871       cosalfa=(pep_side0pept_group/
11872      & (dist_pep_side*dist_side_calf))
11873       fac_alfa_sin=1.0-cosalfa**2
11874       fac_alfa_sin=dsqrt(fac_alfa_sin)
11875       rkprim=fac_alfa_sin*(long-short)+short
11876 C now costhet_grad
11877        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11878        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11879
11880        do j=1,3
11881          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11882      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11883      &*(long-short)/fac_alfa_sin*cosalfa/
11884      &((dist_pep_side*dist_side_calf))*
11885      &((side_calf(j))-cosalfa*
11886      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11887
11888         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11889      &*(long-short)/fac_alfa_sin*cosalfa
11890      &/((dist_pep_side*dist_side_calf))*
11891      &(pep_side(j)-
11892      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11893        enddo
11894
11895       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11896      &                    /VSolvSphere_div
11897      &                    *wshield
11898 C now the gradient...
11899 C grad_shield is gradient of Calfa for peptide groups
11900 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11901 C     &               costhet,cosphi
11902 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11903 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11904       do j=1,3
11905       grad_shield(j,i)=grad_shield(j,i)
11906 C gradient po skalowaniu
11907      &                +(sh_frac_dist_grad(j)
11908 C  gradient po costhet
11909      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11910      &-scale_fac_dist*(cosphi_grad_long(j))
11911      &/(1.0-cosphi) )*div77_81
11912      &*VofOverlap
11913 C grad_shield_side is Cbeta sidechain gradient
11914       grad_shield_side(j,ishield_list(i),i)=
11915      &        (sh_frac_dist_grad(j)*-2.0d0
11916      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11917      &       +scale_fac_dist*(cosphi_grad_long(j))
11918      &        *2.0d0/(1.0-cosphi))
11919      &        *div77_81*VofOverlap
11920
11921        grad_shield_loc(j,ishield_list(i),i)=
11922      &   scale_fac_dist*cosphi_grad_loc(j)
11923      &        *2.0d0/(1.0-cosphi)
11924      &        *div77_81*VofOverlap
11925       enddo
11926       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11927       enddo
11928       fac_shield(i)=VolumeTotal*div77_81+div4_81
11929 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11930       enddo
11931       return
11932       end
11933 C--------------------------------------------------------------------------
11934       double precision function tschebyshev(m,n,x,y)
11935       implicit none
11936       include "DIMENSIONS"
11937       integer i,m,n
11938       double precision x(n),y,yy(0:maxvar),aux
11939 c Tschebyshev polynomial. Note that the first term is omitted
11940 c m=0: the constant term is included
11941 c m=1: the constant term is not included
11942       yy(0)=1.0d0
11943       yy(1)=y
11944       do i=2,n
11945         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11946       enddo
11947       aux=0.0d0
11948       do i=m,n
11949         aux=aux+x(i)*yy(i)
11950       enddo
11951       tschebyshev=aux
11952       return
11953       end
11954 C--------------------------------------------------------------------------
11955       double precision function gradtschebyshev(m,n,x,y)
11956       implicit none
11957       include "DIMENSIONS"
11958       integer i,m,n
11959       double precision x(n+1),y,yy(0:maxvar),aux
11960 c Tschebyshev polynomial. Note that the first term is omitted
11961 c m=0: the constant term is included
11962 c m=1: the constant term is not included
11963       yy(0)=1.0d0
11964       yy(1)=2.0d0*y
11965       do i=2,n
11966         yy(i)=2*y*yy(i-1)-yy(i-2)
11967       enddo
11968       aux=0.0d0
11969       do i=m,n
11970         aux=aux+x(i+1)*yy(i)*(i+1)
11971 C        print *, x(i+1),yy(i),i
11972       enddo
11973       gradtschebyshev=aux
11974       return
11975       end
11976 C------------------------------------------------------------------------
11977 C first for shielding is setting of function of side-chains
11978        subroutine set_shield_fac2
11979       implicit real*8 (a-h,o-z)
11980       include 'DIMENSIONS'
11981       include 'COMMON.CHAIN'
11982       include 'COMMON.DERIV'
11983       include 'COMMON.IOUNITS'
11984       include 'COMMON.SHIELD'
11985       include 'COMMON.INTERACT'
11986       include 'COMMON.LOCAL'
11987
11988 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11989       double precision div77_81/0.974996043d0/,
11990      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11991
11992 C the vector between center of side_chain and peptide group
11993        double precision pep_side(3),long,side_calf(3),
11994      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11995      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11996 C      write(2,*) "ivec",ivec_start,ivec_end
11997       do i=1,nres
11998         fac_shield(i)=0.0d0
11999         do j=1,3
12000         grad_shield(j,i)=0.0d0
12001         enddo
12002       enddo
12003 C the line belowe needs to be changed for FGPROC>1
12004       do i=ivec_start,ivec_end
12005 C      do i=1,nres-1
12006 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12007       ishield_list(i)=0
12008       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12009 Cif there two consequtive dummy atoms there is no peptide group between them
12010 C the line below has to be changed for FGPROC>1
12011       VolumeTotal=0.0
12012       do k=1,nres
12013        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12014        dist_pep_side=0.0
12015        dist_side_calf=0.0
12016        do j=1,3
12017 C first lets set vector conecting the ithe side-chain with kth side-chain
12018       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12019 C      pep_side(j)=2.0d0
12020 C and vector conecting the side-chain with its proper calfa
12021       side_calf(j)=c(j,k+nres)-c(j,k)
12022 C      side_calf(j)=2.0d0
12023       pept_group(j)=c(j,i)-c(j,i+1)
12024 C lets have their lenght
12025       dist_pep_side=pep_side(j)**2+dist_pep_side
12026       dist_side_calf=dist_side_calf+side_calf(j)**2
12027       dist_pept_group=dist_pept_group+pept_group(j)**2
12028       enddo
12029        dist_pep_side=dsqrt(dist_pep_side)
12030        dist_pept_group=dsqrt(dist_pept_group)
12031        dist_side_calf=dsqrt(dist_side_calf)
12032       do j=1,3
12033         pep_side_norm(j)=pep_side(j)/dist_pep_side
12034         side_calf_norm(j)=dist_side_calf
12035       enddo
12036 C now sscale fraction
12037        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12038 C       print *,buff_shield,"buff"
12039 C now sscale
12040         if (sh_frac_dist.le.0.0) cycle
12041 C        print *,ishield_list(i),i
12042 C If we reach here it means that this side chain reaches the shielding sphere
12043 C Lets add him to the list for gradient
12044         ishield_list(i)=ishield_list(i)+1
12045 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12046 C this list is essential otherwise problem would be O3
12047         shield_list(ishield_list(i),i)=k
12048 C Lets have the sscale value
12049         if (sh_frac_dist.gt.1.0) then
12050          scale_fac_dist=1.0d0
12051          do j=1,3
12052          sh_frac_dist_grad(j)=0.0d0
12053          enddo
12054         else
12055          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12056      &                   *(2.0d0*sh_frac_dist-3.0d0)
12057          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12058      &                  /dist_pep_side/buff_shield*0.5d0
12059 C remember for the final gradient multiply sh_frac_dist_grad(j)
12060 C for side_chain by factor -2 !
12061          do j=1,3
12062          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12063 C         sh_frac_dist_grad(j)=0.0d0
12064 C         scale_fac_dist=1.0d0
12065 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12066 C     &                    sh_frac_dist_grad(j)
12067          enddo
12068         endif
12069 C this is what is now we have the distance scaling now volume...
12070       short=short_r_sidechain(itype(k))
12071       long=long_r_sidechain(itype(k))
12072       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12073       sinthet=short/dist_pep_side*costhet
12074 C now costhet_grad
12075 C       costhet=0.6d0
12076 C       sinthet=0.8
12077        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12078 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12079 C     &             -short/dist_pep_side**2/costhet)
12080 C       costhet_fac=0.0d0
12081        do j=1,3
12082          costhet_grad(j)=costhet_fac*pep_side(j)
12083        enddo
12084 C remember for the final gradient multiply costhet_grad(j)
12085 C for side_chain by factor -2 !
12086 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12087 C pep_side0pept_group is vector multiplication
12088       pep_side0pept_group=0.0d0
12089       do j=1,3
12090       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12091       enddo
12092       cosalfa=(pep_side0pept_group/
12093      & (dist_pep_side*dist_side_calf))
12094       fac_alfa_sin=1.0d0-cosalfa**2
12095       fac_alfa_sin=dsqrt(fac_alfa_sin)
12096       rkprim=fac_alfa_sin*(long-short)+short
12097 C      rkprim=short
12098
12099 C now costhet_grad
12100        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12101 C       cosphi=0.6
12102        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12103        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12104      &      dist_pep_side**2)
12105 C       sinphi=0.8
12106        do j=1,3
12107          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12108      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12109      &*(long-short)/fac_alfa_sin*cosalfa/
12110      &((dist_pep_side*dist_side_calf))*
12111      &((side_calf(j))-cosalfa*
12112      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12113 C       cosphi_grad_long(j)=0.0d0
12114         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12115      &*(long-short)/fac_alfa_sin*cosalfa
12116      &/((dist_pep_side*dist_side_calf))*
12117      &(pep_side(j)-
12118      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12119 C       cosphi_grad_loc(j)=0.0d0
12120        enddo
12121 C      print *,sinphi,sinthet
12122       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12123      &                    /VSolvSphere_div
12124 C     &                    *wshield
12125 C now the gradient...
12126       do j=1,3
12127       grad_shield(j,i)=grad_shield(j,i)
12128 C gradient po skalowaniu
12129      &                +(sh_frac_dist_grad(j)*VofOverlap
12130 C  gradient po costhet
12131      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12132      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12133      &       sinphi/sinthet*costhet*costhet_grad(j)
12134      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12135      & )*wshield
12136 C grad_shield_side is Cbeta sidechain gradient
12137       grad_shield_side(j,ishield_list(i),i)=
12138      &        (sh_frac_dist_grad(j)*-2.0d0
12139      &        *VofOverlap
12140      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12141      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12142      &       sinphi/sinthet*costhet*costhet_grad(j)
12143      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12144      &       )*wshield
12145
12146        grad_shield_loc(j,ishield_list(i),i)=
12147      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12148      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12149      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12150      &        ))
12151      &        *wshield
12152       enddo
12153       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12154       enddo
12155       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12156 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12157       enddo
12158       return
12159       end
12160 C-----------------------------------------------------------------------
12161 C-----------------------------------------------------------
12162 C This subroutine is to mimic the histone like structure but as well can be
12163 C utilizet to nanostructures (infinit) small modification has to be used to
12164 C make it finite (z gradient at the ends has to be changes as well as the x,y
12165 C gradient has to be modified at the ends
12166 C The energy function is Kihara potential
12167 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12168 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12169 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12170 C simple Kihara potential
12171       subroutine calctube(Etube)
12172        implicit real*8 (a-h,o-z)
12173       include 'DIMENSIONS'
12174       include 'COMMON.GEO'
12175       include 'COMMON.VAR'
12176       include 'COMMON.LOCAL'
12177       include 'COMMON.CHAIN'
12178       include 'COMMON.DERIV'
12179       include 'COMMON.NAMES'
12180       include 'COMMON.INTERACT'
12181       include 'COMMON.IOUNITS'
12182       include 'COMMON.CALC'
12183       include 'COMMON.CONTROL'
12184       include 'COMMON.SPLITELE'
12185       include 'COMMON.SBRIDGE'
12186       double precision tub_r,vectube(3),enetube(maxres*2)
12187       Etube=0.0d0
12188       do i=itube_start,itube_end
12189         enetube(i)=0.0d0
12190         enetube(i+nres)=0.0d0
12191       enddo
12192 C first we calculate the distance from tube center
12193 C first sugare-phosphate group for NARES this would be peptide group
12194 C for UNRES
12195        do i=itube_start,itube_end
12196 C lets ommit dummy atoms for now
12197        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12198 C now calculate distance from center of tube and direction vectors
12199       xmin=boxxsize
12200       ymin=boxysize
12201         do j=-1,1
12202          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12203          vectube(1)=vectube(1)+boxxsize*j
12204          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12205          vectube(2)=vectube(2)+boxysize*j
12206
12207          xminact=abs(vectube(1)-tubecenter(1))
12208          yminact=abs(vectube(2)-tubecenter(2))
12209            if (xmin.gt.xminact) then
12210             xmin=xminact
12211             xtemp=vectube(1)
12212            endif
12213            if (ymin.gt.yminact) then
12214              ymin=yminact
12215              ytemp=vectube(2)
12216             endif
12217          enddo
12218       vectube(1)=xtemp
12219       vectube(2)=ytemp
12220       vectube(1)=vectube(1)-tubecenter(1)
12221       vectube(2)=vectube(2)-tubecenter(2)
12222
12223 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12224 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12225
12226 C as the tube is infinity we do not calculate the Z-vector use of Z
12227 C as chosen axis
12228       vectube(3)=0.0d0
12229 C now calculte the distance
12230        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12231 C now normalize vector
12232       vectube(1)=vectube(1)/tub_r
12233       vectube(2)=vectube(2)/tub_r
12234 C calculte rdiffrence between r and r0
12235       rdiff=tub_r-tubeR0
12236 C and its 6 power
12237       rdiff6=rdiff**6.0d0
12238 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12239        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12240 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12241 C       print *,rdiff,rdiff6,pep_aa_tube
12242 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12243 C now we calculate gradient
12244        fac=(-12.0d0*pep_aa_tube/rdiff6-
12245      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12246 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12247 C     &rdiff,fac
12248
12249 C now direction of gg_tube vector
12250         do j=1,3
12251         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12252         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12253         enddo
12254         enddo
12255 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12256 C        print *,gg_tube(1,0),"TU"
12257
12258
12259        do i=itube_start,itube_end
12260 C Lets not jump over memory as we use many times iti
12261          iti=itype(i)
12262 C lets ommit dummy atoms for now
12263          if ((iti.eq.ntyp1)
12264 C in UNRES uncomment the line below as GLY has no side-chain...
12265 C      .or.(iti.eq.10)
12266      &   ) cycle
12267       xmin=boxxsize
12268       ymin=boxysize
12269         do j=-1,1
12270          vectube(1)=mod((c(1,i+nres)),boxxsize)
12271          vectube(1)=vectube(1)+boxxsize*j
12272          vectube(2)=mod((c(2,i+nres)),boxysize)
12273          vectube(2)=vectube(2)+boxysize*j
12274
12275          xminact=abs(vectube(1)-tubecenter(1))
12276          yminact=abs(vectube(2)-tubecenter(2))
12277            if (xmin.gt.xminact) then
12278             xmin=xminact
12279             xtemp=vectube(1)
12280            endif
12281            if (ymin.gt.yminact) then
12282              ymin=yminact
12283              ytemp=vectube(2)
12284             endif
12285          enddo
12286       vectube(1)=xtemp
12287       vectube(2)=ytemp
12288 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12289 C     &     tubecenter(2)
12290       vectube(1)=vectube(1)-tubecenter(1)
12291       vectube(2)=vectube(2)-tubecenter(2)
12292
12293 C as the tube is infinity we do not calculate the Z-vector use of Z
12294 C as chosen axis
12295       vectube(3)=0.0d0
12296 C now calculte the distance
12297        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12298 C now normalize vector
12299       vectube(1)=vectube(1)/tub_r
12300       vectube(2)=vectube(2)/tub_r
12301
12302 C calculte rdiffrence between r and r0
12303       rdiff=tub_r-tubeR0
12304 C and its 6 power
12305       rdiff6=rdiff**6.0d0
12306 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12307        sc_aa_tube=sc_aa_tube_par(iti)
12308        sc_bb_tube=sc_bb_tube_par(iti)
12309        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12310 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12311 C now we calculate gradient
12312        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12313      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12314 C now direction of gg_tube vector
12315          do j=1,3
12316           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12317           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12318          enddo
12319         enddo
12320         do i=itube_start,itube_end
12321           Etube=Etube+enetube(i)+enetube(i+nres)
12322         enddo
12323 C        print *,"ETUBE", etube
12324         return
12325         end
12326 C TO DO 1) add to total energy
12327 C       2) add to gradient summation
12328 C       3) add reading parameters (AND of course oppening of PARAM file)
12329 C       4) add reading the center of tube
12330 C       5) add COMMONs
12331 C       6) add to zerograd
12332
12333 C-----------------------------------------------------------------------
12334 C-----------------------------------------------------------
12335 C This subroutine is to mimic the histone like structure but as well can be
12336 C utilizet to nanostructures (infinit) small modification has to be used to
12337 C make it finite (z gradient at the ends has to be changes as well as the x,y
12338 C gradient has to be modified at the ends
12339 C The energy function is Kihara potential
12340 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12341 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12342 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12343 C simple Kihara potential
12344       subroutine calctube2(Etube)
12345        implicit real*8 (a-h,o-z)
12346       include 'DIMENSIONS'
12347       include 'COMMON.GEO'
12348       include 'COMMON.VAR'
12349       include 'COMMON.LOCAL'
12350       include 'COMMON.CHAIN'
12351       include 'COMMON.DERIV'
12352       include 'COMMON.NAMES'
12353       include 'COMMON.INTERACT'
12354       include 'COMMON.IOUNITS'
12355       include 'COMMON.CALC'
12356       include 'COMMON.CONTROL'
12357       include 'COMMON.SPLITELE'
12358       include 'COMMON.SBRIDGE'
12359       double precision tub_r,vectube(3),enetube(maxres*2)
12360       Etube=0.0d0
12361       do i=itube_start,itube_end
12362         enetube(i)=0.0d0
12363         enetube(i+nres)=0.0d0
12364       enddo
12365 C first we calculate the distance from tube center
12366 C first sugare-phosphate group for NARES this would be peptide group
12367 C for UNRES
12368        do i=itube_start,itube_end
12369 C lets ommit dummy atoms for now
12370
12371        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12372 C now calculate distance from center of tube and direction vectors
12373 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12374 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12375 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12376 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12377       xmin=boxxsize
12378       ymin=boxysize
12379         do j=-1,1
12380          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12381          vectube(1)=vectube(1)+boxxsize*j
12382          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12383          vectube(2)=vectube(2)+boxysize*j
12384
12385          xminact=abs(vectube(1)-tubecenter(1))
12386          yminact=abs(vectube(2)-tubecenter(2))
12387            if (xmin.gt.xminact) then
12388             xmin=xminact
12389             xtemp=vectube(1)
12390            endif
12391            if (ymin.gt.yminact) then
12392              ymin=yminact
12393              ytemp=vectube(2)
12394             endif
12395          enddo
12396       vectube(1)=xtemp
12397       vectube(2)=ytemp
12398       vectube(1)=vectube(1)-tubecenter(1)
12399       vectube(2)=vectube(2)-tubecenter(2)
12400
12401 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12402 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12403
12404 C as the tube is infinity we do not calculate the Z-vector use of Z
12405 C as chosen axis
12406       vectube(3)=0.0d0
12407 C now calculte the distance
12408        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12409 C now normalize vector
12410       vectube(1)=vectube(1)/tub_r
12411       vectube(2)=vectube(2)/tub_r
12412 C calculte rdiffrence between r and r0
12413       rdiff=tub_r-tubeR0
12414 C and its 6 power
12415       rdiff6=rdiff**6.0d0
12416 C THIS FRAGMENT MAKES TUBE FINITE
12417         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12418         if (positi.le.0) positi=positi+boxzsize
12419 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12420 c for each residue check if it is in lipid or lipid water border area
12421 C       respos=mod(c(3,i+nres),boxzsize)
12422 C       print *,positi,bordtubebot,buftubebot,bordtubetop
12423        if ((positi.gt.bordtubebot)
12424      & .and.(positi.lt.bordtubetop)) then
12425 C the energy transfer exist
12426         if (positi.lt.buftubebot) then
12427          fracinbuf=1.0d0-
12428      &     ((positi-bordtubebot)/tubebufthick)
12429 C lipbufthick is thickenes of lipid buffore
12430          sstube=sscalelip(fracinbuf)
12431          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12432 C         print *,ssgradtube, sstube,tubetranene(itype(i))
12433          enetube(i)=enetube(i)+sstube*tubetranenepep
12434 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12435 C     &+ssgradtube*tubetranene(itype(i))
12436 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12437 C     &+ssgradtube*tubetranene(itype(i))
12438 C         print *,"doing sccale for lower part"
12439         elseif (positi.gt.buftubetop) then
12440          fracinbuf=1.0d0-
12441      &((bordtubetop-positi)/tubebufthick)
12442          sstube=sscalelip(fracinbuf)
12443          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12444          enetube(i)=enetube(i)+sstube*tubetranenepep
12445 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12446 C     &+ssgradtube*tubetranene(itype(i))
12447 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12448 C     &+ssgradtube*tubetranene(itype(i))
12449 C          print *, "doing sscalefor top part",sslip,fracinbuf
12450         else
12451          sstube=1.0d0
12452          ssgradtube=0.0d0
12453          enetube(i)=enetube(i)+sstube*tubetranenepep
12454 C         print *,"I am in true lipid"
12455         endif
12456         else
12457 C          sstube=0.0d0
12458 C          ssgradtube=0.0d0
12459         cycle
12460         endif ! if in lipid or buffor
12461
12462 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12463        enetube(i)=enetube(i)+sstube*
12464      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
12465 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12466 C       print *,rdiff,rdiff6,pep_aa_tube
12467 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12468 C now we calculate gradient
12469        fac=(-12.0d0*pep_aa_tube/rdiff6-
12470      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
12471 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12472 C     &rdiff,fac
12473
12474 C now direction of gg_tube vector
12475         do j=1,3
12476         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12477         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12478         enddo
12479          gg_tube(3,i)=gg_tube(3,i)
12480      &+ssgradtube*enetube(i)/sstube/2.0d0
12481          gg_tube(3,i-1)= gg_tube(3,i-1)
12482      &+ssgradtube*enetube(i)/sstube/2.0d0
12483
12484         enddo
12485 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12486 C        print *,gg_tube(1,0),"TU"
12487         do i=itube_start,itube_end
12488 C Lets not jump over memory as we use many times iti
12489          iti=itype(i)
12490 C lets ommit dummy atoms for now
12491          if ((iti.eq.ntyp1)
12492 C in UNRES uncomment the line below as GLY has no side-chain...
12493      &      .or.(iti.eq.10)
12494      &   ) cycle
12495           vectube(1)=c(1,i+nres)
12496           vectube(1)=mod(vectube(1),boxxsize)
12497           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12498           vectube(2)=c(2,i+nres)
12499           vectube(2)=mod(vectube(2),boxysize)
12500           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12501
12502       vectube(1)=vectube(1)-tubecenter(1)
12503       vectube(2)=vectube(2)-tubecenter(2)
12504 C THIS FRAGMENT MAKES TUBE FINITE
12505         positi=(mod(c(3,i+nres),boxzsize))
12506         if (positi.le.0) positi=positi+boxzsize
12507 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12508 c for each residue check if it is in lipid or lipid water border area
12509 C       respos=mod(c(3,i+nres),boxzsize)
12510 C       print *,positi,bordtubebot,buftubebot,bordtubetop
12511
12512        if ((positi.gt.bordtubebot)
12513      & .and.(positi.lt.bordtubetop)) then
12514 C the energy transfer exist
12515         if (positi.lt.buftubebot) then
12516          fracinbuf=1.0d0-
12517      &     ((positi-bordtubebot)/tubebufthick)
12518 C lipbufthick is thickenes of lipid buffore
12519          sstube=sscalelip(fracinbuf)
12520          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12521 C         print *,ssgradtube, sstube,tubetranene(itype(i))
12522          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12523 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12524 C     &+ssgradtube*tubetranene(itype(i))
12525 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12526 C     &+ssgradtube*tubetranene(itype(i))
12527 C         print *,"doing sccale for lower part"
12528         elseif (positi.gt.buftubetop) then
12529          fracinbuf=1.0d0-
12530      &((bordtubetop-positi)/tubebufthick)
12531          sstube=sscalelip(fracinbuf)
12532          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12533          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12534 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12535 C     &+ssgradtube*tubetranene(itype(i))
12536 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12537 C     &+ssgradtube*tubetranene(itype(i))
12538 C          print *, "doing sscalefor top part",sslip,fracinbuf
12539         else
12540          sstube=1.0d0
12541          ssgradtube=0.0d0
12542          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12543 C         print *,"I am in true lipid"
12544         endif
12545         else
12546 C          sstube=0.0d0
12547 C          ssgradtube=0.0d0
12548         cycle
12549         endif ! if in lipid or buffor
12550 CEND OF FINITE FRAGMENT
12551 C as the tube is infinity we do not calculate the Z-vector use of Z
12552 C as chosen axis
12553       vectube(3)=0.0d0
12554 C now calculte the distance
12555        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12556 C now normalize vector
12557       vectube(1)=vectube(1)/tub_r
12558       vectube(2)=vectube(2)/tub_r
12559 C calculte rdiffrence between r and r0
12560       rdiff=tub_r-tubeR0
12561 C and its 6 power
12562       rdiff6=rdiff**6.0d0
12563 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12564        sc_aa_tube=sc_aa_tube_par(iti)
12565        sc_bb_tube=sc_bb_tube_par(iti)
12566        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12567      &                 *sstube+enetube(i+nres)
12568 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12569 C now we calculate gradient
12570        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12571      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12572 C now direction of gg_tube vector
12573          do j=1,3
12574           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12575           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12576          enddo
12577          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12578      &+ssgradtube*enetube(i+nres)/sstube
12579          gg_tube(3,i-1)= gg_tube(3,i-1)
12580      &+ssgradtube*enetube(i+nres)/sstube
12581
12582         enddo
12583         do i=itube_start,itube_end
12584           Etube=Etube+enetube(i)+enetube(i+nres)
12585         enddo
12586 C        print *,"ETUBE", etube
12587         return
12588         end
12589 C TO DO 1) add to total energy
12590 C       2) add to gradient summation
12591 C       3) add reading parameters (AND of course oppening of PARAM file)
12592 C       4) add reading the center of tube
12593 C       5) add COMMONs
12594 C       6) add to zerograd
12595
12596
12597 C#-------------------------------------------------------------------------------
12598 C This subroutine is to mimic the histone like structure but as well can be
12599 C utilizet to nanostructures (infinit) small modification has to be used to
12600 C make it finite (z gradient at the ends has to be changes as well as the x,y
12601 C gradient has to be modified at the ends
12602 C The energy function is Kihara potential
12603 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12604 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12605 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12606 C simple Kihara potential
12607       subroutine calcnano(Etube)
12608        implicit real*8 (a-h,o-z)
12609       include 'DIMENSIONS'
12610       include 'COMMON.GEO'
12611       include 'COMMON.VAR'
12612       include 'COMMON.LOCAL'
12613       include 'COMMON.CHAIN'
12614       include 'COMMON.DERIV'
12615       include 'COMMON.NAMES'
12616       include 'COMMON.INTERACT'
12617       include 'COMMON.IOUNITS'
12618       include 'COMMON.CALC'
12619       include 'COMMON.CONTROL'
12620       include 'COMMON.SPLITELE'
12621       include 'COMMON.SBRIDGE'
12622       double precision tub_r,vectube(3),enetube(maxres*2),
12623      & enecavtube(maxres*2)
12624       Etube=0.0d0
12625       do i=itube_start,itube_end
12626         enetube(i)=0.0d0
12627         enetube(i+nres)=0.0d0
12628       enddo
12629 C first we calculate the distance from tube center
12630 C first sugare-phosphate group for NARES this would be peptide group
12631 C for UNRES
12632        do i=itube_start,itube_end
12633 C lets ommit dummy atoms for now
12634        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12635 C now calculate distance from center of tube and direction vectors
12636       xmin=boxxsize
12637       ymin=boxysize
12638       zmin=boxzsize
12639
12640         do j=-1,1
12641          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12642          vectube(1)=vectube(1)+boxxsize*j
12643          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12644          vectube(2)=vectube(2)+boxysize*j
12645          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12646          vectube(3)=vectube(3)+boxzsize*j
12647
12648
12649          xminact=dabs(vectube(1)-tubecenter(1))
12650          yminact=dabs(vectube(2)-tubecenter(2))
12651          zminact=dabs(vectube(3)-tubecenter(3))
12652
12653            if (xmin.gt.xminact) then
12654             xmin=xminact
12655             xtemp=vectube(1)
12656            endif
12657            if (ymin.gt.yminact) then
12658              ymin=yminact
12659              ytemp=vectube(2)
12660             endif
12661            if (zmin.gt.zminact) then
12662              zmin=zminact
12663              ztemp=vectube(3)
12664             endif
12665          enddo
12666       vectube(1)=xtemp
12667       vectube(2)=ytemp
12668       vectube(3)=ztemp
12669
12670       vectube(1)=vectube(1)-tubecenter(1)
12671       vectube(2)=vectube(2)-tubecenter(2)
12672       vectube(3)=vectube(3)-tubecenter(3)
12673
12674 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12675 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12676 C as the tube is infinity we do not calculate the Z-vector use of Z
12677 C as chosen axis
12678 C      vectube(3)=0.0d0
12679 C now calculte the distance
12680        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12681 C now normalize vector
12682       vectube(1)=vectube(1)/tub_r
12683       vectube(2)=vectube(2)/tub_r
12684       vectube(3)=vectube(3)/tub_r
12685 C calculte rdiffrence between r and r0
12686       rdiff=tub_r-tubeR0
12687 C and its 6 power
12688       rdiff6=rdiff**6.0d0
12689 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12690        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12691 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12692 C       print *,rdiff,rdiff6,pep_aa_tube
12693 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12694 C now we calculate gradient
12695        fac=(-12.0d0*pep_aa_tube/rdiff6-
12696      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12697 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12698 C     &rdiff,fac
12699          if (acavtubpep.eq.0.0d0) then
12700 C go to 667
12701          enecavtube(i)=0.0
12702          faccav=0.0
12703          else
12704          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
12705          enecavtube(i)=
12706      &   (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep)
12707      &   /denominator
12708          enecavtube(i)=0.0
12709          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff))
12710      &   *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)
12711      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
12712      &   /denominator**2.0d0
12713 C         faccav=0.0
12714 C         fac=fac+faccav
12715 C 667     continue
12716          endif
12717 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
12718 C     &   enecavtube(i),faccav
12719 C         print *,"licz=",
12720 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12721 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
12722
12723 C now direction of gg_tube vector
12724         do j=1,3
12725         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12726         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12727         enddo
12728         enddo
12729
12730        do i=itube_start,itube_end
12731         enecavtube(i)=0.0d0
12732 C Lets not jump over memory as we use many times iti
12733          iti=itype(i)
12734 C lets ommit dummy atoms for now
12735          if ((iti.eq.ntyp1)
12736 C in UNRES uncomment the line below as GLY has no side-chain...
12737 C      .or.(iti.eq.10)
12738      &   ) cycle
12739       xmin=boxxsize
12740       ymin=boxysize
12741       zmin=boxzsize
12742         do j=-1,1
12743          vectube(1)=dmod((c(1,i+nres)),boxxsize)
12744          vectube(1)=vectube(1)+boxxsize*j
12745          vectube(2)=dmod((c(2,i+nres)),boxysize)
12746          vectube(2)=vectube(2)+boxysize*j
12747          vectube(3)=dmod((c(3,i+nres)),boxzsize)
12748          vectube(3)=vectube(3)+boxzsize*j
12749
12750
12751          xminact=dabs(vectube(1)-tubecenter(1))
12752          yminact=dabs(vectube(2)-tubecenter(2))
12753          zminact=dabs(vectube(3)-tubecenter(3))
12754
12755            if (xmin.gt.xminact) then
12756             xmin=xminact
12757             xtemp=vectube(1)
12758            endif
12759            if (ymin.gt.yminact) then
12760              ymin=yminact
12761              ytemp=vectube(2)
12762             endif
12763            if (zmin.gt.zminact) then
12764              zmin=zminact
12765              ztemp=vectube(3)
12766             endif
12767          enddo
12768       vectube(1)=xtemp
12769       vectube(2)=ytemp
12770       vectube(3)=ztemp
12771
12772 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12773 C     &     tubecenter(2)
12774       vectube(1)=vectube(1)-tubecenter(1)
12775       vectube(2)=vectube(2)-tubecenter(2)
12776       vectube(3)=vectube(3)-tubecenter(3)
12777 C now calculte the distance
12778        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12779 C now normalize vector
12780       vectube(1)=vectube(1)/tub_r
12781       vectube(2)=vectube(2)/tub_r
12782       vectube(3)=vectube(3)/tub_r
12783
12784 C calculte rdiffrence between r and r0
12785       rdiff=tub_r-tubeR0
12786 C and its 6 power
12787       rdiff6=rdiff**6.0d0
12788 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12789        sc_aa_tube=sc_aa_tube_par(iti)
12790        sc_bb_tube=sc_bb_tube_par(iti)
12791        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12792 C       enetube(i+nres)=0.0d0
12793 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12794 C now we calculate gradient
12795        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12796      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12797 C       fac=0.0
12798 C now direction of gg_tube vector
12799 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12800          if (acavtub(iti).eq.0.0d0) then
12801 C go to 667
12802          enecavtube(i+nres)=0.0d0
12803          faccav=0.0d0
12804          else
12805          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
12806          enecavtube(i+nres)=
12807      &   (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti))
12808      &   /denominator
12809 C         enecavtube(i)=0.0
12810          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff))
12811      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)
12812      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
12813      &   /denominator**2.0d0
12814 C         faccav=0.0
12815          fac=fac+faccav
12816 C 667     continue
12817          endif
12818 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
12819 C     &   enecavtube(i),faccav
12820 C         print *,"licz=",
12821 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12822 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
12823          do j=1,3
12824           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12825           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12826          enddo
12827         enddo
12828 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12829 C        do i=itube_start,itube_end
12830 C        enecav(i)=0.0
12831 C        iti=itype(i)
12832 C        if (acavtub(iti).eq.0.0) cycle
12833
12834
12835
12836         do i=itube_start,itube_end
12837           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
12838      & +enecavtube(i+nres)
12839         enddo
12840 C        print *,"ETUBE", etube
12841         return
12842         end
12843 C TO DO 1) add to total energy
12844 C       2) add to gradient summation
12845 C       3) add reading parameters (AND of course oppening of PARAM file)
12846 C       4) add reading the center of tube
12847 C       5) add COMMONs
12848 C       6) add to zerograd
12849