source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       integer IERR
  14       integer status(MPI_STATUS_SIZE)
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26       include 'COMMON.MD'
  27       include 'COMMON.CONTROL'
  28       include 'COMMON.TIME1'
  29       include 'COMMON.SPLITELE'
  30       include 'COMMON.SHIELD'
  31       double precision fac_shieldbuf(maxres),
  32      & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
  33      & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
  34      & grad_shieldbuf(3,-1:maxres)
  35        integer ishield_listbuf(maxres),
  36      &shield_listbuf(maxcontsshi,maxres)
  37 #ifdef MPI
  38 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  39 c     & " nfgtasks",nfgtasks
  40       if (nfgtasks.gt.1) then
  41         time00=MPI_Wtime()
  42 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  43         if (fg_rank.eq.0) then
  44           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  45 c          print *,"Processor",myrank," BROADCAST iorder"
  46 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  47 C FG slaves as WEIGHTS array.
  48           weights_(1)=wsc
  49           weights_(2)=wscp
  50           weights_(3)=welec
  51           weights_(4)=wcorr
  52           weights_(5)=wcorr5
  53           weights_(6)=wcorr6
  54           weights_(7)=wel_loc
  55           weights_(8)=wturn3
  56           weights_(9)=wturn4
  57           weights_(10)=wturn6
  58           weights_(11)=wang
  59           weights_(12)=wscloc
  60           weights_(13)=wtor
  61           weights_(14)=wtor_d
  62           weights_(15)=wstrain
  63           weights_(16)=wvdwpp
  64           weights_(17)=wbond
  65           weights_(18)=scal14
  66           weights_(21)=wsccor
  67           weights_(22)=wtube
  68
  69 C FG Master broadcasts the WEIGHTS_ array
  70           call MPI_Bcast(weights_(1),n_ene,
  71      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  72         else
  73 C FG slaves receive the WEIGHTS array
  74           call MPI_Bcast(weights(1),n_ene,
  75      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  76           wsc=weights(1)
  77           wscp=weights(2)
  78           welec=weights(3)
  79           wcorr=weights(4)
  80           wcorr5=weights(5)
  81           wcorr6=weights(6)
  82           wel_loc=weights(7)
  83           wturn3=weights(8)
  84           wturn4=weights(9)
  85           wturn6=weights(10)
  86           wang=weights(11)
  87           wscloc=weights(12)
  88           wtor=weights(13)
  89           wtor_d=weights(14)
  90           wstrain=weights(15)
  91           wvdwpp=weights(16)
  92           wbond=weights(17)
  93           scal14=weights(18)
  94           wsccor=weights(21)
  95           wtube=weights(22)
  96         endif
  97         time_Bcast=time_Bcast+MPI_Wtime()-time00
  98         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  99 c        call chainbuild_cart
 100       endif
 101 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 102 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 103 #else
 104 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 105 c        call int_from_cart1(.false.)
 106 c      endif
 107 #endif
 108 #ifdef TIMING
 109       time00=MPI_Wtime()
 110 #endif
 111 C
 112 C Compute the side-chain and electrostatic interaction energy
 113 C
 114 C      print *,ipot
 115       goto (101,102,103,104,105,106) ipot
 116 C Lennard-Jones potential.
 117   101 call elj(evdw)
 118 cd    print '(a)','Exit ELJ'
 119       goto 107
 120 C Lennard-Jones-Kihara potential (shifted).
 121   102 call eljk(evdw)
 122       goto 107
 123 C Berne-Pechukas potential (dilated LJ, angular dependence).
 124   103 call ebp(evdw)
 125       goto 107
 126 C Gay-Berne potential (shifted LJ, angular dependence).
 127   104 call egb(evdw)
 128 C      print *,"bylem w egb"
 129       goto 107
 130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 131   105 call egbv(evdw)
 132       goto 107
 133 C Soft-sphere potential
 134   106 call e_softsphere(evdw)
 135 C
 136 C Calculate electrostatic (H-bonding) energy of the main chain.
 137 C
 138   107 continue
 139 cmc
 140 cmc Sep-06: egb takes care of dynamic ss bonds too
 141 cmc
 142 c      if (dyn_ss) call dyn_set_nss
 143
 144 c      print *,"Processor",myrank," computed USCSC"
 145 #ifdef TIMING
 146       time01=MPI_Wtime()
 147 #endif
 148       call vec_and_deriv
 149 #ifdef TIMING
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #endif
 152 C Introduction of shielding effect first for each peptide group
 153 C the shielding factor is set this factor is describing how each
 154 C peptide group is shielded by side-chains
 155 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 156 C      write (iout,*) "shield_mode",shield_mode
 157       if (shield_mode.eq.1) then
 158        call set_shield_fac
 159       else if  (shield_mode.eq.2) then
 160        call set_shield_fac2
 161       if (nfgtasks.gt.1) then
 162 C#define DEBUG
 163 #ifdef DEBUG
 164        write(iout,*) "befor reduce fac_shield reduce"
 165        do i=1,nres
 166         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 167         write(2,*) "list", shield_list(1,i),ishield_list(i),
 168      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 169        enddo
 170 #endif
 171        call MPI_Allgatherv(fac_shield(ivec_start),
 172      &  ivec_count(fg_rank1),
 173      &  MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0),
 174      &  ivec_displ(0),
 175      &  MPI_DOUBLE_PRECISION,FG_COMM,IERR)
 176        call MPI_Allgatherv(shield_list(1,ivec_start),
 177      &  ivec_count(fg_rank1),
 178      &  MPI_I50,shield_listbuf(1,1),ivec_count(0),
 179      &  ivec_displ(0),
 180      &  MPI_I50,FG_COMM,IERR)
 181        call MPI_Allgatherv(ishield_list(ivec_start),
 182      &  ivec_count(fg_rank1),
 183      &  MPI_INTEGER,ishield_listbuf(1),ivec_count(0),
 184      &  ivec_displ(0),
 185      &  MPI_INTEGER,FG_COMM,IERR)
 186        call MPI_Allgatherv(grad_shield(1,ivec_start),
 187      &  ivec_count(fg_rank1),
 188      &  MPI_UYZ,grad_shieldbuf(1,1),ivec_count(0),
 189      &  ivec_displ(0),
 190      &  MPI_UYZ,FG_COMM,IERR)
 191        call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
 192      &  ivec_count(fg_rank1),
 193      &  MPI_SHI,grad_shield_sidebuf(1,1,1),ivec_count(0),
 194      &  ivec_displ(0),
 195      &  MPI_SHI,FG_COMM,IERR)
 196        call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
 197      &  ivec_count(fg_rank1),
 198      &  MPI_SHI,grad_shield_locbuf(1,1,1),ivec_count(0),
 199      &  ivec_displ(0),
 200      &  MPI_SHI,FG_COMM,IERR)
 201        do i=1,nres
 202         fac_shield(i)=fac_shieldbuf(i)
 203         ishield_list(i)=ishield_listbuf(i)
 204         do j=1,3
 205         grad_shield(j,i)=grad_shieldbuf(j,i)
 206         enddo !j
 207         do j=1,ishield_list(i)
 208           shield_list(j,i)=shield_listbuf(j,i)
 209          do k=1,3
 210          grad_shield_loc(k,j,i)=grad_shield_locbuf(k,j,i)
 211          grad_shield_side(k,j,i)=grad_shield_sidebuf(k,j,i)
 212          enddo !k
 213        enddo !j
 214       enddo !i
 215 #ifdef DEBUG
 216        write(iout,*) "after reduce fac_shield reduce"
 217        do i=1,nres
 218         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 219         write(2,*) "list", shield_list(1,i),ishield_list(i),
 220      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 221        enddo
 222 #endif
 223 C#undef DEBUG
 224       endif
 225 #ifdef DEBUG
 226       do i=1,nres
 227       write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
 228         do j=1,ishield_list(i)
 229          write(iout,*) "grad", grad_shield_side(1,j,i),
 230      &   grad_shield_loc(1,j,i)
 231         enddo
 232       enddo
 233 #endif
 234       endif
 235 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 236       if (ipot.lt.6) then
 237 #ifdef SPLITELE
 238          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 239      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 240      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 241      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 242 #else
 243          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 244      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 245      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 246      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 247 #endif
 248             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 249          else
 250             ees=0.0d0
 251             evdw1=0.0d0
 252             eel_loc=0.0d0
 253             eello_turn3=0.0d0
 254             eello_turn4=0.0d0
 255          endif
 256       else
 257         write (iout,*) "Soft-spheer ELEC potential"
 258 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 259 c     &   eello_turn4)
 260       endif
 261 c      print *,"Processor",myrank," computed UELEC"
 262 C
 263 C Calculate excluded-volume interaction energy between peptide groups
 264 C and side chains.
 265 C
 266       if (ipot.lt.6) then
 267        if(wscp.gt.0d0) then
 268         call escp(evdw2,evdw2_14)
 269        else
 270         evdw2=0
 271         evdw2_14=0
 272        endif
 273       else
 274 c        write (iout,*) "Soft-sphere SCP potential"
 275         call escp_soft_sphere(evdw2,evdw2_14)
 276       endif
 277 c
 278 c Calculate the bond-stretching energy
 279 c
 280       call ebond(estr)
 281 C
 282 C Calculate the disulfide-bridge and other energy and the contributions
 283 C from other distance constraints.
 284 cd    print *,'Calling EHPB'
 285       call edis(ehpb)
 286 cd    print *,'EHPB exitted succesfully.'
 287 C
 288 C Calculate the virtual-bond-angle energy.
 289 C
 290       if (wang.gt.0d0) then
 291        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 292         call ebend(ebe,ethetacnstr)
 293         endif
 294 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 295 C energy function
 296        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 297          call ebend_kcc(ebe,ethetacnstr)
 298         endif
 299       else
 300         ebe=0
 301         ethetacnstr=0
 302       endif
 303 c      print *,"Processor",myrank," computed UB"
 304 C
 305 C Calculate the SC local energy.
 306 C
 307 C      print *,"TU DOCHODZE?"
 308       call esc(escloc)
 309 c      print *,"Processor",myrank," computed USC"
 310 C
 311 C Calculate the virtual-bond torsional energy.
 312 C
 313 cd    print *,'nterm=',nterm
 314 C      print *,"tor",tor_mode
 315       if (wtor.gt.0) then
 316        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 317        call etor(etors,edihcnstr)
 318        endif
 319 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 320 C energy function
 321        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 322        call etor_kcc(etors,edihcnstr)
 323        endif
 324       else
 325        etors=0
 326        edihcnstr=0
 327       endif
 328 c      print *,"Processor",myrank," computed Utor"
 329 C
 330 C 6/23/01 Calculate double-torsional energy
 331 C
 332       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 333        call etor_d(etors_d)
 334       else
 335        etors_d=0
 336       endif
 337 c      print *,"Processor",myrank," computed Utord"
 338 C
 339 C 21/5/07 Calculate local sicdechain correlation energy
 340 C
 341       if (wsccor.gt.0.0d0) then
 342         call eback_sc_corr(esccor)
 343       else
 344         esccor=0.0d0
 345       endif
 346 C      print *,"PRZED MULIt"
 347 c      print *,"Processor",myrank," computed Usccorr"
 348 C
 349 C 12/1/95 Multi-body terms
 350 C
 351       n_corr=0
 352       n_corr1=0
 353       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 354      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 355          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 356 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 357 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 358       else
 359          ecorr=0.0d0
 360          ecorr5=0.0d0
 361          ecorr6=0.0d0
 362          eturn6=0.0d0
 363       endif
 364       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 365          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 366 cd         write (iout,*) "multibody_hb ecorr",ecorr
 367       endif
 368 c      print *,"Processor",myrank," computed Ucorr"
 369 C
 370 C If performing constraint dynamics, call the constraint energy
 371 C  after the equilibration time
 372       if(usampl.and.totT.gt.eq_time) then
 373          call EconstrQ
 374          call Econstr_back
 375       else
 376          Uconst=0.0d0
 377          Uconst_back=0.0d0
 378       endif
 379 C 01/27/2015 added by adasko
 380 C the energy component below is energy transfer into lipid environment
 381 C based on partition function
 382 C      print *,"przed lipidami"
 383       if (wliptran.gt.0) then
 384         call Eliptransfer(eliptran)
 385       else
 386        eliptran=0.0d0
 387       endif
 388 C      print *,"za lipidami"
 389       if (AFMlog.gt.0) then
 390         call AFMforce(Eafmforce)
 391       else if (selfguide.gt.0) then
 392         call AFMvel(Eafmforce)
 393       endif
 394       if (TUBElog.eq.1) then
 395 C      print *,"just before call"
 396         call calctube(Etube)
 397        elseif (TUBElog.eq.2) then
 398         call calctube2(Etube)
 399        elseif (TUBElog.eq.3) then
 400         call calcnano(Etube)
 401        else
 402        Etube=0.0d0
 403        endif
 404
 405 #ifdef TIMING
 406       time_enecalc=time_enecalc+MPI_Wtime()-time00
 407 #endif
 408 c      print *,"Processor",myrank," computed Uconstr"
 409 #ifdef TIMING
 410       time00=MPI_Wtime()
 411 #endif
 412 c
 413 C Sum the energies
 414 C
 415       energia(1)=evdw
 416 #ifdef SCP14
 417       energia(2)=evdw2-evdw2_14
 418       energia(18)=evdw2_14
 419 #else
 420       energia(2)=evdw2
 421       energia(18)=0.0d0
 422 #endif
 423 #ifdef SPLITELE
 424       energia(3)=ees
 425       energia(16)=evdw1
 426 #else
 427       energia(3)=ees+evdw1
 428       energia(16)=0.0d0
 429 #endif
 430       energia(4)=ecorr
 431       energia(5)=ecorr5
 432       energia(6)=ecorr6
 433       energia(7)=eel_loc
 434       energia(8)=eello_turn3
 435       energia(9)=eello_turn4
 436       energia(10)=eturn6
 437       energia(11)=ebe
 438       energia(12)=escloc
 439       energia(13)=etors
 440       energia(14)=etors_d
 441       energia(15)=ehpb
 442       energia(19)=edihcnstr
 443       energia(17)=estr
 444       energia(20)=Uconst+Uconst_back
 445       energia(21)=esccor
 446       energia(22)=eliptran
 447       energia(23)=Eafmforce
 448       energia(24)=ethetacnstr
 449       energia(25)=Etube
 450 c    Here are the energies showed per procesor if the are more processors
 451 c    per molecule then we sum it up in sum_energy subroutine
 452 c      print *," Processor",myrank," calls SUM_ENERGY"
 453       call sum_energy(energia,.true.)
 454       if (dyn_ss) call dyn_set_nss
 455 c      print *," Processor",myrank," left SUM_ENERGY"
 456 #ifdef TIMING
 457       time_sumene=time_sumene+MPI_Wtime()-time00
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_energy(energia,reduce)
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include "mpif.h"
 473 #endif
 474       include 'COMMON.SETUP'
 475       include 'COMMON.IOUNITS'
 476       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       logical reduce
 486 #ifdef MPI
 487       if (nfgtasks.gt.1 .and. reduce) then
 488 #ifdef DEBUG
 489         write (iout,*) "energies before REDUCE"
 490         call enerprint(energia)
 491         call flush(iout)
 492 #endif
 493         do i=0,n_ene
 494           enebuff(i)=energia(i)
 495         enddo
 496         time00=MPI_Wtime()
 497         call MPI_Barrier(FG_COMM,IERR)
 498         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 499         time00=MPI_Wtime()
 500         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 501      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 502 #ifdef DEBUG
 503         write (iout,*) "energies after REDUCE"
 504         call enerprint(energia)
 505         call flush(iout)
 506 #endif
 507         time_Reduce=time_Reduce+MPI_Wtime()-time00
 508       endif
 509       if (fg_rank.eq.0) then
 510 #endif
 511       evdw=energia(1)
 512 #ifdef SCP14
 513       evdw2=energia(2)+energia(18)
 514       evdw2_14=energia(18)
 515 #else
 516       evdw2=energia(2)
 517 #endif
 518 #ifdef SPLITELE
 519       ees=energia(3)
 520       evdw1=energia(16)
 521 #else
 522       ees=energia(3)
 523       evdw1=0.0d0
 524 #endif
 525       ecorr=energia(4)
 526       ecorr5=energia(5)
 527       ecorr6=energia(6)
 528       eel_loc=energia(7)
 529       eello_turn3=energia(8)
 530       eello_turn4=energia(9)
 531       eturn6=energia(10)
 532       ebe=energia(11)
 533       escloc=energia(12)
 534       etors=energia(13)
 535       etors_d=energia(14)
 536       ehpb=energia(15)
 537       edihcnstr=energia(19)
 538       estr=energia(17)
 539       Uconst=energia(20)
 540       esccor=energia(21)
 541       eliptran=energia(22)
 542       Eafmforce=energia(23)
 543       ethetacnstr=energia(24)
 544       Etube=energia(25)
 545 #ifdef SPLITELE
 546       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 547      & +wang*ebe+wtor*etors+wscloc*escloc
 548      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 549      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 550      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 551      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 552      & +ethetacnstr+wtube*Etube
 553 #else
 554       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 555      & +wang*ebe+wtor*etors+wscloc*escloc
 556      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 557      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 558      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 559      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 560      & +Eafmforce
 561      & +ethetacnstr+wtube*Etube
 562 #endif
 563       energia(0)=etot
 564 c detecting NaNQ
 565 #ifdef ISNAN
 566 #ifdef AIX
 567       if (isnan(etot).ne.0) energia(0)=1.0d+99
 568 #else
 569       if (isnan(etot)) energia(0)=1.0d+99
 570 #endif
 571 #else
 572       i=0
 573 #ifdef WINPGI
 574       idumm=proc_proc(etot,i)
 575 #else
 576       call proc_proc(etot,i)
 577 #endif
 578       if(i.eq.1)energia(0)=1.0d+99
 579 #endif
 580 #ifdef MPI
 581       endif
 582 #endif
 583       return
 584       end
 585 c-------------------------------------------------------------------------------
 586       subroutine sum_gradient
 587       implicit real*8 (a-h,o-z)
 588       include 'DIMENSIONS'
 589 #ifndef ISNAN
 590       external proc_proc
 591 #ifdef WINPGI
 592 cMS$ATTRIBUTES C ::  proc_proc
 593 #endif
 594 #endif
 595 #ifdef MPI
 596       include 'mpif.h'
 597 #endif
 598       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 599      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 600      & ,gloc_scbuf(3,-1:maxres)
 601       include 'COMMON.SETUP'
 602       include 'COMMON.IOUNITS'
 603       include 'COMMON.FFIELD'
 604       include 'COMMON.DERIV'
 605       include 'COMMON.INTERACT'
 606       include 'COMMON.SBRIDGE'
 607       include 'COMMON.CHAIN'
 608       include 'COMMON.VAR'
 609       include 'COMMON.CONTROL'
 610       include 'COMMON.TIME1'
 611       include 'COMMON.MAXGRAD'
 612       include 'COMMON.SCCOR'
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616 #ifdef DEBUG
 617       write (iout,*) "sum_gradient gvdwc, gvdwx"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 620      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef MPI
 625 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 626         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 627      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 628 #endif
 629 C
 630 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 631 C            in virtual-bond-vector coordinates
 632 C
 633 #ifdef DEBUG
 634 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 635 c      do i=1,nres-1
 636 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 637 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 638 c      enddo
 639 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 640 c      do i=1,nres-1
 641 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 642 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 643 c      enddo
 644       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 645       do i=1,nres
 646         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 647      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 648      &   g_corr5_loc(i)
 649       enddo
 650       call flush(iout)
 651 #endif
 652 #ifdef SPLITELE
 653       do i=0,nct
 654         do j=1,3
 655           gradbufc(j,i)=wsc*gvdwc(j,i)+
 656      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 657      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 658      &                wel_loc*gel_loc_long(j,i)+
 659      &                wcorr*gradcorr_long(j,i)+
 660      &                wcorr5*gradcorr5_long(j,i)+
 661      &                wcorr6*gradcorr6_long(j,i)+
 662      &                wturn6*gcorr6_turn_long(j,i)+
 663      &                wstrain*ghpbc(j,i)
 664      &                +wliptran*gliptranc(j,i)
 665      &                +gradafm(j,i)
 666      &                 +welec*gshieldc(j,i)
 667      &                 +wcorr*gshieldc_ec(j,i)
 668      &                 +wturn3*gshieldc_t3(j,i)
 669      &                 +wturn4*gshieldc_t4(j,i)
 670      &                 +wel_loc*gshieldc_ll(j,i)
 671      &                +wtube*gg_tube(j,i)
 672
 673
 674
 675         enddo
 676       enddo
 677 C      j=1
 678 C      i=0
 679 C      print *,"KUPA2",gradbufc(j,i),wsc*gvdwc(j,i),
 680 C     &                wscp*gvdwc_scp(j,i),gvdwc_scpp(j,i),
 681 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 682 C     &                wel_loc*gel_loc_long(j,i),
 683 C     &                wcorr*gradcorr_long(j,i),
 684 C     &                wcorr5*gradcorr5_long(j,i),
 685 C     &                wcorr6*gradcorr6_long(j,i),
 686 C     &                wturn6*gcorr6_turn_long(j,i),
 687 C     &                wstrain*ghpbc(j,i)
 688 C     &                ,wliptran*gliptranc(j,i)
 689 C     &                ,gradafm(j,i)
 690 C     &                 ,welec*gshieldc(j,i)
 691 C     &                 ,wcorr*gshieldc_ec(j,i)
 692 C     &                 ,wturn3*gshieldc_t3(j,i)
 693 C     &                 ,wturn4*gshieldc_t4(j,i)
 694 C     &                 ,wel_loc*gshieldc_ll(j,i)
 695 C     &                ,wtube*gg_tube(j,i)
 696 #else
 697       do i=0,nct
 698         do j=1,3
 699           gradbufc(j,i)=wsc*gvdwc(j,i)+
 700      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 701      &                welec*gelc_long(j,i)+
 702      &                wbond*gradb(j,i)+
 703      &                wel_loc*gel_loc_long(j,i)+
 704      &                wcorr*gradcorr_long(j,i)+
 705      &                wcorr5*gradcorr5_long(j,i)+
 706      &                wcorr6*gradcorr6_long(j,i)+
 707      &                wturn6*gcorr6_turn_long(j,i)+
 708      &                wstrain*ghpbc(j,i)
 709      &                +wliptran*gliptranc(j,i)
 710      &                +gradafm(j,i)
 711      &                 +welec*gshieldc(j,i)
 712      &                 +wcorr*gshieldc_ec(j,i)
 713      &                 +wturn4*gshieldc_t4(j,i)
 714      &                 +wel_loc*gshieldc_ll(j,i)
 715      &                +wtube*gg_tube(j,i)
 716
 717
 718
 719         enddo
 720       enddo
 721 #endif
 722 #ifdef MPI
 723       if (nfgtasks.gt.1) then
 724       time00=MPI_Wtime()
 725 #ifdef DEBUG
 726       write (iout,*) "gradbufc before allreduce"
 727       do i=1,nres
 728         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 729       enddo
 730       call flush(iout)
 731 #endif
 732       do i=0,nres
 733         do j=1,3
 734           gradbufc_sum(j,i)=gradbufc(j,i)
 735         enddo
 736       enddo
 737 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 738 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 739 c      time_reduce=time_reduce+MPI_Wtime()-time00
 740 #ifdef DEBUG
 741 c      write (iout,*) "gradbufc_sum after allreduce"
 742 c      do i=1,nres
 743 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 744 c      enddo
 745 c      call flush(iout)
 746 #endif
 747 #ifdef TIMING
 748 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 749 #endif
 750       do i=0,nres
 751         do k=1,3
 752           gradbufc(k,i)=0.0d0
 753         enddo
 754       enddo
 755 #ifdef DEBUG
 756       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 757       write (iout,*) (i," jgrad_start",jgrad_start(i),
 758      &                  " jgrad_end  ",jgrad_end(i),
 759      &                  i=igrad_start,igrad_end)
 760 #endif
 761 c
 762 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 763 c do not parallelize this part.
 764 c
 765 c      do i=igrad_start,igrad_end
 766 c        do j=jgrad_start(i),jgrad_end(i)
 767 c          do k=1,3
 768 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 769 c          enddo
 770 c        enddo
 771 c      enddo
 772       do j=1,3
 773         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 774       enddo
 775       do i=nres-2,-1,-1
 776         do j=1,3
 777           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 778         enddo
 779       enddo
 780 #ifdef DEBUG
 781       write (iout,*) "gradbufc after summing"
 782       do i=1,nres
 783         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 784       enddo
 785       call flush(iout)
 786 #endif
 787       else
 788 #endif
 789 #ifdef DEBUG
 790       write (iout,*) "gradbufc"
 791       do i=1,nres
 792         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 793       enddo
 794       call flush(iout)
 795 #endif
 796       do i=-1,nres
 797         do j=1,3
 798           gradbufc_sum(j,i)=gradbufc(j,i)
 799           gradbufc(j,i)=0.0d0
 800         enddo
 801       enddo
 802       do j=1,3
 803         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 804       enddo
 805       do i=nres-2,-1,-1
 806         do j=1,3
 807           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 808         enddo
 809       enddo
 810 c      do i=nnt,nres-1
 811 c        do k=1,3
 812 c          gradbufc(k,i)=0.0d0
 813 c        enddo
 814 c        do j=i+1,nres
 815 c          do k=1,3
 816 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 817 c          enddo
 818 c        enddo
 819 c      enddo
 820 #ifdef DEBUG
 821       write (iout,*) "gradbufc after summing"
 822       do i=1,nres
 823         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 824       enddo
 825       call flush(iout)
 826 #endif
 827 #ifdef MPI
 828       endif
 829 #endif
 830       do k=1,3
 831         gradbufc(k,nres)=0.0d0
 832       enddo
 833       do i=-1,nct
 834         do j=1,3
 835 #ifdef SPLITELE
 836 C          print *,gradbufc(1,13)
 837 C          print *,welec*gelc(1,13)
 838 C          print *,wel_loc*gel_loc(1,13)
 839 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 840 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 841 C          print *,wel_loc*gel_loc_long(1,13)
 842 C          print *,gradafm(1,13),"AFM"
 843           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 844      &                wel_loc*gel_loc(j,i)+
 845      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 846      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 847      &                wel_loc*gel_loc_long(j,i)+
 848      &                wcorr*gradcorr_long(j,i)+
 849      &                wcorr5*gradcorr5_long(j,i)+
 850      &                wcorr6*gradcorr6_long(j,i)+
 851      &                wturn6*gcorr6_turn_long(j,i))+
 852      &                wbond*gradb(j,i)+
 853      &                wcorr*gradcorr(j,i)+
 854      &                wturn3*gcorr3_turn(j,i)+
 855      &                wturn4*gcorr4_turn(j,i)+
 856      &                wcorr5*gradcorr5(j,i)+
 857      &                wcorr6*gradcorr6(j,i)+
 858      &                wturn6*gcorr6_turn(j,i)+
 859      &                wsccor*gsccorc(j,i)
 860      &               +wscloc*gscloc(j,i)
 861      &               +wliptran*gliptranc(j,i)
 862      &                +gradafm(j,i)
 863      &                 +welec*gshieldc(j,i)
 864      &                 +welec*gshieldc_loc(j,i)
 865      &                 +wcorr*gshieldc_ec(j,i)
 866      &                 +wcorr*gshieldc_loc_ec(j,i)
 867      &                 +wturn3*gshieldc_t3(j,i)
 868      &                 +wturn3*gshieldc_loc_t3(j,i)
 869      &                 +wturn4*gshieldc_t4(j,i)
 870      &                 +wturn4*gshieldc_loc_t4(j,i)
 871      &                 +wel_loc*gshieldc_ll(j,i)
 872      &                 +wel_loc*gshieldc_loc_ll(j,i)
 873      &                +wtube*gg_tube(j,i)
 874
 875 #else
 876           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 877      &                wel_loc*gel_loc(j,i)+
 878      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 879      &                welec*gelc_long(j,i)+
 880      &                wel_loc*gel_loc_long(j,i)+
 881      &                wcorr*gcorr_long(j,i)+
 882      &                wcorr5*gradcorr5_long(j,i)+
 883      &                wcorr6*gradcorr6_long(j,i)+
 884      &                wturn6*gcorr6_turn_long(j,i))+
 885      &                wbond*gradb(j,i)+
 886      &                wcorr*gradcorr(j,i)+
 887      &                wturn3*gcorr3_turn(j,i)+
 888      &                wturn4*gcorr4_turn(j,i)+
 889      &                wcorr5*gradcorr5(j,i)+
 890      &                wcorr6*gradcorr6(j,i)+
 891      &                wturn6*gcorr6_turn(j,i)+
 892      &                wsccor*gsccorc(j,i)
 893      &               +wscloc*gscloc(j,i)
 894      &               +wliptran*gliptranc(j,i)
 895      &                +gradafm(j,i)
 896      &                 +welec*gshieldc(j,i)
 897      &                 +welec*gshieldc_loc(j,i)
 898      &                 +wcorr*gshieldc_ec(j,i)
 899      &                 +wcorr*gshieldc_loc_ec(j,i)
 900      &                 +wturn3*gshieldc_t3(j,i)
 901      &                 +wturn3*gshieldc_loc_t3(j,i)
 902      &                 +wturn4*gshieldc_t4(j,i)
 903      &                 +wturn4*gshieldc_loc_t4(j,i)
 904      &                 +wel_loc*gshieldc_ll(j,i)
 905      &                 +wel_loc*gshieldc_loc_ll(j,i)
 906      &                +wtube*gg_tube(j,i)
 907
 908
 909 #endif
 910           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 911      &                  wbond*gradbx(j,i)+
 912      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 913      &                  wsccor*gsccorx(j,i)
 914      &                 +wscloc*gsclocx(j,i)
 915      &                 +wliptran*gliptranx(j,i)
 916      &                 +welec*gshieldx(j,i)
 917      &                 +wcorr*gshieldx_ec(j,i)
 918      &                 +wturn3*gshieldx_t3(j,i)
 919      &                 +wturn4*gshieldx_t4(j,i)
 920      &                 +wel_loc*gshieldx_ll(j,i)
 921      &                 +wtube*gg_tube_sc(j,i)
 922
 923
 924
 925         enddo
 926       enddo
 927 C       i=0
 928 C       j=1
 929 C       print *,"KUPA",    gradbufc(j,i),welec*gelc(j,i),
 930 C     &                wel_loc*gel_loc(j,i),
 931 C     &                0.5d0*wscp*gvdwc_scpp(j,i),
 932 C     &                welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
 933 C     &                wel_loc*gel_loc_long(j,i),
 934 C     &                wcorr*gradcorr_long(j,i),
 935 C     &                wcorr5*gradcorr5_long(j,i),
 936 C     &                wcorr6*gradcorr6_long(j,i),
 937 C     &                wturn6*gcorr6_turn_long(j,i),
 938 C     &                wbond*gradb(j,i),
 939 C     &                wcorr*gradcorr(j,i),
 940 C     &                wturn3*gcorr3_turn(j,i),
 941 C     &                wturn4*gcorr4_turn(j,i),
 942 C     &                wcorr5*gradcorr5(j,i),
 943 C     &                wcorr6*gradcorr6(j,i),
 944 C     &                wturn6*gcorr6_turn(j,i),
 945 C     &                wsccor*gsccorc(j,i)
 946 C     &               ,wscloc*gscloc(j,i)
 947 C     &               ,wliptran*gliptranc(j,i)
 948 C     &                ,gradafm(j,i)
 949 C     &                 +welec*gshieldc(j,i)
 950 C     &                 +welec*gshieldc_loc(j,i)
 951 C     &                 +wcorr*gshieldc_ec(j,i)
 952 C     &                 +wcorr*gshieldc_loc_ec(j,i)
 953 C     &                 +wturn3*gshieldc_t3(j,i)
 954 C     &                 +wturn3*gshieldc_loc_t3(j,i)
 955 C     &                 +wturn4*gshieldc_t4(j,i)
 956 C     &                 ,wturn4*gshieldc_loc_t4(j,i)
 957 C     &                 ,wel_loc*gshieldc_ll(j,i)
 958 C     &                 ,wel_loc*gshieldc_loc_ll(j,i)
 959 C     &                ,wtube*gg_tube(j,i)
 960
 961 C      print *,gg_tube(1,0),"TU3"
 962 #ifdef DEBUG
 963       write (iout,*) "gloc before adding corr"
 964       do i=1,4*nres
 965         write (iout,*) i,gloc(i,icg)
 966       enddo
 967 #endif
 968       do i=1,nres-3
 969         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 970      &   +wcorr5*g_corr5_loc(i)
 971      &   +wcorr6*g_corr6_loc(i)
 972      &   +wturn4*gel_loc_turn4(i)
 973      &   +wturn3*gel_loc_turn3(i)
 974      &   +wturn6*gel_loc_turn6(i)
 975      &   +wel_loc*gel_loc_loc(i)
 976       enddo
 977 #ifdef DEBUG
 978       write (iout,*) "gloc after adding corr"
 979       do i=1,4*nres
 980         write (iout,*) i,gloc(i,icg)
 981       enddo
 982 #endif
 983 #ifdef MPI
 984       if (nfgtasks.gt.1) then
 985         do j=1,3
 986           do i=1,nres
 987             gradbufc(j,i)=gradc(j,i,icg)
 988             gradbufx(j,i)=gradx(j,i,icg)
 989           enddo
 990         enddo
 991         do i=1,4*nres
 992           glocbuf(i)=gloc(i,icg)
 993         enddo
 994 c#define DEBUG
 995 #ifdef DEBUG
 996       write (iout,*) "gloc_sc before reduce"
 997       do i=1,nres
 998        do j=1,1
 999         write (iout,*) i,j,gloc_sc(j,i,icg)
1000        enddo
1001       enddo
1002 #endif
1003 c#undef DEBUG
1004         do i=1,nres
1005          do j=1,3
1006           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1007          enddo
1008         enddo
1009         time00=MPI_Wtime()
1010         call MPI_Barrier(FG_COMM,IERR)
1011         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1012         time00=MPI_Wtime()
1013         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,
1014      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1015         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1016      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1017         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1018      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019         time_reduce=time_reduce+MPI_Wtime()-time00
1020         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1021      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1022         time_reduce=time_reduce+MPI_Wtime()-time00
1023 c#define DEBUG
1024 #ifdef DEBUG
1025       write (iout,*) "gloc_sc after reduce"
1026       do i=1,nres
1027        do j=1,1
1028         write (iout,*) i,j,gloc_sc(j,i,icg)
1029        enddo
1030       enddo
1031 #endif
1032 c#undef DEBUG
1033 #ifdef DEBUG
1034       write (iout,*) "gloc after reduce"
1035       do i=1,4*nres
1036         write (iout,*) i,gloc(i,icg)
1037       enddo
1038 #endif
1039       endif
1040 #endif
1041       if (gnorm_check) then
1042 c
1043 c Compute the maximum elements of the gradient
1044 c
1045       gvdwc_max=0.0d0
1046       gvdwc_scp_max=0.0d0
1047       gelc_max=0.0d0
1048       gvdwpp_max=0.0d0
1049       gradb_max=0.0d0
1050       ghpbc_max=0.0d0
1051       gradcorr_max=0.0d0
1052       gel_loc_max=0.0d0
1053       gcorr3_turn_max=0.0d0
1054       gcorr4_turn_max=0.0d0
1055       gradcorr5_max=0.0d0
1056       gradcorr6_max=0.0d0
1057       gcorr6_turn_max=0.0d0
1058       gsccorc_max=0.0d0
1059       gscloc_max=0.0d0
1060       gvdwx_max=0.0d0
1061       gradx_scp_max=0.0d0
1062       ghpbx_max=0.0d0
1063       gradxorr_max=0.0d0
1064       gsccorx_max=0.0d0
1065       gsclocx_max=0.0d0
1066       do i=1,nct
1067         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1068         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1069         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1070         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1071      &   gvdwc_scp_max=gvdwc_scp_norm
1072         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1073         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1074         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1075         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1076         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1077         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1078         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1079         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1080         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1081         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1082         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1083         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1084         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1085      &    gcorr3_turn(1,i)))
1086         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1087      &    gcorr3_turn_max=gcorr3_turn_norm
1088         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1089      &    gcorr4_turn(1,i)))
1090         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1091      &    gcorr4_turn_max=gcorr4_turn_norm
1092         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1093         if (gradcorr5_norm.gt.gradcorr5_max)
1094      &    gradcorr5_max=gradcorr5_norm
1095         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1096         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1097         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1098      &    gcorr6_turn(1,i)))
1099         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1100      &    gcorr6_turn_max=gcorr6_turn_norm
1101         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1102         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1103         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1104         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1105         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1106         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1107         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1108         if (gradx_scp_norm.gt.gradx_scp_max)
1109      &    gradx_scp_max=gradx_scp_norm
1110         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1111         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1112         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1113         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1114         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1115         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1116         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1117         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1118       enddo
1119       if (gradout) then
1120 #ifdef AIX
1121         open(istat,file=statname,position="append")
1122 #else
1123         open(istat,file=statname,access="append")
1124 #endif
1125         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1126      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1127      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1128      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1129      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1130      &     gsccorx_max,gsclocx_max
1131         close(istat)
1132         if (gvdwc_max.gt.1.0d4) then
1133           write (iout,*) "gvdwc gvdwx gradb gradbx"
1134           do i=nnt,nct
1135             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1136      &        gradb(j,i),gradbx(j,i),j=1,3)
1137           enddo
1138           call pdbout(0.0d0,'cipiszcze',iout)
1139           call flush(iout)
1140         endif
1141       endif
1142       endif
1143 #ifdef DEBUG
1144       write (iout,*) "gradc gradx gloc"
1145       do i=1,nres
1146         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1147      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1148       enddo
1149 #endif
1150 #ifdef TIMING
1151       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1152 #endif
1153       return
1154       end
1155 c-------------------------------------------------------------------------------
1156       subroutine rescale_weights(t_bath)
1157       implicit real*8 (a-h,o-z)
1158       include 'DIMENSIONS'
1159       include 'COMMON.IOUNITS'
1160       include 'COMMON.FFIELD'
1161       include 'COMMON.SBRIDGE'
1162       include 'COMMON.CONTROL'
1163       double precision kfac /2.4d0/
1164       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1165 c      facT=temp0/t_bath
1166 c      facT=2*temp0/(t_bath+temp0)
1167       if (rescale_mode.eq.0) then
1168         facT=1.0d0
1169         facT2=1.0d0
1170         facT3=1.0d0
1171         facT4=1.0d0
1172         facT5=1.0d0
1173       else if (rescale_mode.eq.1) then
1174         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1175         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1176         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1177         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1178         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1179       else if (rescale_mode.eq.2) then
1180         x=t_bath/temp0
1181         x2=x*x
1182         x3=x2*x
1183         x4=x3*x
1184         x5=x4*x
1185         facT=licznik/dlog(dexp(x)+dexp(-x))
1186         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1187         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1188         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1189         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1190       else
1191         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1192         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1193 #ifdef MPI
1194        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1195 #endif
1196        stop 555
1197       endif
1198       if (shield_mode.gt.0) then
1199        wscp=weights(2)*fact
1200        wsc=weights(1)*fact
1201        wvdwpp=weights(16)*fact
1202       endif
1203       welec=weights(3)*fact
1204       wcorr=weights(4)*fact3
1205       wcorr5=weights(5)*fact4
1206       wcorr6=weights(6)*fact5
1207       wel_loc=weights(7)*fact2
1208       wturn3=weights(8)*fact2
1209       wturn4=weights(9)*fact3
1210       wturn6=weights(10)*fact5
1211       wtor=weights(13)*fact
1212       wtor_d=weights(14)*fact2
1213       wsccor=weights(21)*fact
1214
1215       return
1216       end
1217 C------------------------------------------------------------------------
1218       subroutine enerprint(energia)
1219       implicit real*8 (a-h,o-z)
1220       include 'DIMENSIONS'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.FFIELD'
1223       include 'COMMON.SBRIDGE'
1224       include 'COMMON.MD'
1225       double precision energia(0:n_ene)
1226       etot=energia(0)
1227       evdw=energia(1)
1228       evdw2=energia(2)
1229 #ifdef SCP14
1230       evdw2=energia(2)+energia(18)
1231 #else
1232       evdw2=energia(2)
1233 #endif
1234       ees=energia(3)
1235 #ifdef SPLITELE
1236       evdw1=energia(16)
1237 #endif
1238       ecorr=energia(4)
1239       ecorr5=energia(5)
1240       ecorr6=energia(6)
1241       eel_loc=energia(7)
1242       eello_turn3=energia(8)
1243       eello_turn4=energia(9)
1244       eello_turn6=energia(10)
1245       ebe=energia(11)
1246       escloc=energia(12)
1247       etors=energia(13)
1248       etors_d=energia(14)
1249       ehpb=energia(15)
1250       edihcnstr=energia(19)
1251       estr=energia(17)
1252       Uconst=energia(20)
1253       esccor=energia(21)
1254       eliptran=energia(22)
1255       Eafmforce=energia(23)
1256       ethetacnstr=energia(24)
1257       etube=energia(25)
1258 #ifdef SPLITELE
1259       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1260      &  estr,wbond,ebe,wang,
1261      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1262      &  ecorr,wcorr,
1263      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1264      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1265      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1266      &  etube,wtube,
1267      &  etot
1268    10 format (/'Virtual-chain energies:'//
1269      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1270      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1271      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1272      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1273      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1274      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1275      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1276      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1277      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1278      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1279      & ' (SS bridges & dist. cnstr.)'/
1280      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1281      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1282      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1283      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1284      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1285      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1286      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1287      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1288      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1289      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1290      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1291      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1292      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1293      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1294      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1295      & 'ETOT=  ',1pE16.6,' (total)')
1296
1297 #else
1298       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1299      &  estr,wbond,ebe,wang,
1300      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1301      &  ecorr,wcorr,
1302      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1303      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1304      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1305      &  etube,wtube,
1306      &  etot
1307    10 format (/'Virtual-chain energies:'//
1308      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1309      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1310      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1311      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1312      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1313      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1314      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1315      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1316      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1317      & ' (SS bridges & dist. cnstr.)'/
1318      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1319      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1320      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1321      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1322      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1323      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1324      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1325      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1326      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1327      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1328      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1329      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1330      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1331      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1332      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1333      & 'ETOT=  ',1pE16.6,' (total)')
1334 #endif
1335       return
1336       end
1337 C-----------------------------------------------------------------------
1338       subroutine elj(evdw)
1339 C
1340 C This subroutine calculates the interaction energy of nonbonded side chains
1341 C assuming the LJ potential of interaction.
1342 C
1343       implicit real*8 (a-h,o-z)
1344       include 'DIMENSIONS'
1345       parameter (accur=1.0d-10)
1346       include 'COMMON.GEO'
1347       include 'COMMON.VAR'
1348       include 'COMMON.LOCAL'
1349       include 'COMMON.CHAIN'
1350       include 'COMMON.DERIV'
1351       include 'COMMON.INTERACT'
1352       include 'COMMON.TORSION'
1353       include 'COMMON.SBRIDGE'
1354       include 'COMMON.NAMES'
1355       include 'COMMON.IOUNITS'
1356       include 'COMMON.CONTACTS'
1357       dimension gg(3)
1358 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1359       evdw=0.0D0
1360       do i=iatsc_s,iatsc_e
1361         itypi=iabs(itype(i))
1362         if (itypi.eq.ntyp1) cycle
1363         itypi1=iabs(itype(i+1))
1364         xi=c(1,nres+i)
1365         yi=c(2,nres+i)
1366         zi=c(3,nres+i)
1367 C Change 12/1/95
1368         num_conti=0
1369 C
1370 C Calculate SC interaction energy.
1371 C
1372         do iint=1,nint_gr(i)
1373 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1374 cd   &                  'iend=',iend(i,iint)
1375           do j=istart(i,iint),iend(i,iint)
1376             itypj=iabs(itype(j))
1377             if (itypj.eq.ntyp1) cycle
1378             xj=c(1,nres+j)-xi
1379             yj=c(2,nres+j)-yi
1380             zj=c(3,nres+j)-zi
1381 C Change 12/1/95 to calculate four-body interactions
1382             rij=xj*xj+yj*yj+zj*zj
1383             rrij=1.0D0/rij
1384 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1385             eps0ij=eps(itypi,itypj)
1386             fac=rrij**expon2
1387 C have you changed here?
1388             e1=fac*fac*aa
1389             e2=fac*bb
1390             evdwij=e1+e2
1391 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1392 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1393 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1394 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1395 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1396 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1397             evdw=evdw+evdwij
1398 C
1399 C Calculate the components of the gradient in DC and X
1400 C
1401             fac=-rrij*(e1+evdwij)
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405             do k=1,3
1406               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1410             enddo
1411 cgrad            do k=i,j-1
1412 cgrad              do l=1,3
1413 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1414 cgrad              enddo
1415 cgrad            enddo
1416 C
1417 C 12/1/95, revised on 5/20/97
1418 C
1419 C Calculate the contact function. The ith column of the array JCONT will
1420 C contain the numbers of atoms that make contacts with the atom I (of numbers
1421 C greater than I). The arrays FACONT and GACONT will contain the values of
1422 C the contact function and its derivative.
1423 C
1424 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1425 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1426 C Uncomment next line, if the correlation interactions are contact function only
1427             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1428               rij=dsqrt(rij)
1429               sigij=sigma(itypi,itypj)
1430               r0ij=rs0(itypi,itypj)
1431 C
1432 C Check whether the SC's are not too far to make a contact.
1433 C
1434               rcut=1.5d0*r0ij
1435               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1436 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1437 C
1438               if (fcont.gt.0.0D0) then
1439 C If the SC-SC distance if close to sigma, apply spline.
1440 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1441 cAdam &             fcont1,fprimcont1)
1442 cAdam           fcont1=1.0d0-fcont1
1443 cAdam           if (fcont1.gt.0.0d0) then
1444 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1445 cAdam             fcont=fcont*fcont1
1446 cAdam           endif
1447 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1448 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1449 cga             do k=1,3
1450 cga               gg(k)=gg(k)*eps0ij
1451 cga             enddo
1452 cga             eps0ij=-evdwij*eps0ij
1453 C Uncomment for AL's type of SC correlation interactions.
1454 cadam           eps0ij=-evdwij
1455                 num_conti=num_conti+1
1456                 jcont(num_conti,i)=j
1457                 facont(num_conti,i)=fcont*eps0ij
1458                 fprimcont=eps0ij*fprimcont/rij
1459                 fcont=expon*fcont
1460 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1461 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1462 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1463 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1464                 gacont(1,num_conti,i)=-fprimcont*xj
1465                 gacont(2,num_conti,i)=-fprimcont*yj
1466                 gacont(3,num_conti,i)=-fprimcont*zj
1467 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1468 cd              write (iout,'(2i3,3f10.5)')
1469 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1470               endif
1471             endif
1472           enddo      ! j
1473         enddo        ! iint
1474 C Change 12/1/95
1475         num_cont(i)=num_conti
1476       enddo          ! i
1477       do i=1,nct
1478         do j=1,3
1479           gvdwc(j,i)=expon*gvdwc(j,i)
1480           gvdwx(j,i)=expon*gvdwx(j,i)
1481         enddo
1482       enddo
1483 C******************************************************************************
1484 C
1485 C                              N O T E !!!
1486 C
1487 C To save time, the factor of EXPON has been extracted from ALL components
1488 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1489 C use!
1490 C
1491 C******************************************************************************
1492       return
1493       end
1494 C-----------------------------------------------------------------------------
1495       subroutine eljk(evdw)
1496 C
1497 C This subroutine calculates the interaction energy of nonbonded side chains
1498 C assuming the LJK potential of interaction.
1499 C
1500       implicit real*8 (a-h,o-z)
1501       include 'DIMENSIONS'
1502       include 'COMMON.GEO'
1503       include 'COMMON.VAR'
1504       include 'COMMON.LOCAL'
1505       include 'COMMON.CHAIN'
1506       include 'COMMON.DERIV'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.NAMES'
1510       dimension gg(3)
1511       logical scheck
1512 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1513       evdw=0.0D0
1514       do i=iatsc_s,iatsc_e
1515         itypi=iabs(itype(i))
1516         if (itypi.eq.ntyp1) cycle
1517         itypi1=iabs(itype(i+1))
1518         xi=c(1,nres+i)
1519         yi=c(2,nres+i)
1520         zi=c(3,nres+i)
1521 C
1522 C Calculate SC interaction energy.
1523 C
1524         do iint=1,nint_gr(i)
1525           do j=istart(i,iint),iend(i,iint)
1526             itypj=iabs(itype(j))
1527             if (itypj.eq.ntyp1) cycle
1528             xj=c(1,nres+j)-xi
1529             yj=c(2,nres+j)-yi
1530             zj=c(3,nres+j)-zi
1531             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532             fac_augm=rrij**expon
1533             e_augm=augm(itypi,itypj)*fac_augm
1534             r_inv_ij=dsqrt(rrij)
1535             rij=1.0D0/r_inv_ij
1536             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1537             fac=r_shift_inv**expon
1538 C have you changed here?
1539             e1=fac*fac*aa
1540             e2=fac*bb
1541             evdwij=e_augm+e1+e2
1542 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1543 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1544 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1545 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1546 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1547 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1548 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1549             evdw=evdw+evdwij
1550 C
1551 C Calculate the components of the gradient in DC and X
1552 C
1553             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557             do k=1,3
1558               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1559               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1561               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1562             enddo
1563 cgrad            do k=i,j-1
1564 cgrad              do l=1,3
1565 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1566 cgrad              enddo
1567 cgrad            enddo
1568           enddo      ! j
1569         enddo        ! iint
1570       enddo          ! i
1571       do i=1,nct
1572         do j=1,3
1573           gvdwc(j,i)=expon*gvdwc(j,i)
1574           gvdwx(j,i)=expon*gvdwx(j,i)
1575         enddo
1576       enddo
1577       return
1578       end
1579 C-----------------------------------------------------------------------------
1580       subroutine ebp(evdw)
1581 C
1582 C This subroutine calculates the interaction energy of nonbonded side chains
1583 C assuming the Berne-Pechukas potential of interaction.
1584 C
1585       implicit real*8 (a-h,o-z)
1586       include 'DIMENSIONS'
1587       include 'COMMON.GEO'
1588       include 'COMMON.VAR'
1589       include 'COMMON.LOCAL'
1590       include 'COMMON.CHAIN'
1591       include 'COMMON.DERIV'
1592       include 'COMMON.NAMES'
1593       include 'COMMON.INTERACT'
1594       include 'COMMON.IOUNITS'
1595       include 'COMMON.CALC'
1596       common /srutu/ icall
1597 c     double precision rrsave(maxdim)
1598       logical lprn
1599       evdw=0.0D0
1600 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1601       evdw=0.0D0
1602 c     if (icall.eq.0) then
1603 c       lprn=.true.
1604 c     else
1605         lprn=.false.
1606 c     endif
1607       ind=0
1608       do i=iatsc_s,iatsc_e
1609         itypi=iabs(itype(i))
1610         if (itypi.eq.ntyp1) cycle
1611         itypi1=iabs(itype(i+1))
1612         xi=c(1,nres+i)
1613         yi=c(2,nres+i)
1614         zi=c(3,nres+i)
1615         dxi=dc_norm(1,nres+i)
1616         dyi=dc_norm(2,nres+i)
1617         dzi=dc_norm(3,nres+i)
1618 c        dsci_inv=dsc_inv(itypi)
1619         dsci_inv=vbld_inv(i+nres)
1620 C
1621 C Calculate SC interaction energy.
1622 C
1623         do iint=1,nint_gr(i)
1624           do j=istart(i,iint),iend(i,iint)
1625             ind=ind+1
1626             itypj=iabs(itype(j))
1627             if (itypj.eq.ntyp1) cycle
1628 c            dscj_inv=dsc_inv(itypj)
1629             dscj_inv=vbld_inv(j+nres)
1630             chi1=chi(itypi,itypj)
1631             chi2=chi(itypj,itypi)
1632             chi12=chi1*chi2
1633             chip1=chip(itypi)
1634             chip2=chip(itypj)
1635             chip12=chip1*chip2
1636             alf1=alp(itypi)
1637             alf2=alp(itypj)
1638             alf12=0.5D0*(alf1+alf2)
1639 C For diagnostics only!!!
1640 c           chi1=0.0D0
1641 c           chi2=0.0D0
1642 c           chi12=0.0D0
1643 c           chip1=0.0D0
1644 c           chip2=0.0D0
1645 c           chip12=0.0D0
1646 c           alf1=0.0D0
1647 c           alf2=0.0D0
1648 c           alf12=0.0D0
1649             xj=c(1,nres+j)-xi
1650             yj=c(2,nres+j)-yi
1651             zj=c(3,nres+j)-zi
1652             dxj=dc_norm(1,nres+j)
1653             dyj=dc_norm(2,nres+j)
1654             dzj=dc_norm(3,nres+j)
1655             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1656 cd          if (icall.eq.0) then
1657 cd            rrsave(ind)=rrij
1658 cd          else
1659 cd            rrij=rrsave(ind)
1660 cd          endif
1661             rij=dsqrt(rrij)
1662 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1663             call sc_angular
1664 C Calculate whole angle-dependent part of epsilon and contributions
1665 C to its derivatives
1666 C have you changed here?
1667             fac=(rrij*sigsq)**expon2
1668             e1=fac*fac*aa
1669             e2=fac*bb
1670             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1671             eps2der=evdwij*eps3rt
1672             eps3der=evdwij*eps2rt
1673             evdwij=evdwij*eps2rt*eps3rt
1674             evdw=evdw+evdwij
1675             if (lprn) then
1676             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1677             epsi=bb**2/aa
1678 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1679 cd     &        restyp(itypi),i,restyp(itypj),j,
1680 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1681 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1682 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1683 cd     &        evdwij
1684             endif
1685 C Calculate gradient components.
1686             e1=e1*eps1*eps2rt**2*eps3rt**2
1687             fac=-expon*(e1+evdwij)
1688             sigder=fac/sigsq
1689             fac=rrij*fac
1690 C Calculate radial part of the gradient
1691             gg(1)=xj*fac
1692             gg(2)=yj*fac
1693             gg(3)=zj*fac
1694 C Calculate the angular part of the gradient and sum add the contributions
1695 C to the appropriate components of the Cartesian gradient.
1696             call sc_grad
1697           enddo      ! j
1698         enddo        ! iint
1699       enddo          ! i
1700 c     stop
1701       return
1702       end
1703 C-----------------------------------------------------------------------------
1704       subroutine egb(evdw)
1705 C
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne potential of interaction.
1708 C
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.GEO'
1712       include 'COMMON.VAR'
1713       include 'COMMON.LOCAL'
1714       include 'COMMON.CHAIN'
1715       include 'COMMON.DERIV'
1716       include 'COMMON.NAMES'
1717       include 'COMMON.INTERACT'
1718       include 'COMMON.IOUNITS'
1719       include 'COMMON.CALC'
1720       include 'COMMON.CONTROL'
1721       include 'COMMON.SPLITELE'
1722       include 'COMMON.SBRIDGE'
1723       logical lprn
1724       integer xshift,yshift,zshift
1725
1726       evdw=0.0D0
1727 ccccc      energy_dec=.false.
1728 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1729       evdw=0.0D0
1730       lprn=.false.
1731 c     if (icall.eq.0) lprn=.false.
1732       ind=0
1733 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1734 C we have the original box)
1735 C      do xshift=-1,1
1736 C      do yshift=-1,1
1737 C      do zshift=-1,1
1738       do i=iatsc_s,iatsc_e
1739         itypi=iabs(itype(i))
1740         if (itypi.eq.ntyp1) cycle
1741         itypi1=iabs(itype(i+1))
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745 C Return atom into box, boxxsize is size of box in x dimension
1746 c  134   continue
1747 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1748 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1749 C Condition for being inside the proper box
1750 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1751 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1752 c        go to 134
1753 c        endif
1754 c  135   continue
1755 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1756 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1757 C Condition for being inside the proper box
1758 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1759 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1760 c        go to 135
1761 c        endif
1762 c  136   continue
1763 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1764 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1765 C Condition for being inside the proper box
1766 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1767 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1768 c        go to 136
1769 c        endif
1770           xi=mod(xi,boxxsize)
1771           if (xi.lt.0) xi=xi+boxxsize
1772           yi=mod(yi,boxysize)
1773           if (yi.lt.0) yi=yi+boxysize
1774           zi=mod(zi,boxzsize)
1775           if (zi.lt.0) zi=zi+boxzsize
1776 C define scaling factor for lipids
1777
1778 C        if (positi.le.0) positi=positi+boxzsize
1779 C        print *,i
1780 C first for peptide groups
1781 c for each residue check if it is in lipid or lipid water border area
1782        if ((zi.gt.bordlipbot)
1783      &.and.(zi.lt.bordliptop)) then
1784 C the energy transfer exist
1785         if (zi.lt.buflipbot) then
1786 C what fraction I am in
1787          fracinbuf=1.0d0-
1788      &        ((zi-bordlipbot)/lipbufthick)
1789 C lipbufthick is thickenes of lipid buffore
1790          sslipi=sscalelip(fracinbuf)
1791          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1792         elseif (zi.gt.bufliptop) then
1793          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1794          sslipi=sscalelip(fracinbuf)
1795          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1796         else
1797          sslipi=1.0d0
1798          ssgradlipi=0.0
1799         endif
1800        else
1801          sslipi=0.0d0
1802          ssgradlipi=0.0
1803        endif
1804
1805 C          xi=xi+xshift*boxxsize
1806 C          yi=yi+yshift*boxysize
1807 C          zi=zi+zshift*boxzsize
1808
1809         dxi=dc_norm(1,nres+i)
1810         dyi=dc_norm(2,nres+i)
1811         dzi=dc_norm(3,nres+i)
1812 c        dsci_inv=dsc_inv(itypi)
1813         dsci_inv=vbld_inv(i+nres)
1814 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1815 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1816 C
1817 C Calculate SC interaction energy.
1818 C
1819         do iint=1,nint_gr(i)
1820           do j=istart(i,iint),iend(i,iint)
1821             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1822
1823 c              write(iout,*) "PRZED ZWYKLE", evdwij
1824               call dyn_ssbond_ene(i,j,evdwij)
1825 c              write(iout,*) "PO ZWYKLE", evdwij
1826
1827               evdw=evdw+evdwij
1828               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1829      &                        'evdw',i,j,evdwij,' ss'
1830 C triple bond artifac removal
1831              do k=j+1,iend(i,iint)
1832 C search over all next residues
1833               if (dyn_ss_mask(k)) then
1834 C check if they are cysteins
1835 C              write(iout,*) 'k=',k
1836
1837 c              write(iout,*) "PRZED TRI", evdwij
1838                evdwij_przed_tri=evdwij
1839               call triple_ssbond_ene(i,j,k,evdwij)
1840 c               if(evdwij_przed_tri.ne.evdwij) then
1841 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1842 c               endif
1843
1844 c              write(iout,*) "PO TRI", evdwij
1845 C call the energy function that removes the artifical triple disulfide
1846 C bond the soubroutine is located in ssMD.F
1847               evdw=evdw+evdwij
1848               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1849      &                        'evdw',i,j,evdwij,'tss'
1850               endif!dyn_ss_mask(k)
1851              enddo! k
1852             ELSE
1853             ind=ind+1
1854             itypj=iabs(itype(j))
1855             if (itypj.eq.ntyp1) cycle
1856 c            dscj_inv=dsc_inv(itypj)
1857             dscj_inv=vbld_inv(j+nres)
1858 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1859 c     &       1.0d0/vbld(j+nres)
1860 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1861             sig0ij=sigma(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881             xj=c(1,nres+j)
1882             yj=c(2,nres+j)
1883             zj=c(3,nres+j)
1884 C Return atom J into box the original box
1885 c  137   continue
1886 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1887 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1888 C Condition for being inside the proper box
1889 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1890 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1891 c        go to 137
1892 c        endif
1893 c  138   continue
1894 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1895 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1896 C Condition for being inside the proper box
1897 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1898 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1899 c        go to 138
1900 c        endif
1901 c  139   continue
1902 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1903 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1904 C Condition for being inside the proper box
1905 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1906 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1907 c        go to 139
1908 c        endif
1909           xj=mod(xj,boxxsize)
1910           if (xj.lt.0) xj=xj+boxxsize
1911           yj=mod(yj,boxysize)
1912           if (yj.lt.0) yj=yj+boxysize
1913           zj=mod(zj,boxzsize)
1914           if (zj.lt.0) zj=zj+boxzsize
1915        if ((zj.gt.bordlipbot)
1916      &.and.(zj.lt.bordliptop)) then
1917 C the energy transfer exist
1918         if (zj.lt.buflipbot) then
1919 C what fraction I am in
1920          fracinbuf=1.0d0-
1921      &        ((zj-bordlipbot)/lipbufthick)
1922 C lipbufthick is thickenes of lipid buffore
1923          sslipj=sscalelip(fracinbuf)
1924          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925         elseif (zj.gt.bufliptop) then
1926          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927          sslipj=sscalelip(fracinbuf)
1928          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1929         else
1930          sslipj=1.0d0
1931          ssgradlipj=0.0
1932         endif
1933        else
1934          sslipj=0.0d0
1935          ssgradlipj=0.0
1936        endif
1937       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1940      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1942 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1943 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1944 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1945 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1946       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1947       xj_safe=xj
1948       yj_safe=yj
1949       zj_safe=zj
1950       subchap=0
1951       do xshift=-1,1
1952       do yshift=-1,1
1953       do zshift=-1,1
1954           xj=xj_safe+xshift*boxxsize
1955           yj=yj_safe+yshift*boxysize
1956           zj=zj_safe+zshift*boxzsize
1957           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1958           if(dist_temp.lt.dist_init) then
1959             dist_init=dist_temp
1960             xj_temp=xj
1961             yj_temp=yj
1962             zj_temp=zj
1963             subchap=1
1964           endif
1965        enddo
1966        enddo
1967        enddo
1968        if (subchap.eq.1) then
1969           xj=xj_temp-xi
1970           yj=yj_temp-yi
1971           zj=zj_temp-zi
1972        else
1973           xj=xj_safe-xi
1974           yj=yj_safe-yi
1975           zj=zj_safe-zi
1976        endif
1977             dxj=dc_norm(1,nres+j)
1978             dyj=dc_norm(2,nres+j)
1979             dzj=dc_norm(3,nres+j)
1980 C            xj=xj-xi
1981 C            yj=yj-yi
1982 C            zj=zj-zi
1983 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1984 c            write (iout,*) "j",j," dc_norm",
1985 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1986             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1987             rij=dsqrt(rrij)
1988             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1989             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1990
1991 c            write (iout,'(a7,4f8.3)')
1992 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1993             if (sss.gt.0.0d0) then
1994 C Calculate angle-dependent terms of energy and contributions to their
1995 C derivatives.
1996             call sc_angular
1997             sigsq=1.0D0/sigsq
1998             sig=sig0ij*dsqrt(sigsq)
1999             rij_shift=1.0D0/rij-sig+sig0ij
2000 c for diagnostics; uncomment
2001 c            rij_shift=1.2*sig0ij
2002 C I hate to put IF's in the loops, but here don't have another choice!!!!
2003             if (rij_shift.le.0.0D0) then
2004               evdw=1.0D20
2005 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2006 cd     &        restyp(itypi),i,restyp(itypj),j,
2007 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2008               return
2009             endif
2010             sigder=-sig*sigsq
2011 c---------------------------------------------------------------
2012             rij_shift=1.0D0/rij_shift
2013             fac=rij_shift**expon
2014 C here to start with
2015 C            if (c(i,3).gt.
2016             faclip=fac
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2023 C     &((sslipi+sslipj)/2.0d0+
2024 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2025 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2026 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2027             evdwij=evdwij*eps2rt*eps3rt
2028             evdw=evdw+evdwij*sss
2029             if (lprn) then
2030             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2031             epsi=bb**2/aa
2032             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2033      &        restyp(itypi),i,restyp(itypj),j,
2034      &        epsi,sigm,chi1,chi2,chip1,chip2,
2035      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2036      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2037      &        evdwij
2038             endif
2039
2040             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2041      &                        'evdw',i,j,evdwij
2042
2043 C Calculate gradient components.
2044             e1=e1*eps1*eps2rt**2*eps3rt**2
2045             fac=-expon*(e1+evdwij)*rij_shift
2046             sigder=fac*sigder
2047             fac=rij*fac
2048 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2049 c     &      evdwij,fac,sigma(itypi,itypj),expon
2050             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2051 c            fac=0.0d0
2052 C Calculate the radial part of the gradient
2053             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2054      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2055      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2056      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2057             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2058             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2059 C            gg_lipi(3)=0.0d0
2060 C            gg_lipj(3)=0.0d0
2061             gg(1)=xj*fac
2062             gg(2)=yj*fac
2063             gg(3)=zj*fac
2064 C Calculate angular part of the gradient.
2065             call sc_grad
2066             endif
2067             ENDIF    ! dyn_ss
2068           enddo      ! j
2069         enddo        ! iint
2070       enddo          ! i
2071 C      enddo          ! zshift
2072 C      enddo          ! yshift
2073 C      enddo          ! xshift
2074 c      write (iout,*) "Number of loop steps in EGB:",ind
2075 cccc      energy_dec=.false.
2076       return
2077       end
2078 C-----------------------------------------------------------------------------
2079       subroutine egbv(evdw)
2080 C
2081 C This subroutine calculates the interaction energy of nonbonded side chains
2082 C assuming the Gay-Berne-Vorobjev potential of interaction.
2083 C
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.GEO'
2087       include 'COMMON.VAR'
2088       include 'COMMON.LOCAL'
2089       include 'COMMON.CHAIN'
2090       include 'COMMON.DERIV'
2091       include 'COMMON.NAMES'
2092       include 'COMMON.INTERACT'
2093       include 'COMMON.IOUNITS'
2094       include 'COMMON.CALC'
2095       common /srutu/ icall
2096       logical lprn
2097       evdw=0.0D0
2098 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2099       evdw=0.0D0
2100       lprn=.false.
2101 c     if (icall.eq.0) lprn=.true.
2102       ind=0
2103       do i=iatsc_s,iatsc_e
2104         itypi=iabs(itype(i))
2105         if (itypi.eq.ntyp1) cycle
2106         itypi1=iabs(itype(i+1))
2107         xi=c(1,nres+i)
2108         yi=c(2,nres+i)
2109         zi=c(3,nres+i)
2110           xi=mod(xi,boxxsize)
2111           if (xi.lt.0) xi=xi+boxxsize
2112           yi=mod(yi,boxysize)
2113           if (yi.lt.0) yi=yi+boxysize
2114           zi=mod(zi,boxzsize)
2115           if (zi.lt.0) zi=zi+boxzsize
2116 C define scaling factor for lipids
2117
2118 C        if (positi.le.0) positi=positi+boxzsize
2119 C        print *,i
2120 C first for peptide groups
2121 c for each residue check if it is in lipid or lipid water border area
2122        if ((zi.gt.bordlipbot)
2123      &.and.(zi.lt.bordliptop)) then
2124 C the energy transfer exist
2125         if (zi.lt.buflipbot) then
2126 C what fraction I am in
2127          fracinbuf=1.0d0-
2128      &        ((zi-bordlipbot)/lipbufthick)
2129 C lipbufthick is thickenes of lipid buffore
2130          sslipi=sscalelip(fracinbuf)
2131          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2132         elseif (zi.gt.bufliptop) then
2133          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2134          sslipi=sscalelip(fracinbuf)
2135          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2136         else
2137          sslipi=1.0d0
2138          ssgradlipi=0.0
2139         endif
2140        else
2141          sslipi=0.0d0
2142          ssgradlipi=0.0
2143        endif
2144
2145         dxi=dc_norm(1,nres+i)
2146         dyi=dc_norm(2,nres+i)
2147         dzi=dc_norm(3,nres+i)
2148 c        dsci_inv=dsc_inv(itypi)
2149         dsci_inv=vbld_inv(i+nres)
2150 C
2151 C Calculate SC interaction energy.
2152 C
2153         do iint=1,nint_gr(i)
2154           do j=istart(i,iint),iend(i,iint)
2155             ind=ind+1
2156             itypj=iabs(itype(j))
2157             if (itypj.eq.ntyp1) cycle
2158 c            dscj_inv=dsc_inv(itypj)
2159             dscj_inv=vbld_inv(j+nres)
2160             sig0ij=sigma(itypi,itypj)
2161             r0ij=r0(itypi,itypj)
2162             chi1=chi(itypi,itypj)
2163             chi2=chi(itypj,itypi)
2164             chi12=chi1*chi2
2165             chip1=chip(itypi)
2166             chip2=chip(itypj)
2167             chip12=chip1*chip2
2168             alf1=alp(itypi)
2169             alf2=alp(itypj)
2170             alf12=0.5D0*(alf1+alf2)
2171 C For diagnostics only!!!
2172 c           chi1=0.0D0
2173 c           chi2=0.0D0
2174 c           chi12=0.0D0
2175 c           chip1=0.0D0
2176 c           chip2=0.0D0
2177 c           chip12=0.0D0
2178 c           alf1=0.0D0
2179 c           alf2=0.0D0
2180 c           alf12=0.0D0
2181 C            xj=c(1,nres+j)-xi
2182 C            yj=c(2,nres+j)-yi
2183 C            zj=c(3,nres+j)-zi
2184           xj=mod(xj,boxxsize)
2185           if (xj.lt.0) xj=xj+boxxsize
2186           yj=mod(yj,boxysize)
2187           if (yj.lt.0) yj=yj+boxysize
2188           zj=mod(zj,boxzsize)
2189           if (zj.lt.0) zj=zj+boxzsize
2190        if ((zj.gt.bordlipbot)
2191      &.and.(zj.lt.bordliptop)) then
2192 C the energy transfer exist
2193         if (zj.lt.buflipbot) then
2194 C what fraction I am in
2195          fracinbuf=1.0d0-
2196      &        ((zj-bordlipbot)/lipbufthick)
2197 C lipbufthick is thickenes of lipid buffore
2198          sslipj=sscalelip(fracinbuf)
2199          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2200         elseif (zj.gt.bufliptop) then
2201          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2202          sslipj=sscalelip(fracinbuf)
2203          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2204         else
2205          sslipj=1.0d0
2206          ssgradlipj=0.0
2207         endif
2208        else
2209          sslipj=0.0d0
2210          ssgradlipj=0.0
2211        endif
2212       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2213      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2214       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2215      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2216 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2217 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2218 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2219       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2220       xj_safe=xj
2221       yj_safe=yj
2222       zj_safe=zj
2223       subchap=0
2224       do xshift=-1,1
2225       do yshift=-1,1
2226       do zshift=-1,1
2227           xj=xj_safe+xshift*boxxsize
2228           yj=yj_safe+yshift*boxysize
2229           zj=zj_safe+zshift*boxzsize
2230           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2231           if(dist_temp.lt.dist_init) then
2232             dist_init=dist_temp
2233             xj_temp=xj
2234             yj_temp=yj
2235             zj_temp=zj
2236             subchap=1
2237           endif
2238        enddo
2239        enddo
2240        enddo
2241        if (subchap.eq.1) then
2242           xj=xj_temp-xi
2243           yj=yj_temp-yi
2244           zj=zj_temp-zi
2245        else
2246           xj=xj_safe-xi
2247           yj=yj_safe-yi
2248           zj=zj_safe-zi
2249        endif
2250             dxj=dc_norm(1,nres+j)
2251             dyj=dc_norm(2,nres+j)
2252             dzj=dc_norm(3,nres+j)
2253             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2254             rij=dsqrt(rrij)
2255 C Calculate angle-dependent terms of energy and contributions to their
2256 C derivatives.
2257             call sc_angular
2258             sigsq=1.0D0/sigsq
2259             sig=sig0ij*dsqrt(sigsq)
2260             rij_shift=1.0D0/rij-sig+r0ij
2261 C I hate to put IF's in the loops, but here don't have another choice!!!!
2262             if (rij_shift.le.0.0D0) then
2263               evdw=1.0D20
2264               return
2265             endif
2266             sigder=-sig*sigsq
2267 c---------------------------------------------------------------
2268             rij_shift=1.0D0/rij_shift
2269             fac=rij_shift**expon
2270             e1=fac*fac*aa
2271             e2=fac*bb
2272             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2273             eps2der=evdwij*eps3rt
2274             eps3der=evdwij*eps2rt
2275             fac_augm=rrij**expon
2276             e_augm=augm(itypi,itypj)*fac_augm
2277             evdwij=evdwij*eps2rt*eps3rt
2278             evdw=evdw+evdwij+e_augm
2279             if (lprn) then
2280             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2281             epsi=bb**2/aa
2282             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2283      &        restyp(itypi),i,restyp(itypj),j,
2284      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2285      &        chi1,chi2,chip1,chip2,
2286      &        eps1,eps2rt**2,eps3rt**2,
2287      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2288      &        evdwij+e_augm
2289             endif
2290 C Calculate gradient components.
2291             e1=e1*eps1*eps2rt**2*eps3rt**2
2292             fac=-expon*(e1+evdwij)*rij_shift
2293             sigder=fac*sigder
2294             fac=rij*fac-2*expon*rrij*e_augm
2295             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2296 C Calculate the radial part of the gradient
2297             gg(1)=xj*fac
2298             gg(2)=yj*fac
2299             gg(3)=zj*fac
2300 C Calculate angular part of the gradient.
2301             call sc_grad
2302           enddo      ! j
2303         enddo        ! iint
2304       enddo          ! i
2305       end
2306 C-----------------------------------------------------------------------------
2307       subroutine sc_angular
2308 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2309 C om12. Called by ebp, egb, and egbv.
2310       implicit none
2311       include 'COMMON.CALC'
2312       include 'COMMON.IOUNITS'
2313       erij(1)=xj*rij
2314       erij(2)=yj*rij
2315       erij(3)=zj*rij
2316       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2317       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2318       om12=dxi*dxj+dyi*dyj+dzi*dzj
2319       chiom12=chi12*om12
2320 C Calculate eps1(om12) and its derivative in om12
2321       faceps1=1.0D0-om12*chiom12
2322       faceps1_inv=1.0D0/faceps1
2323       eps1=dsqrt(faceps1_inv)
2324 C Following variable is eps1*deps1/dom12
2325       eps1_om12=faceps1_inv*chiom12
2326 c diagnostics only
2327 c      faceps1_inv=om12
2328 c      eps1=om12
2329 c      eps1_om12=1.0d0
2330 c      write (iout,*) "om12",om12," eps1",eps1
2331 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2332 C and om12.
2333       om1om2=om1*om2
2334       chiom1=chi1*om1
2335       chiom2=chi2*om2
2336       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2337       sigsq=1.0D0-facsig*faceps1_inv
2338       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2339       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2340       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2341 c diagnostics only
2342 c      sigsq=1.0d0
2343 c      sigsq_om1=0.0d0
2344 c      sigsq_om2=0.0d0
2345 c      sigsq_om12=0.0d0
2346 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2347 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2348 c     &    " eps1",eps1
2349 C Calculate eps2 and its derivatives in om1, om2, and om12.
2350       chipom1=chip1*om1
2351       chipom2=chip2*om2
2352       chipom12=chip12*om12
2353       facp=1.0D0-om12*chipom12
2354       facp_inv=1.0D0/facp
2355       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2356 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2357 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2358 C Following variable is the square root of eps2
2359       eps2rt=1.0D0-facp1*facp_inv
2360 C Following three variables are the derivatives of the square root of eps
2361 C in om1, om2, and om12.
2362       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2363       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2364       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2365 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2366       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2367 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2368 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2369 c     &  " eps2rt_om12",eps2rt_om12
2370 C Calculate whole angle-dependent part of epsilon and contributions
2371 C to its derivatives
2372       return
2373       end
2374 C----------------------------------------------------------------------------
2375       subroutine sc_grad
2376       implicit real*8 (a-h,o-z)
2377       include 'DIMENSIONS'
2378       include 'COMMON.CHAIN'
2379       include 'COMMON.DERIV'
2380       include 'COMMON.CALC'
2381       include 'COMMON.IOUNITS'
2382       double precision dcosom1(3),dcosom2(3)
2383 cc      print *,'sss=',sss
2384       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2385       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2386       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2387      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2388 c diagnostics only
2389 c      eom1=0.0d0
2390 c      eom2=0.0d0
2391 c      eom12=evdwij*eps1_om12
2392 c end diagnostics
2393 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2394 c     &  " sigder",sigder
2395 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2396 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2397       do k=1,3
2398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2400       enddo
2401       do k=1,3
2402         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2403       enddo
2404 c      write (iout,*) "gg",(gg(k),k=1,3)
2405       do k=1,3
2406         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2407      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2409         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2410      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2411      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2412 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2413 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2414 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2415 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2416       enddo
2417 C
2418 C Calculate the components of the gradient in DC and X
2419 C
2420 cgrad      do k=i,j-1
2421 cgrad        do l=1,3
2422 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2423 cgrad        enddo
2424 cgrad      enddo
2425       do l=1,3
2426         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2427         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2428       enddo
2429       return
2430       end
2431 C-----------------------------------------------------------------------
2432       subroutine e_softsphere(evdw)
2433 C
2434 C This subroutine calculates the interaction energy of nonbonded side chains
2435 C assuming the LJ potential of interaction.
2436 C
2437       implicit real*8 (a-h,o-z)
2438       include 'DIMENSIONS'
2439       parameter (accur=1.0d-10)
2440       include 'COMMON.GEO'
2441       include 'COMMON.VAR'
2442       include 'COMMON.LOCAL'
2443       include 'COMMON.CHAIN'
2444       include 'COMMON.DERIV'
2445       include 'COMMON.INTERACT'
2446       include 'COMMON.TORSION'
2447       include 'COMMON.SBRIDGE'
2448       include 'COMMON.NAMES'
2449       include 'COMMON.IOUNITS'
2450       include 'COMMON.CONTACTS'
2451       dimension gg(3)
2452 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2453       evdw=0.0D0
2454       do i=iatsc_s,iatsc_e
2455         itypi=iabs(itype(i))
2456         if (itypi.eq.ntyp1) cycle
2457         itypi1=iabs(itype(i+1))
2458         xi=c(1,nres+i)
2459         yi=c(2,nres+i)
2460         zi=c(3,nres+i)
2461 C
2462 C Calculate SC interaction energy.
2463 C
2464         do iint=1,nint_gr(i)
2465 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd   &                  'iend=',iend(i,iint)
2467           do j=istart(i,iint),iend(i,iint)
2468             itypj=iabs(itype(j))
2469             if (itypj.eq.ntyp1) cycle
2470             xj=c(1,nres+j)-xi
2471             yj=c(2,nres+j)-yi
2472             zj=c(3,nres+j)-zi
2473             rij=xj*xj+yj*yj+zj*zj
2474 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475             r0ij=r0(itypi,itypj)
2476             r0ijsq=r0ij*r0ij
2477 c            print *,i,j,r0ij,dsqrt(rij)
2478             if (rij.lt.r0ijsq) then
2479               evdwij=0.25d0*(rij-r0ijsq)**2
2480               fac=rij-r0ijsq
2481             else
2482               evdwij=0.0d0
2483               fac=0.0d0
2484             endif
2485             evdw=evdw+evdwij
2486 C
2487 C Calculate the components of the gradient in DC and X
2488 C
2489             gg(1)=xj*fac
2490             gg(2)=yj*fac
2491             gg(3)=zj*fac
2492             do k=1,3
2493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2497             enddo
2498 cgrad            do k=i,j-1
2499 cgrad              do l=1,3
2500 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2501 cgrad              enddo
2502 cgrad            enddo
2503           enddo ! j
2504         enddo ! iint
2505       enddo ! i
2506       return
2507       end
2508 C--------------------------------------------------------------------------
2509       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2510      &              eello_turn4)
2511 C
2512 C Soft-sphere potential of p-p interaction
2513 C
2514       implicit real*8 (a-h,o-z)
2515       include 'DIMENSIONS'
2516       include 'COMMON.CONTROL'
2517       include 'COMMON.IOUNITS'
2518       include 'COMMON.GEO'
2519       include 'COMMON.VAR'
2520       include 'COMMON.LOCAL'
2521       include 'COMMON.CHAIN'
2522       include 'COMMON.DERIV'
2523       include 'COMMON.INTERACT'
2524       include 'COMMON.CONTACTS'
2525       include 'COMMON.TORSION'
2526       include 'COMMON.VECTORS'
2527       include 'COMMON.FFIELD'
2528       dimension ggg(3)
2529 C      write(iout,*) 'In EELEC_soft_sphere'
2530       ees=0.0D0
2531       evdw1=0.0D0
2532       eel_loc=0.0d0
2533       eello_turn3=0.0d0
2534       eello_turn4=0.0d0
2535       ind=0
2536       do i=iatel_s,iatel_e
2537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2538         dxi=dc(1,i)
2539         dyi=dc(2,i)
2540         dzi=dc(3,i)
2541         xmedi=c(1,i)+0.5d0*dxi
2542         ymedi=c(2,i)+0.5d0*dyi
2543         zmedi=c(3,i)+0.5d0*dzi
2544           xmedi=mod(xmedi,boxxsize)
2545           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2546           ymedi=mod(ymedi,boxysize)
2547           if (ymedi.lt.0) ymedi=ymedi+boxysize
2548           zmedi=mod(zmedi,boxzsize)
2549           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2550         num_conti=0
2551 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2552         do j=ielstart(i),ielend(i)
2553           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2554           ind=ind+1
2555           iteli=itel(i)
2556           itelj=itel(j)
2557           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2558           r0ij=rpp(iteli,itelj)
2559           r0ijsq=r0ij*r0ij
2560           dxj=dc(1,j)
2561           dyj=dc(2,j)
2562           dzj=dc(3,j)
2563           xj=c(1,j)+0.5D0*dxj
2564           yj=c(2,j)+0.5D0*dyj
2565           zj=c(3,j)+0.5D0*dzj
2566           xj=mod(xj,boxxsize)
2567           if (xj.lt.0) xj=xj+boxxsize
2568           yj=mod(yj,boxysize)
2569           if (yj.lt.0) yj=yj+boxysize
2570           zj=mod(zj,boxzsize)
2571           if (zj.lt.0) zj=zj+boxzsize
2572       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2573       xj_safe=xj
2574       yj_safe=yj
2575       zj_safe=zj
2576       isubchap=0
2577       do xshift=-1,1
2578       do yshift=-1,1
2579       do zshift=-1,1
2580           xj=xj_safe+xshift*boxxsize
2581           yj=yj_safe+yshift*boxysize
2582           zj=zj_safe+zshift*boxzsize
2583           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2584           if(dist_temp.lt.dist_init) then
2585             dist_init=dist_temp
2586             xj_temp=xj
2587             yj_temp=yj
2588             zj_temp=zj
2589             isubchap=1
2590           endif
2591        enddo
2592        enddo
2593        enddo
2594        if (isubchap.eq.1) then
2595           xj=xj_temp-xmedi
2596           yj=yj_temp-ymedi
2597           zj=zj_temp-zmedi
2598        else
2599           xj=xj_safe-xmedi
2600           yj=yj_safe-ymedi
2601           zj=zj_safe-zmedi
2602        endif
2603           rij=xj*xj+yj*yj+zj*zj
2604             sss=sscale(sqrt(rij))
2605             sssgrad=sscagrad(sqrt(rij))
2606           if (rij.lt.r0ijsq) then
2607             evdw1ij=0.25d0*(rij-r0ijsq)**2
2608             fac=rij-r0ijsq
2609           else
2610             evdw1ij=0.0d0
2611             fac=0.0d0
2612           endif
2613           evdw1=evdw1+evdw1ij*sss
2614 C
2615 C Calculate contributions to the Cartesian gradient.
2616 C
2617           ggg(1)=fac*xj*sssgrad
2618           ggg(2)=fac*yj*sssgrad
2619           ggg(3)=fac*zj*sssgrad
2620           do k=1,3
2621             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2622             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2623           enddo
2624 *
2625 * Loop over residues i+1 thru j-1.
2626 *
2627 cgrad          do k=i+1,j-1
2628 cgrad            do l=1,3
2629 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2630 cgrad            enddo
2631 cgrad          enddo
2632         enddo ! j
2633       enddo   ! i
2634 cgrad      do i=nnt,nct-1
2635 cgrad        do k=1,3
2636 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2637 cgrad        enddo
2638 cgrad        do j=i+1,nct-1
2639 cgrad          do k=1,3
2640 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2641 cgrad          enddo
2642 cgrad        enddo
2643 cgrad      enddo
2644       return
2645       end
2646 c------------------------------------------------------------------------------
2647       subroutine vec_and_deriv
2648       implicit real*8 (a-h,o-z)
2649       include 'DIMENSIONS'
2650 #ifdef MPI
2651       include 'mpif.h'
2652 #endif
2653       include 'COMMON.IOUNITS'
2654       include 'COMMON.GEO'
2655       include 'COMMON.VAR'
2656       include 'COMMON.LOCAL'
2657       include 'COMMON.CHAIN'
2658       include 'COMMON.VECTORS'
2659       include 'COMMON.SETUP'
2660       include 'COMMON.TIME1'
2661       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2662 C Compute the local reference systems. For reference system (i), the
2663 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2664 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2665 #ifdef PARVEC
2666       do i=ivec_start,ivec_end
2667 #else
2668       do i=1,nres-1
2669 #endif
2670           if (i.eq.nres-1) then
2671 C Case of the last full residue
2672 C Compute the Z-axis
2673             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2674             costh=dcos(pi-theta(nres))
2675             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2676             do k=1,3
2677               uz(k,i)=fac*uz(k,i)
2678             enddo
2679 C Compute the derivatives of uz
2680             uzder(1,1,1)= 0.0d0
2681             uzder(2,1,1)=-dc_norm(3,i-1)
2682             uzder(3,1,1)= dc_norm(2,i-1)
2683             uzder(1,2,1)= dc_norm(3,i-1)
2684             uzder(2,2,1)= 0.0d0
2685             uzder(3,2,1)=-dc_norm(1,i-1)
2686             uzder(1,3,1)=-dc_norm(2,i-1)
2687             uzder(2,3,1)= dc_norm(1,i-1)
2688             uzder(3,3,1)= 0.0d0
2689             uzder(1,1,2)= 0.0d0
2690             uzder(2,1,2)= dc_norm(3,i)
2691             uzder(3,1,2)=-dc_norm(2,i)
2692             uzder(1,2,2)=-dc_norm(3,i)
2693             uzder(2,2,2)= 0.0d0
2694             uzder(3,2,2)= dc_norm(1,i)
2695             uzder(1,3,2)= dc_norm(2,i)
2696             uzder(2,3,2)=-dc_norm(1,i)
2697             uzder(3,3,2)= 0.0d0
2698 C Compute the Y-axis
2699             facy=fac
2700             do k=1,3
2701               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2702             enddo
2703 C Compute the derivatives of uy
2704             do j=1,3
2705               do k=1,3
2706                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2707      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2708                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2709               enddo
2710               uyder(j,j,1)=uyder(j,j,1)-costh
2711               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2712             enddo
2713             do j=1,2
2714               do k=1,3
2715                 do l=1,3
2716                   uygrad(l,k,j,i)=uyder(l,k,j)
2717                   uzgrad(l,k,j,i)=uzder(l,k,j)
2718                 enddo
2719               enddo
2720             enddo
2721             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2722             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2723             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2724             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2725           else
2726 C Other residues
2727 C Compute the Z-axis
2728             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2729             costh=dcos(pi-theta(i+2))
2730             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2731             do k=1,3
2732               uz(k,i)=fac*uz(k,i)
2733             enddo
2734 C Compute the derivatives of uz
2735             uzder(1,1,1)= 0.0d0
2736             uzder(2,1,1)=-dc_norm(3,i+1)
2737             uzder(3,1,1)= dc_norm(2,i+1)
2738             uzder(1,2,1)= dc_norm(3,i+1)
2739             uzder(2,2,1)= 0.0d0
2740             uzder(3,2,1)=-dc_norm(1,i+1)
2741             uzder(1,3,1)=-dc_norm(2,i+1)
2742             uzder(2,3,1)= dc_norm(1,i+1)
2743             uzder(3,3,1)= 0.0d0
2744             uzder(1,1,2)= 0.0d0
2745             uzder(2,1,2)= dc_norm(3,i)
2746             uzder(3,1,2)=-dc_norm(2,i)
2747             uzder(1,2,2)=-dc_norm(3,i)
2748             uzder(2,2,2)= 0.0d0
2749             uzder(3,2,2)= dc_norm(1,i)
2750             uzder(1,3,2)= dc_norm(2,i)
2751             uzder(2,3,2)=-dc_norm(1,i)
2752             uzder(3,3,2)= 0.0d0
2753 C Compute the Y-axis
2754             facy=fac
2755             do k=1,3
2756               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2757             enddo
2758 C Compute the derivatives of uy
2759             do j=1,3
2760               do k=1,3
2761                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2762      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2763                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2764               enddo
2765               uyder(j,j,1)=uyder(j,j,1)-costh
2766               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2767             enddo
2768             do j=1,2
2769               do k=1,3
2770                 do l=1,3
2771                   uygrad(l,k,j,i)=uyder(l,k,j)
2772                   uzgrad(l,k,j,i)=uzder(l,k,j)
2773                 enddo
2774               enddo
2775             enddo
2776             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2777             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2778             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2779             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2780           endif
2781       enddo
2782       do i=1,nres-1
2783         vbld_inv_temp(1)=vbld_inv(i+1)
2784         if (i.lt.nres-1) then
2785           vbld_inv_temp(2)=vbld_inv(i+2)
2786           else
2787           vbld_inv_temp(2)=vbld_inv(i)
2788           endif
2789         do j=1,2
2790           do k=1,3
2791             do l=1,3
2792               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2793               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2794             enddo
2795           enddo
2796         enddo
2797       enddo
2798 #if defined(PARVEC) && defined(MPI)
2799       if (nfgtasks1.gt.1) then
2800         time00=MPI_Wtime()
2801 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2802 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2803 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2804         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2811      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2812      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2813         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2814      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2815      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2816         time_gather=time_gather+MPI_Wtime()-time00
2817       endif
2818 c      if (fg_rank.eq.0) then
2819 c        write (iout,*) "Arrays UY and UZ"
2820 c        do i=1,nres-1
2821 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2822 c     &     (uz(k,i),k=1,3)
2823 c        enddo
2824 c      endif
2825 #endif
2826       return
2827       end
2828 C-----------------------------------------------------------------------------
2829       subroutine check_vecgrad
2830       implicit real*8 (a-h,o-z)
2831       include 'DIMENSIONS'
2832       include 'COMMON.IOUNITS'
2833       include 'COMMON.GEO'
2834       include 'COMMON.VAR'
2835       include 'COMMON.LOCAL'
2836       include 'COMMON.CHAIN'
2837       include 'COMMON.VECTORS'
2838       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2839       dimension uyt(3,maxres),uzt(3,maxres)
2840       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2841       double precision delta /1.0d-7/
2842       call vec_and_deriv
2843 cd      do i=1,nres
2844 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2845 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2846 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2847 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2848 cd     &     (dc_norm(if90,i),if90=1,3)
2849 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2850 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2851 cd          write(iout,'(a)')
2852 cd      enddo
2853       do i=1,nres
2854         do j=1,2
2855           do k=1,3
2856             do l=1,3
2857               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2858               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2859             enddo
2860           enddo
2861         enddo
2862       enddo
2863       call vec_and_deriv
2864       do i=1,nres
2865         do j=1,3
2866           uyt(j,i)=uy(j,i)
2867           uzt(j,i)=uz(j,i)
2868         enddo
2869       enddo
2870       do i=1,nres
2871 cd        write (iout,*) 'i=',i
2872         do k=1,3
2873           erij(k)=dc_norm(k,i)
2874         enddo
2875         do j=1,3
2876           do k=1,3
2877             dc_norm(k,i)=erij(k)
2878           enddo
2879           dc_norm(j,i)=dc_norm(j,i)+delta
2880 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2881 c          do k=1,3
2882 c            dc_norm(k,i)=dc_norm(k,i)/fac
2883 c          enddo
2884 c          write (iout,*) (dc_norm(k,i),k=1,3)
2885 c          write (iout,*) (erij(k),k=1,3)
2886           call vec_and_deriv
2887           do k=1,3
2888             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2889             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2890             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2891             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2892           enddo
2893 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2894 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2895 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2896         enddo
2897         do k=1,3
2898           dc_norm(k,i)=erij(k)
2899         enddo
2900 cd        do k=1,3
2901 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2902 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2903 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2904 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2905 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2906 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2907 cd          write (iout,'(a)')
2908 cd        enddo
2909       enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine set_matrices
2914       implicit real*8 (a-h,o-z)
2915       include 'DIMENSIONS'
2916 #ifdef MPI
2917       include "mpif.h"
2918       include "COMMON.SETUP"
2919       integer IERR
2920       integer status(MPI_STATUS_SIZE)
2921 #endif
2922       include 'COMMON.IOUNITS'
2923       include 'COMMON.GEO'
2924       include 'COMMON.VAR'
2925       include 'COMMON.LOCAL'
2926       include 'COMMON.CHAIN'
2927       include 'COMMON.DERIV'
2928       include 'COMMON.INTERACT'
2929       include 'COMMON.CONTACTS'
2930       include 'COMMON.TORSION'
2931       include 'COMMON.VECTORS'
2932       include 'COMMON.FFIELD'
2933       double precision auxvec(2),auxmat(2,2)
2934 C
2935 C Compute the virtual-bond-torsional-angle dependent quantities needed
2936 C to calculate the el-loc multibody terms of various order.
2937 C
2938 c      write(iout,*) 'nphi=',nphi,nres
2939 #ifdef PARMAT
2940       do i=ivec_start+2,ivec_end+2
2941 #else
2942       do i=3,nres+1
2943 #endif
2944 #ifdef NEWCORR
2945         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2946           iti = itype2loc(itype(i-2))
2947         else
2948           iti=nloctyp
2949         endif
2950 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2951         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2952           iti1 = itype2loc(itype(i-1))
2953         else
2954           iti1=nloctyp
2955         endif
2956 c        write(iout,*),i
2957         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2958      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2959      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2960         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2961      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2962      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2963 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2964 c     &*(cos(theta(i)/2.0)
2965         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2966      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2967      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2968 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2969 c     &*(cos(theta(i)/2.0)
2970         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2971      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2972      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2973 c        if (ggb1(1,i).eq.0.0d0) then
2974 c        write(iout,*) 'i=',i,ggb1(1,i),
2975 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2976 c     &bnew1(2,1,iti)*cos(theta(i)),
2977 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2978 c        endif
2979         b1(2,i-2)=bnew1(1,2,iti)
2980         gtb1(2,i-2)=0.0
2981         b2(2,i-2)=bnew2(1,2,iti)
2982         gtb2(2,i-2)=0.0
2983         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2984         EE(1,2,i-2)=eeold(1,2,iti)
2985         EE(2,1,i-2)=eeold(2,1,iti)
2986         EE(2,2,i-2)=eeold(2,2,iti)
2987         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2988         gtEE(1,2,i-2)=0.0d0
2989         gtEE(2,2,i-2)=0.0d0
2990         gtEE(2,1,i-2)=0.0d0
2991 c        EE(2,2,iti)=0.0d0
2992 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2993 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2994 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2995 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2996        b1tilde(1,i-2)=b1(1,i-2)
2997        b1tilde(2,i-2)=-b1(2,i-2)
2998        b2tilde(1,i-2)=b2(1,i-2)
2999        b2tilde(2,i-2)=-b2(2,i-2)
3000 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001 c       write(iout,*)  'b1=',b1(1,i-2)
3002 c       write (iout,*) 'theta=', theta(i-1)
3003        enddo
3004 #else
3005         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3006           iti = itype2loc(itype(i-2))
3007         else
3008           iti=nloctyp
3009         endif
3010 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3011         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3012           iti1 = itype2loc(itype(i-1))
3013         else
3014           iti1=nloctyp
3015         endif
3016         b1(1,i-2)=b(3,iti)
3017         b1(2,i-2)=b(5,iti)
3018         b2(1,i-2)=b(2,iti)
3019         b2(2,i-2)=b(4,iti)
3020        b1tilde(1,i-2)=b1(1,i-2)
3021        b1tilde(2,i-2)=-b1(2,i-2)
3022        b2tilde(1,i-2)=b2(1,i-2)
3023        b2tilde(2,i-2)=-b2(2,i-2)
3024         EE(1,2,i-2)=eeold(1,2,iti)
3025         EE(2,1,i-2)=eeold(2,1,iti)
3026         EE(2,2,i-2)=eeold(2,2,iti)
3027         EE(1,1,i-2)=eeold(1,1,iti)
3028       enddo
3029 #endif
3030 #ifdef PARMAT
3031       do i=ivec_start+2,ivec_end+2
3032 #else
3033       do i=3,nres+1
3034 #endif
3035         if (i .lt. nres+1) then
3036           sin1=dsin(phi(i))
3037           cos1=dcos(phi(i))
3038           sintab(i-2)=sin1
3039           costab(i-2)=cos1
3040           obrot(1,i-2)=cos1
3041           obrot(2,i-2)=sin1
3042           sin2=dsin(2*phi(i))
3043           cos2=dcos(2*phi(i))
3044           sintab2(i-2)=sin2
3045           costab2(i-2)=cos2
3046           obrot2(1,i-2)=cos2
3047           obrot2(2,i-2)=sin2
3048           Ug(1,1,i-2)=-cos1
3049           Ug(1,2,i-2)=-sin1
3050           Ug(2,1,i-2)=-sin1
3051           Ug(2,2,i-2)= cos1
3052           Ug2(1,1,i-2)=-cos2
3053           Ug2(1,2,i-2)=-sin2
3054           Ug2(2,1,i-2)=-sin2
3055           Ug2(2,2,i-2)= cos2
3056         else
3057           costab(i-2)=1.0d0
3058           sintab(i-2)=0.0d0
3059           obrot(1,i-2)=1.0d0
3060           obrot(2,i-2)=0.0d0
3061           obrot2(1,i-2)=0.0d0
3062           obrot2(2,i-2)=0.0d0
3063           Ug(1,1,i-2)=1.0d0
3064           Ug(1,2,i-2)=0.0d0
3065           Ug(2,1,i-2)=0.0d0
3066           Ug(2,2,i-2)=1.0d0
3067           Ug2(1,1,i-2)=0.0d0
3068           Ug2(1,2,i-2)=0.0d0
3069           Ug2(2,1,i-2)=0.0d0
3070           Ug2(2,2,i-2)=0.0d0
3071         endif
3072         if (i .gt. 3 .and. i .lt. nres+1) then
3073           obrot_der(1,i-2)=-sin1
3074           obrot_der(2,i-2)= cos1
3075           Ugder(1,1,i-2)= sin1
3076           Ugder(1,2,i-2)=-cos1
3077           Ugder(2,1,i-2)=-cos1
3078           Ugder(2,2,i-2)=-sin1
3079           dwacos2=cos2+cos2
3080           dwasin2=sin2+sin2
3081           obrot2_der(1,i-2)=-dwasin2
3082           obrot2_der(2,i-2)= dwacos2
3083           Ug2der(1,1,i-2)= dwasin2
3084           Ug2der(1,2,i-2)=-dwacos2
3085           Ug2der(2,1,i-2)=-dwacos2
3086           Ug2der(2,2,i-2)=-dwasin2
3087         else
3088           obrot_der(1,i-2)=0.0d0
3089           obrot_der(2,i-2)=0.0d0
3090           Ugder(1,1,i-2)=0.0d0
3091           Ugder(1,2,i-2)=0.0d0
3092           Ugder(2,1,i-2)=0.0d0
3093           Ugder(2,2,i-2)=0.0d0
3094           obrot2_der(1,i-2)=0.0d0
3095           obrot2_der(2,i-2)=0.0d0
3096           Ug2der(1,1,i-2)=0.0d0
3097           Ug2der(1,2,i-2)=0.0d0
3098           Ug2der(2,1,i-2)=0.0d0
3099           Ug2der(2,2,i-2)=0.0d0
3100         endif
3101 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3102         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103           iti = itype2loc(itype(i-2))
3104         else
3105           iti=nloctyp
3106         endif
3107 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3108         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3109           iti1 = itype2loc(itype(i-1))
3110         else
3111           iti1=nloctyp
3112         endif
3113 cd        write (iout,*) '*******i',i,' iti1',iti
3114 cd        write (iout,*) 'b1',b1(:,iti)
3115 cd        write (iout,*) 'b2',b2(:,iti)
3116 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3117 c        if (i .gt. iatel_s+2) then
3118         if (i .gt. nnt+2) then
3119           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3120 #ifdef NEWCORR
3121           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3122 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3123 #endif
3124 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3125 c     &    EE(1,2,iti),EE(2,2,i)
3126           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3127           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3128 c          write(iout,*) "Macierz EUG",
3129 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3130 c     &    eug(2,2,i-2)
3131           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3132      &    then
3133           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3134           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3135           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3136           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3137           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3138           endif
3139         else
3140           do k=1,2
3141             Ub2(k,i-2)=0.0d0
3142             Ctobr(k,i-2)=0.0d0
3143             Dtobr2(k,i-2)=0.0d0
3144             do l=1,2
3145               EUg(l,k,i-2)=0.0d0
3146               CUg(l,k,i-2)=0.0d0
3147               DUg(l,k,i-2)=0.0d0
3148               DtUg2(l,k,i-2)=0.0d0
3149             enddo
3150           enddo
3151         endif
3152         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3153         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3154         do k=1,2
3155           muder(k,i-2)=Ub2der(k,i-2)
3156         enddo
3157 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3158         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3159           if (itype(i-1).le.ntyp) then
3160             iti1 = itype2loc(itype(i-1))
3161           else
3162             iti1=nloctyp
3163           endif
3164         else
3165           iti1=nloctyp
3166         endif
3167         do k=1,2
3168           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3169         enddo
3170 #ifdef MUOUT
3171         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3172      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3173      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3174      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3175      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3176      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3177 #endif
3178 cd        write (iout,*) 'mu1',mu1(:,i-2)
3179 cd        write (iout,*) 'mu2',mu2(:,i-2)
3180         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3181      &  then
3182         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3183         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3184         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3185         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3186         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3187 C Vectors and matrices dependent on a single virtual-bond dihedral.
3188         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3189         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3190         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3191         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3192         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3193         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3194         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3195         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3196         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3197         endif
3198       enddo
3199 C Matrices dependent on two consecutive virtual-bond dihedrals.
3200 C The order of matrices is from left to right.
3201       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3202      &then
3203 c      do i=max0(ivec_start,2),ivec_end
3204       do i=2,nres-1
3205         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3206         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3207         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3208         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3209         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3210         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3211         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3212         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3213       enddo
3214       endif
3215 #if defined(MPI) && defined(PARMAT)
3216 #ifdef DEBUG
3217 c      if (fg_rank.eq.0) then
3218         write (iout,*) "Arrays UG and UGDER before GATHER"
3219         do i=1,nres-1
3220           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3221      &     ((ug(l,k,i),l=1,2),k=1,2),
3222      &     ((ugder(l,k,i),l=1,2),k=1,2)
3223         enddo
3224         write (iout,*) "Arrays UG2 and UG2DER"
3225         do i=1,nres-1
3226           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3227      &     ((ug2(l,k,i),l=1,2),k=1,2),
3228      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3229         enddo
3230         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3231         do i=1,nres-1
3232           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3233      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3234      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3235         enddo
3236         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3237         do i=1,nres-1
3238           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3239      &     costab(i),sintab(i),costab2(i),sintab2(i)
3240         enddo
3241         write (iout,*) "Array MUDER"
3242         do i=1,nres-1
3243           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3244         enddo
3245 c      endif
3246 #endif
3247       if (nfgtasks.gt.1) then
3248         time00=MPI_Wtime()
3249 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3250 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3251 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3252 #ifdef MATGATHER
3253         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3254      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3255      &   FG_COMM1,IERR)
3256         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3257      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3258      &   FG_COMM1,IERR)
3259         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3260      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3261      &   FG_COMM1,IERR)
3262         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3263      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3264      &   FG_COMM1,IERR)
3265         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3266      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3267      &   FG_COMM1,IERR)
3268         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3269      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3270      &   FG_COMM1,IERR)
3271         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3272      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3273      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3274         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3275      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3276      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3277         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3278      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3279      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3280         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3281      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3282      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3283         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3284      &  then
3285         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3292      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3293      &   FG_COMM1,IERR)
3294        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3295      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3296      &   FG_COMM1,IERR)
3297         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3298      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3299      &   FG_COMM1,IERR)
3300         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3301      &   ivec_count(fg_rank1),
3302      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3303      &   FG_COMM1,IERR)
3304         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3305      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3308      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3309      &   FG_COMM1,IERR)
3310         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3311      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3312      &   FG_COMM1,IERR)
3313         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3314      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3315      &   FG_COMM1,IERR)
3316         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3317      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3318      &   FG_COMM1,IERR)
3319         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3320      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3321      &   FG_COMM1,IERR)
3322         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3323      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3324      &   FG_COMM1,IERR)
3325         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3326      &   ivec_count(fg_rank1),
3327      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3331      &   FG_COMM1,IERR)
3332        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3337      &   FG_COMM1,IERR)
3338        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3342      &   ivec_count(fg_rank1),
3343      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3344      &   FG_COMM1,IERR)
3345         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3346      &   ivec_count(fg_rank1),
3347      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3348      &   FG_COMM1,IERR)
3349         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3350      &   ivec_count(fg_rank1),
3351      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3352      &   MPI_MAT2,FG_COMM1,IERR)
3353         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3354      &   ivec_count(fg_rank1),
3355      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3356      &   MPI_MAT2,FG_COMM1,IERR)
3357         endif
3358 #else
3359 c Passes matrix info through the ring
3360       isend=fg_rank1
3361       irecv=fg_rank1-1
3362       if (irecv.lt.0) irecv=nfgtasks1-1
3363       iprev=irecv
3364       inext=fg_rank1+1
3365       if (inext.ge.nfgtasks1) inext=0
3366       do i=1,nfgtasks1-1
3367 c        write (iout,*) "isend",isend," irecv",irecv
3368 c        call flush(iout)
3369         lensend=lentyp(isend)
3370         lenrecv=lentyp(irecv)
3371 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3372 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3373 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3374 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3375 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3376 c        write (iout,*) "Gather ROTAT1"
3377 c        call flush(iout)
3378 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3379 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3380 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3381 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3382 c        write (iout,*) "Gather ROTAT2"
3383 c        call flush(iout)
3384         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3385      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3386      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3387      &   iprev,4400+irecv,FG_COMM,status,IERR)
3388 c        write (iout,*) "Gather ROTAT_OLD"
3389 c        call flush(iout)
3390         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3391      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3392      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3393      &   iprev,5500+irecv,FG_COMM,status,IERR)
3394 c        write (iout,*) "Gather PRECOMP11"
3395 c        call flush(iout)
3396         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3397      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3398      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3399      &   iprev,6600+irecv,FG_COMM,status,IERR)
3400 c        write (iout,*) "Gather PRECOMP12"
3401 c        call flush(iout)
3402         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3403      &  then
3404         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3405      &   MPI_ROTAT2(lensend),inext,7700+isend,
3406      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3407      &   iprev,7700+irecv,FG_COMM,status,IERR)
3408 c        write (iout,*) "Gather PRECOMP21"
3409 c        call flush(iout)
3410         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3411      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3412      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3413      &   iprev,8800+irecv,FG_COMM,status,IERR)
3414 c        write (iout,*) "Gather PRECOMP22"
3415 c        call flush(iout)
3416         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3417      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3418      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3419      &   MPI_PRECOMP23(lenrecv),
3420      &   iprev,9900+irecv,FG_COMM,status,IERR)
3421 c        write (iout,*) "Gather PRECOMP23"
3422 c        call flush(iout)
3423         endif
3424         isend=irecv
3425         irecv=irecv-1
3426         if (irecv.lt.0) irecv=nfgtasks1-1
3427       enddo
3428 #endif
3429         time_gather=time_gather+MPI_Wtime()-time00
3430       endif
3431 #ifdef DEBUG
3432 c      if (fg_rank.eq.0) then
3433         write (iout,*) "Arrays UG and UGDER"
3434         do i=1,nres-1
3435           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3436      &     ((ug(l,k,i),l=1,2),k=1,2),
3437      &     ((ugder(l,k,i),l=1,2),k=1,2)
3438         enddo
3439         write (iout,*) "Arrays UG2 and UG2DER"
3440         do i=1,nres-1
3441           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3442      &     ((ug2(l,k,i),l=1,2),k=1,2),
3443      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3444         enddo
3445         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3446         do i=1,nres-1
3447           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3448      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3449      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3450         enddo
3451         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3452         do i=1,nres-1
3453           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3454      &     costab(i),sintab(i),costab2(i),sintab2(i)
3455         enddo
3456         write (iout,*) "Array MUDER"
3457         do i=1,nres-1
3458           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3459         enddo
3460 c      endif
3461 #endif
3462 #endif
3463 cd      do i=1,nres
3464 cd        iti = itype2loc(itype(i))
3465 cd        write (iout,*) i
3466 cd        do j=1,2
3467 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3468 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3469 cd        enddo
3470 cd      enddo
3471       return
3472       end
3473 C--------------------------------------------------------------------------
3474       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3475 C
3476 C This subroutine calculates the average interaction energy and its gradient
3477 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3478 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3479 C The potential depends both on the distance of peptide-group centers and on
3480 C the orientation of the CA-CA virtual bonds.
3481 C
3482       implicit real*8 (a-h,o-z)
3483 #ifdef MPI
3484       include 'mpif.h'
3485 #endif
3486       include 'DIMENSIONS'
3487       include 'COMMON.CONTROL'
3488       include 'COMMON.SETUP'
3489       include 'COMMON.IOUNITS'
3490       include 'COMMON.GEO'
3491       include 'COMMON.VAR'
3492       include 'COMMON.LOCAL'
3493       include 'COMMON.CHAIN'
3494       include 'COMMON.DERIV'
3495       include 'COMMON.INTERACT'
3496       include 'COMMON.CONTACTS'
3497       include 'COMMON.TORSION'
3498       include 'COMMON.VECTORS'
3499       include 'COMMON.FFIELD'
3500       include 'COMMON.TIME1'
3501       include 'COMMON.SPLITELE'
3502       include 'COMMON.SHIELD'
3503       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3504      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3505       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3506      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3507       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3508      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3509      &    num_conti,j1,j2
3510 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3511 #ifdef MOMENT
3512       double precision scal_el /1.0d0/
3513 #else
3514       double precision scal_el /0.5d0/
3515 #endif
3516 C 12/13/98
3517 C 13-go grudnia roku pamietnego...
3518       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3519      &                   0.0d0,1.0d0,0.0d0,
3520      &                   0.0d0,0.0d0,1.0d0/
3521 cd      write(iout,*) 'In EELEC'
3522 cd      do i=1,nloctyp
3523 cd        write(iout,*) 'Type',i
3524 cd        write(iout,*) 'B1',B1(:,i)
3525 cd        write(iout,*) 'B2',B2(:,i)
3526 cd        write(iout,*) 'CC',CC(:,:,i)
3527 cd        write(iout,*) 'DD',DD(:,:,i)
3528 cd        write(iout,*) 'EE',EE(:,:,i)
3529 cd      enddo
3530 cd      call check_vecgrad
3531 cd      stop
3532       if (icheckgrad.eq.1) then
3533         do i=1,nres-1
3534           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3535           do k=1,3
3536             dc_norm(k,i)=dc(k,i)*fac
3537           enddo
3538 c          write (iout,*) 'i',i,' fac',fac
3539         enddo
3540       endif
3541       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3542      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3543      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3544 c        call vec_and_deriv
3545 #ifdef TIMING
3546         time01=MPI_Wtime()
3547 #endif
3548         call set_matrices
3549 #ifdef TIMING
3550         time_mat=time_mat+MPI_Wtime()-time01
3551 #endif
3552       endif
3553 cd      do i=1,nres-1
3554 cd        write (iout,*) 'i=',i
3555 cd        do k=1,3
3556 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3557 cd        enddo
3558 cd        do k=1,3
3559 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3560 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3561 cd        enddo
3562 cd      enddo
3563       t_eelecij=0.0d0
3564       ees=0.0D0
3565       evdw1=0.0D0
3566       eel_loc=0.0d0
3567       eello_turn3=0.0d0
3568       eello_turn4=0.0d0
3569       ind=0
3570       do i=1,nres
3571         num_cont_hb(i)=0
3572       enddo
3573 cd      print '(a)','Enter EELEC'
3574 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3575       do i=1,nres
3576         gel_loc_loc(i)=0.0d0
3577         gcorr_loc(i)=0.0d0
3578       enddo
3579 c
3580 c
3581 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3582 C
3583 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3584 C
3585 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3586       do i=iturn3_start,iturn3_end
3587 c        if (i.le.1) cycle
3588 C        write(iout,*) "tu jest i",i
3589         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3590 C changes suggested by Ana to avoid out of bounds
3591 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3592 c     & .or.((i+4).gt.nres)
3593 c     & .or.((i-1).le.0)
3594 C end of changes by Ana
3595      &  .or. itype(i+2).eq.ntyp1
3596      &  .or. itype(i+3).eq.ntyp1) cycle
3597 C Adam: Instructions below will switch off existing interactions
3598 c        if(i.gt.1)then
3599 c          if(itype(i-1).eq.ntyp1)cycle
3600 c        end if
3601 c        if(i.LT.nres-3)then
3602 c          if (itype(i+4).eq.ntyp1) cycle
3603 c        end if
3604         dxi=dc(1,i)
3605         dyi=dc(2,i)
3606         dzi=dc(3,i)
3607         dx_normi=dc_norm(1,i)
3608         dy_normi=dc_norm(2,i)
3609         dz_normi=dc_norm(3,i)
3610         xmedi=c(1,i)+0.5d0*dxi
3611         ymedi=c(2,i)+0.5d0*dyi
3612         zmedi=c(3,i)+0.5d0*dzi
3613           xmedi=mod(xmedi,boxxsize)
3614           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3615           ymedi=mod(ymedi,boxysize)
3616           if (ymedi.lt.0) ymedi=ymedi+boxysize
3617           zmedi=mod(zmedi,boxzsize)
3618           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3619           zmedi2=mod(zmedi,boxzsize)
3620           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3621        if ((zmedi2.gt.bordlipbot)
3622      &.and.(zmedi2.lt.bordliptop)) then
3623 C the energy transfer exist
3624         if (zmedi2.lt.buflipbot) then
3625 C what fraction I am in
3626          fracinbuf=1.0d0-
3627      &        ((zmedi2-bordlipbot)/lipbufthick)
3628 C lipbufthick is thickenes of lipid buffore
3629          sslipi=sscalelip(fracinbuf)
3630          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3631         elseif (zmedi2.gt.bufliptop) then
3632          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3633          sslipi=sscalelip(fracinbuf)
3634          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3635         else
3636          sslipi=1.0d0
3637          ssgradlipi=0.0d0
3638         endif
3639        else
3640          sslipi=0.0d0
3641          ssgradlipi=0.0d0
3642        endif
3643         num_conti=0
3644         call eelecij(i,i+2,ees,evdw1,eel_loc)
3645         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3646         num_cont_hb(i)=num_conti
3647       enddo
3648       do i=iturn4_start,iturn4_end
3649         if (i.lt.1) cycle
3650         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 c     & .or.((i+5).gt.nres)
3653 c     & .or.((i-1).le.0)
3654 C end of changes suggested by Ana
3655      &    .or. itype(i+3).eq.ntyp1
3656      &    .or. itype(i+4).eq.ntyp1
3657 c     &    .or. itype(i+5).eq.ntyp1
3658 c     &    .or. itype(i).eq.ntyp1
3659 c     &    .or. itype(i-1).eq.ntyp1
3660      &                             ) cycle
3661         dxi=dc(1,i)
3662         dyi=dc(2,i)
3663         dzi=dc(3,i)
3664         dx_normi=dc_norm(1,i)
3665         dy_normi=dc_norm(2,i)
3666         dz_normi=dc_norm(3,i)
3667         xmedi=c(1,i)+0.5d0*dxi
3668         ymedi=c(2,i)+0.5d0*dyi
3669         zmedi=c(3,i)+0.5d0*dzi
3670 C Return atom into box, boxxsize is size of box in x dimension
3671 c  194   continue
3672 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3673 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3674 C Condition for being inside the proper box
3675 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3676 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3677 c        go to 194
3678 c        endif
3679 c  195   continue
3680 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3681 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3682 C Condition for being inside the proper box
3683 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3684 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3685 c        go to 195
3686 c        endif
3687 c  196   continue
3688 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3689 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3690 C Condition for being inside the proper box
3691 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3692 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3693 c        go to 196
3694 c        endif
3695           xmedi=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         do l=1,3
5129 c            ghalf1=0.5d0*agg(l,1)
5130 c            ghalf2=0.5d0*agg(l,2)
5131 c            ghalf3=0.5d0*agg(l,3)
5132 c            ghalf4=0.5d0*agg(l,4)
5133           a_temp(1,1)=aggi(l,1)!+ghalf1
5134           a_temp(1,2)=aggi(l,2)!+ghalf2
5135           a_temp(2,1)=aggi(l,3)!+ghalf3
5136           a_temp(2,2)=aggi(l,4)!+ghalf4
5137           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5138           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5139      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5140      &   *fac_shield(i)*fac_shield(j)
5141      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5142
5143           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5144           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5145           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5146           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5147           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5148           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5149      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5150      &   *fac_shield(i)*fac_shield(j)
5151      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5152           a_temp(1,1)=aggj(l,1)!+ghalf1
5153           a_temp(1,2)=aggj(l,2)!+ghalf2
5154           a_temp(2,1)=aggj(l,3)!+ghalf3
5155           a_temp(2,2)=aggj(l,4)!+ghalf4
5156           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5157           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5158      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5159      &   *fac_shield(i)*fac_shield(j)
5160      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5161
5162           a_temp(1,1)=aggj1(l,1)
5163           a_temp(1,2)=aggj1(l,2)
5164           a_temp(2,1)=aggj1(l,3)
5165           a_temp(2,2)=aggj1(l,4)
5166           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5167           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5168      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5169      &   *fac_shield(i)*fac_shield(j)
5170      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5171         enddo
5172          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5173      &     ssgradlipi*eello_t3/4.0d0*lipscale
5174          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5175      &     ssgradlipj*eello_t3/4.0d0*lipscale
5176          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5177      &     ssgradlipi*eello_t3/4.0d0*lipscale
5178          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5179      &     ssgradlipj*eello_t3/4.0d0*lipscale
5180
5181 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5182       return
5183       end
5184 C-------------------------------------------------------------------------------
5185       subroutine eturn4(i,eello_turn4)
5186 C Third- and fourth-order contributions from turns
5187       implicit real*8 (a-h,o-z)
5188       include 'DIMENSIONS'
5189       include 'COMMON.IOUNITS'
5190       include 'COMMON.GEO'
5191       include 'COMMON.VAR'
5192       include 'COMMON.LOCAL'
5193       include 'COMMON.CHAIN'
5194       include 'COMMON.DERIV'
5195       include 'COMMON.INTERACT'
5196       include 'COMMON.CONTACTS'
5197       include 'COMMON.TORSION'
5198       include 'COMMON.VECTORS'
5199       include 'COMMON.FFIELD'
5200       include 'COMMON.CONTROL'
5201       include 'COMMON.SHIELD'
5202       dimension ggg(3)
5203       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5204      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5205      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5206      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5207      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5208      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5209      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5210       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5211      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5212       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5213      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5214      &    num_conti,j1,j2
5215       j=i+3
5216 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5217 C
5218 C               Fourth-order contributions
5219 C
5220 C                 (i+3)o----(i+4)
5221 C                     /  |
5222 C               (i+2)o   |
5223 C                     \  |
5224 C                 (i+1)o----i
5225 C
5226 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5227 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5228 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5229 c        write(iout,*)"WCHODZE W PROGRAM"
5230           zj=(c(3,j)+c(3,j+1))/2.0d0
5231 C          xj=mod(xj,boxxsize)
5232 C          if (xj.lt.0) xj=xj+boxxsize
5233 C          yj=mod(yj,boxysize)
5234 C          if (yj.lt.0) yj=yj+boxysize
5235           zj=mod(zj,boxzsize)
5236           if (zj.lt.0) zj=zj+boxzsize
5237 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5238        if ((zj.gt.bordlipbot)
5239      &.and.(zj.lt.bordliptop)) then
5240 C the energy transfer exist
5241         if (zj.lt.buflipbot) then
5242 C what fraction I am in
5243          fracinbuf=1.0d0-
5244      &        ((zj-bordlipbot)/lipbufthick)
5245 C lipbufthick is thickenes of lipid buffore
5246          sslipj=sscalelip(fracinbuf)
5247          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5248         elseif (zj.gt.bufliptop) then
5249          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5250          sslipj=sscalelip(fracinbuf)
5251          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5252         else
5253          sslipj=1.0d0
5254          ssgradlipj=0.0
5255         endif
5256        else
5257          sslipj=0.0d0
5258          ssgradlipj=0.0
5259        endif
5260
5261         a_temp(1,1)=a22
5262         a_temp(1,2)=a23
5263         a_temp(2,1)=a32
5264         a_temp(2,2)=a33
5265         iti1=itype2loc(itype(i+1))
5266         iti2=itype2loc(itype(i+2))
5267         iti3=itype2loc(itype(i+3))
5268 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5269         call transpose2(EUg(1,1,i+1),e1t(1,1))
5270         call transpose2(Eug(1,1,i+2),e2t(1,1))
5271         call transpose2(Eug(1,1,i+3),e3t(1,1))
5272 C Ematrix derivative in theta
5273         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5274         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5275         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5276         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5277 c       eta1 in derivative theta
5278         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5279         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5280 c       auxgvec is derivative of Ub2 so i+3 theta
5281         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5282 c       auxalary matrix of E i+1
5283         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5284 c        s1=0.0
5285 c        gs1=0.0
5286         s1=scalar2(b1(1,i+2),auxvec(1))
5287 c derivative of theta i+2 with constant i+3
5288         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5289 c derivative of theta i+2 with constant i+2
5290         gs32=scalar2(b1(1,i+2),auxgvec(1))
5291 c derivative of E matix in theta of i+1
5292         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5293
5294         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5295 c       ea31 in derivative theta
5296         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5297         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5298 c auxilary matrix auxgvec of Ub2 with constant E matirx
5299         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5300 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5301         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5302
5303 c        s2=0.0
5304 c        gs2=0.0
5305         s2=scalar2(b1(1,i+1),auxvec(1))
5306 c derivative of theta i+1 with constant i+3
5307         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5308 c derivative of theta i+2 with constant i+1
5309         gs21=scalar2(b1(1,i+1),auxgvec(1))
5310 c derivative of theta i+3 with constant i+1
5311         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5312 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5313 c     &  gtb1(1,i+1)
5314         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5315 c two derivatives over diffetent matrices
5316 c gtae3e2 is derivative over i+3
5317         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5318 c ae3gte2 is derivative over i+2
5319         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5320         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5321 c three possible derivative over theta E matices
5322 c i+1
5323         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5324 c i+2
5325         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5326 c i+3
5327         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5328         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5329
5330         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5331         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5332         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5333         if (shield_mode.eq.0) then
5334         fac_shield(i)=1.0
5335         fac_shield(j)=1.0
5336 C        else
5337 C        fac_shield(i)=0.6
5338 C        fac_shield(j)=0.4
5339         endif
5340         eello_turn4=eello_turn4-(s1+s2+s3)
5341      &  *fac_shield(i)*fac_shield(j)
5342      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5343
5344         eello_t4=-(s1+s2+s3)
5345      &  *fac_shield(i)*fac_shield(j)
5346 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5347         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5348      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5349 C Now derivative over shield:
5350           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5351      &  (shield_mode.gt.0)) then
5352 C          print *,i,j
5353
5354           do ilist=1,ishield_list(i)
5355            iresshield=shield_list(ilist,i)
5356            do k=1,3
5357            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5358 C     &      *2.0
5359            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5360      &              rlocshield
5361      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5362             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5363      &      +rlocshield
5364            enddo
5365           enddo
5366           do ilist=1,ishield_list(j)
5367            iresshield=shield_list(ilist,j)
5368            do k=1,3
5369            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5370 C     &     *2.0
5371            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5372      &              rlocshield
5373      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5374            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5375      &             +rlocshield
5376
5377            enddo
5378           enddo
5379
5380           do k=1,3
5381             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5382      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5383             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5384      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5385             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5386      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5387             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5388      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5389            enddo
5390            endif
5391
5392
5393
5394
5395
5396
5397 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5398 cd     &    ' eello_turn4_num',8*eello_turn4_num
5399 #ifdef NEWCORR
5400         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5401      &                  -(gs13+gsE13+gsEE1)*wturn4
5402      &  *fac_shield(i)*fac_shield(j)
5403      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5404
5405         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5406      &                    -(gs23+gs21+gsEE2)*wturn4
5407      &  *fac_shield(i)*fac_shield(j)
5408      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5409
5410         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5411      &                    -(gs32+gsE31+gsEE3)*wturn4
5412      &  *fac_shield(i)*fac_shield(j)
5413      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5414
5415 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5416 c     &   gs2
5417 #endif
5418         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5419      &      'eturn4',i,j,-(s1+s2+s3)
5420 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5421 c     &    ' eello_turn4_num',8*eello_turn4_num
5422 C Derivatives in gamma(i)
5423         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5424         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5425         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5426         s1=scalar2(b1(1,i+2),auxvec(1))
5427         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5428         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5429         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5430      &  *fac_shield(i)*fac_shield(j)
5431      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5432
5433 C Derivatives in gamma(i+1)
5434         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5435         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5436         s2=scalar2(b1(1,i+1),auxvec(1))
5437         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5438         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5439         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5440         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5441      &  *fac_shield(i)*fac_shield(j)
5442      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5443
5444 C Derivatives in gamma(i+2)
5445         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5446         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5447         s1=scalar2(b1(1,i+2),auxvec(1))
5448         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5449         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5450         s2=scalar2(b1(1,i+1),auxvec(1))
5451         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5452         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5453         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5454         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5455      &  *fac_shield(i)*fac_shield(j)
5456      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5457
5458 C Cartesian derivatives
5459 C Derivatives of this turn contributions in DC(i+2)
5460         if (j.lt.nres-1) then
5461           do l=1,3
5462             a_temp(1,1)=agg(l,1)
5463             a_temp(1,2)=agg(l,2)
5464             a_temp(2,1)=agg(l,3)
5465             a_temp(2,2)=agg(l,4)
5466             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5467             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5468             s1=scalar2(b1(1,i+2),auxvec(1))
5469             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5470             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5471             s2=scalar2(b1(1,i+1),auxvec(1))
5472             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5473             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5474             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5475             ggg(l)=-(s1+s2+s3)
5476             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5477      &  *fac_shield(i)*fac_shield(j)
5478      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5479
5480           enddo
5481         endif
5482 C Remaining derivatives of this turn contribution
5483         do l=1,3
5484           a_temp(1,1)=aggi(l,1)
5485           a_temp(1,2)=aggi(l,2)
5486           a_temp(2,1)=aggi(l,3)
5487           a_temp(2,2)=aggi(l,4)
5488           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5489           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5490           s1=scalar2(b1(1,i+2),auxvec(1))
5491           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5492           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5493           s2=scalar2(b1(1,i+1),auxvec(1))
5494           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5495           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5496           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5497           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5498      &  *fac_shield(i)*fac_shield(j)
5499      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5500
5501           a_temp(1,1)=aggi1(l,1)
5502           a_temp(1,2)=aggi1(l,2)
5503           a_temp(2,1)=aggi1(l,3)
5504           a_temp(2,2)=aggi1(l,4)
5505           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5506           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5507           s1=scalar2(b1(1,i+2),auxvec(1))
5508           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5509           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5510           s2=scalar2(b1(1,i+1),auxvec(1))
5511           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5512           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5513           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5514           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5515      &  *fac_shield(i)*fac_shield(j)
5516      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5517
5518           a_temp(1,1)=aggj(l,1)
5519           a_temp(1,2)=aggj(l,2)
5520           a_temp(2,1)=aggj(l,3)
5521           a_temp(2,2)=aggj(l,4)
5522           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5523           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5524           s1=scalar2(b1(1,i+2),auxvec(1))
5525           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5526           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5527           s2=scalar2(b1(1,i+1),auxvec(1))
5528           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5529           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5530           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5531           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5532      &  *fac_shield(i)*fac_shield(j)
5533      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5534
5535           a_temp(1,1)=aggj1(l,1)
5536           a_temp(1,2)=aggj1(l,2)
5537           a_temp(2,1)=aggj1(l,3)
5538           a_temp(2,2)=aggj1(l,4)
5539           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5540           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5541           s1=scalar2(b1(1,i+2),auxvec(1))
5542           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5543           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5544           s2=scalar2(b1(1,i+1),auxvec(1))
5545           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5546           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5547           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5548 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5549           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5550      &  *fac_shield(i)*fac_shield(j)
5551      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5552         enddo
5553          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5554      &     ssgradlipi*eello_t4/4.0d0*lipscale
5555          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5556      &     ssgradlipj*eello_t4/4.0d0*lipscale
5557          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5558      &     ssgradlipi*eello_t4/4.0d0*lipscale
5559          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5560      &     ssgradlipj*eello_t4/4.0d0*lipscale
5561       return
5562       end
5563 C-----------------------------------------------------------------------------
5564       subroutine vecpr(u,v,w)
5565       implicit real*8(a-h,o-z)
5566       dimension u(3),v(3),w(3)
5567       w(1)=u(2)*v(3)-u(3)*v(2)
5568       w(2)=-u(1)*v(3)+u(3)*v(1)
5569       w(3)=u(1)*v(2)-u(2)*v(1)
5570       return
5571       end
5572 C-----------------------------------------------------------------------------
5573       subroutine unormderiv(u,ugrad,unorm,ungrad)
5574 C This subroutine computes the derivatives of a normalized vector u, given
5575 C the derivatives computed without normalization conditions, ugrad. Returns
5576 C ungrad.
5577       implicit none
5578       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5579       double precision vec(3)
5580       double precision scalar
5581       integer i,j
5582 c      write (2,*) 'ugrad',ugrad
5583 c      write (2,*) 'u',u
5584       do i=1,3
5585         vec(i)=scalar(ugrad(1,i),u(1))
5586       enddo
5587 c      write (2,*) 'vec',vec
5588       do i=1,3
5589         do j=1,3
5590           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5591         enddo
5592       enddo
5593 c      write (2,*) 'ungrad',ungrad
5594       return
5595       end
5596 C-----------------------------------------------------------------------------
5597       subroutine escp_soft_sphere(evdw2,evdw2_14)
5598 C
5599 C This subroutine calculates the excluded-volume interaction energy between
5600 C peptide-group centers and side chains and its gradient in virtual-bond and
5601 C side-chain vectors.
5602 C
5603       implicit real*8 (a-h,o-z)
5604       include 'DIMENSIONS'
5605       include 'COMMON.GEO'
5606       include 'COMMON.VAR'
5607       include 'COMMON.LOCAL'
5608       include 'COMMON.CHAIN'
5609       include 'COMMON.DERIV'
5610       include 'COMMON.INTERACT'
5611       include 'COMMON.FFIELD'
5612       include 'COMMON.IOUNITS'
5613       include 'COMMON.CONTROL'
5614       dimension ggg(3)
5615       evdw2=0.0D0
5616       evdw2_14=0.0d0
5617       r0_scp=4.5d0
5618 cd    print '(a)','Enter ESCP'
5619 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5620 C      do xshift=-1,1
5621 C      do yshift=-1,1
5622 C      do zshift=-1,1
5623       do i=iatscp_s,iatscp_e
5624         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5625         iteli=itel(i)
5626         xi=0.5D0*(c(1,i)+c(1,i+1))
5627         yi=0.5D0*(c(2,i)+c(2,i+1))
5628         zi=0.5D0*(c(3,i)+c(3,i+1))
5629 C Return atom into box, boxxsize is size of box in x dimension
5630 c  134   continue
5631 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5632 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5633 C Condition for being inside the proper box
5634 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5635 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5636 c        go to 134
5637 c        endif
5638 c  135   continue
5639 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5640 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5641 C Condition for being inside the proper box
5642 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5643 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5644 c        go to 135
5645 c c       endif
5646 c  136   continue
5647 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5648 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5649 cC Condition for being inside the proper box
5650 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5651 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5652 c        go to 136
5653 c        endif
5654           xi=mod(xi,boxxsize)
5655           if (xi.lt.0) xi=xi+boxxsize
5656           yi=mod(yi,boxysize)
5657           if (yi.lt.0) yi=yi+boxysize
5658           zi=mod(zi,boxzsize)
5659           if (zi.lt.0) zi=zi+boxzsize
5660 C          xi=xi+xshift*boxxsize
5661 C          yi=yi+yshift*boxysize
5662 C          zi=zi+zshift*boxzsize
5663         do iint=1,nscp_gr(i)
5664
5665         do j=iscpstart(i,iint),iscpend(i,iint)
5666           if (itype(j).eq.ntyp1) cycle
5667           itypj=iabs(itype(j))
5668 C Uncomment following three lines for SC-p interactions
5669 c         xj=c(1,nres+j)-xi
5670 c         yj=c(2,nres+j)-yi
5671 c         zj=c(3,nres+j)-zi
5672 C Uncomment following three lines for Ca-p interactions
5673           xj=c(1,j)
5674           yj=c(2,j)
5675           zj=c(3,j)
5676 c  174   continue
5677 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5678 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5679 C Condition for being inside the proper box
5680 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5681 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5682 c        go to 174
5683 c        endif
5684 c  175   continue
5685 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5686 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5687 cC Condition for being inside the proper box
5688 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5689 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5690 c        go to 175
5691 c        endif
5692 c  176   continue
5693 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5694 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5695 C Condition for being inside the proper box
5696 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5697 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5698 c        go to 176
5699           xj=mod(xj,boxxsize)
5700           if (xj.lt.0) xj=xj+boxxsize
5701           yj=mod(yj,boxysize)
5702           if (yj.lt.0) yj=yj+boxysize
5703           zj=mod(zj,boxzsize)
5704           if (zj.lt.0) zj=zj+boxzsize
5705       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5706       xj_safe=xj
5707       yj_safe=yj
5708       zj_safe=zj
5709       subchap=0
5710       do xshift=-1,1
5711       do yshift=-1,1
5712       do zshift=-1,1
5713           xj=xj_safe+xshift*boxxsize
5714           yj=yj_safe+yshift*boxysize
5715           zj=zj_safe+zshift*boxzsize
5716           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5717           if(dist_temp.lt.dist_init) then
5718             dist_init=dist_temp
5719             xj_temp=xj
5720             yj_temp=yj
5721             zj_temp=zj
5722             subchap=1
5723           endif
5724        enddo
5725        enddo
5726        enddo
5727        if (subchap.eq.1) then
5728           xj=xj_temp-xi
5729           yj=yj_temp-yi
5730           zj=zj_temp-zi
5731        else
5732           xj=xj_safe-xi
5733           yj=yj_safe-yi
5734           zj=zj_safe-zi
5735        endif
5736 c c       endif
5737 C          xj=xj-xi
5738 C          yj=yj-yi
5739 C          zj=zj-zi
5740           rij=xj*xj+yj*yj+zj*zj
5741
5742           r0ij=r0_scp
5743           r0ijsq=r0ij*r0ij
5744           if (rij.lt.r0ijsq) then
5745             evdwij=0.25d0*(rij-r0ijsq)**2
5746             fac=rij-r0ijsq
5747           else
5748             evdwij=0.0d0
5749             fac=0.0d0
5750           endif
5751           evdw2=evdw2+evdwij
5752 C
5753 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5754 C
5755           ggg(1)=xj*fac
5756           ggg(2)=yj*fac
5757           ggg(3)=zj*fac
5758 cgrad          if (j.lt.i) then
5759 cd          write (iout,*) 'j<i'
5760 C Uncomment following three lines for SC-p interactions
5761 c           do k=1,3
5762 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5763 c           enddo
5764 cgrad          else
5765 cd          write (iout,*) 'j>i'
5766 cgrad            do k=1,3
5767 cgrad              ggg(k)=-ggg(k)
5768 C Uncomment following line for SC-p interactions
5769 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5770 cgrad            enddo
5771 cgrad          endif
5772 cgrad          do k=1,3
5773 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5774 cgrad          enddo
5775 cgrad          kstart=min0(i+1,j)
5776 cgrad          kend=max0(i-1,j-1)
5777 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5778 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5779 cgrad          do k=kstart,kend
5780 cgrad            do l=1,3
5781 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5782 cgrad            enddo
5783 cgrad          enddo
5784           do k=1,3
5785             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5786             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5787           enddo
5788         enddo
5789
5790         enddo ! iint
5791       enddo ! i
5792 C      enddo !zshift
5793 C      enddo !yshift
5794 C      enddo !xshift
5795       return
5796       end
5797 C-----------------------------------------------------------------------------
5798       subroutine escp(evdw2,evdw2_14)
5799 C
5800 C This subroutine calculates the excluded-volume interaction energy between
5801 C peptide-group centers and side chains and its gradient in virtual-bond and
5802 C side-chain vectors.
5803 C
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       include 'COMMON.GEO'
5807       include 'COMMON.VAR'
5808       include 'COMMON.LOCAL'
5809       include 'COMMON.CHAIN'
5810       include 'COMMON.DERIV'
5811       include 'COMMON.INTERACT'
5812       include 'COMMON.FFIELD'
5813       include 'COMMON.IOUNITS'
5814       include 'COMMON.CONTROL'
5815       include 'COMMON.SPLITELE'
5816       dimension ggg(3)
5817       evdw2=0.0D0
5818       evdw2_14=0.0d0
5819 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5820 cd    print '(a)','Enter ESCP'
5821 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5822 C      do xshift=-1,1
5823 C      do yshift=-1,1
5824 C      do zshift=-1,1
5825       do i=iatscp_s,iatscp_e
5826         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5827         iteli=itel(i)
5828         xi=0.5D0*(c(1,i)+c(1,i+1))
5829         yi=0.5D0*(c(2,i)+c(2,i+1))
5830         zi=0.5D0*(c(3,i)+c(3,i+1))
5831           xi=mod(xi,boxxsize)
5832           if (xi.lt.0) xi=xi+boxxsize
5833           yi=mod(yi,boxysize)
5834           if (yi.lt.0) yi=yi+boxysize
5835           zi=mod(zi,boxzsize)
5836           if (zi.lt.0) zi=zi+boxzsize
5837 c          xi=xi+xshift*boxxsize
5838 c          yi=yi+yshift*boxysize
5839 c          zi=zi+zshift*boxzsize
5840 c        print *,xi,yi,zi,'polozenie i'
5841 C Return atom into box, boxxsize is size of box in x dimension
5842 c  134   continue
5843 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5844 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5845 C Condition for being inside the proper box
5846 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5847 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5848 c        go to 134
5849 c        endif
5850 c  135   continue
5851 c          print *,xi,boxxsize,"pierwszy"
5852
5853 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5854 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5855 C Condition for being inside the proper box
5856 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5857 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5858 c        go to 135
5859 c        endif
5860 c  136   continue
5861 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5862 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5863 C Condition for being inside the proper box
5864 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5865 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5866 c        go to 136
5867 c        endif
5868         do iint=1,nscp_gr(i)
5869
5870         do j=iscpstart(i,iint),iscpend(i,iint)
5871           itypj=iabs(itype(j))
5872           if (itypj.eq.ntyp1) cycle
5873 C Uncomment following three lines for SC-p interactions
5874 c         xj=c(1,nres+j)-xi
5875 c         yj=c(2,nres+j)-yi
5876 c         zj=c(3,nres+j)-zi
5877 C Uncomment following three lines for Ca-p interactions
5878           xj=c(1,j)
5879           yj=c(2,j)
5880           zj=c(3,j)
5881           xj=mod(xj,boxxsize)
5882           if (xj.lt.0) xj=xj+boxxsize
5883           yj=mod(yj,boxysize)
5884           if (yj.lt.0) yj=yj+boxysize
5885           zj=mod(zj,boxzsize)
5886           if (zj.lt.0) zj=zj+boxzsize
5887 c  174   continue
5888 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5889 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5890 C Condition for being inside the proper box
5891 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5892 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5893 c        go to 174
5894 c        endif
5895 c  175   continue
5896 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5897 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5898 cC Condition for being inside the proper box
5899 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5900 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5901 c        go to 175
5902 c        endif
5903 c  176   continue
5904 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5905 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5906 C Condition for being inside the proper box
5907 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5908 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5909 c        go to 176
5910 c        endif
5911 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5912       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5913       xj_safe=xj
5914       yj_safe=yj
5915       zj_safe=zj
5916       subchap=0
5917       do xshift=-1,1
5918       do yshift=-1,1
5919       do zshift=-1,1
5920           xj=xj_safe+xshift*boxxsize
5921           yj=yj_safe+yshift*boxysize
5922           zj=zj_safe+zshift*boxzsize
5923           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5924           if(dist_temp.lt.dist_init) then
5925             dist_init=dist_temp
5926             xj_temp=xj
5927             yj_temp=yj
5928             zj_temp=zj
5929             subchap=1
5930           endif
5931        enddo
5932        enddo
5933        enddo
5934        if (subchap.eq.1) then
5935           xj=xj_temp-xi
5936           yj=yj_temp-yi
5937           zj=zj_temp-zi
5938        else
5939           xj=xj_safe-xi
5940           yj=yj_safe-yi
5941           zj=zj_safe-zi
5942        endif
5943 c          print *,xj,yj,zj,'polozenie j'
5944           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5945 c          print *,rrij
5946           sss=sscale(1.0d0/(dsqrt(rrij)))
5947 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5948 c          if (sss.eq.0) print *,'czasem jest OK'
5949           if (sss.le.0.0d0) cycle
5950           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5951           fac=rrij**expon2
5952           e1=fac*fac*aad(itypj,iteli)
5953           e2=fac*bad(itypj,iteli)
5954           if (iabs(j-i) .le. 2) then
5955             e1=scal14*e1
5956             e2=scal14*e2
5957             evdw2_14=evdw2_14+(e1+e2)*sss
5958           endif
5959           evdwij=e1+e2
5960           evdw2=evdw2+evdwij*sss
5961           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5962      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5963      &       bad(itypj,iteli)
5964 C
5965 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5966 C
5967           fac=-(evdwij+e1)*rrij*sss
5968           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5969           ggg(1)=xj*fac
5970           ggg(2)=yj*fac
5971           ggg(3)=zj*fac
5972 cgrad          if (j.lt.i) then
5973 cd          write (iout,*) 'j<i'
5974 C Uncomment following three lines for SC-p interactions
5975 c           do k=1,3
5976 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5977 c           enddo
5978 cgrad          else
5979 cd          write (iout,*) 'j>i'
5980 cgrad            do k=1,3
5981 cgrad              ggg(k)=-ggg(k)
5982 C Uncomment following line for SC-p interactions
5983 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5984 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5985 cgrad            enddo
5986 cgrad          endif
5987 cgrad          do k=1,3
5988 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5989 cgrad          enddo
5990 cgrad          kstart=min0(i+1,j)
5991 cgrad          kend=max0(i-1,j-1)
5992 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5993 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5994 cgrad          do k=kstart,kend
5995 cgrad            do l=1,3
5996 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5997 cgrad            enddo
5998 cgrad          enddo
5999           do k=1,3
6000             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
6001             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
6002           enddo
6003 c        endif !endif for sscale cutoff
6004         enddo ! j
6005
6006         enddo ! iint
6007       enddo ! i
6008 c      enddo !zshift
6009 c      enddo !yshift
6010 c      enddo !xshift
6011       do i=1,nct
6012         do j=1,3
6013           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
6014           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
6015           gradx_scp(j,i)=expon*gradx_scp(j,i)
6016         enddo
6017       enddo
6018 C******************************************************************************
6019 C
6020 C                              N O T E !!!
6021 C
6022 C To save time the factor EXPON has been extracted from ALL components
6023 C of GVDWC and GRADX. Remember to multiply them by this factor before further
6024 C use!
6025 C
6026 C******************************************************************************
6027       return
6028       end
6029 C--------------------------------------------------------------------------
6030       subroutine edis(ehpb)
6031 C
6032 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6033 C
6034       implicit real*8 (a-h,o-z)
6035       include 'DIMENSIONS'
6036       include 'COMMON.SBRIDGE'
6037       include 'COMMON.CHAIN'
6038       include 'COMMON.DERIV'
6039       include 'COMMON.VAR'
6040       include 'COMMON.INTERACT'
6041       include 'COMMON.IOUNITS'
6042       include 'COMMON.CONTROL'
6043       dimension ggg(3)
6044       ehpb=0.0D0
6045       do i=1,3
6046        ggg(i)=0.0d0
6047       enddo
6048 C      write (iout,*) ,"link_end",link_end,constr_dist
6049 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6050 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
6051       if (link_end.eq.0) return
6052       do i=link_start,link_end
6053 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6054 C CA-CA distance used in regularization of structure.
6055         ii=ihpb(i)
6056         jj=jhpb(i)
6057 C iii and jjj point to the residues for which the distance is assigned.
6058         if (ii.gt.nres) then
6059           iii=ii-nres
6060           jjj=jj-nres
6061         else
6062           iii=ii
6063           jjj=jj
6064         endif
6065 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6066 c     &    dhpb(i),dhpb1(i),forcon(i)
6067 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6068 C    distance and angle dependent SS bond potential.
6069 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6070 C     & iabs(itype(jjj)).eq.1) then
6071 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6072 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6073         if (.not.dyn_ss .and. i.le.nss) then
6074 C 15/02/13 CC dynamic SSbond - additional check
6075          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6076      & iabs(itype(jjj)).eq.1) then
6077           call ssbond_ene(iii,jjj,eij)
6078           ehpb=ehpb+2*eij
6079          endif
6080 cd          write (iout,*) "eij",eij
6081 cd   &   ' waga=',waga,' fac=',fac
6082         else if (ii.gt.nres .and. jj.gt.nres) then
6083 c Restraints from contact prediction
6084           dd=dist(ii,jj)
6085           if (constr_dist.eq.11) then
6086             ehpb=ehpb+fordepth(i)**4.0d0
6087      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6088             fac=fordepth(i)**4.0d0
6089      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6090           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6091      &    ehpb,fordepth(i),dd
6092            else
6093           if (dhpb1(i).gt.0.0d0) then
6094             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6095             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6096 c            write (iout,*) "beta nmr",
6097 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6098           else
6099             dd=dist(ii,jj)
6100             rdis=dd-dhpb(i)
6101 C Get the force constant corresponding to this distance.
6102             waga=forcon(i)
6103 C Calculate the contribution to energy.
6104             ehpb=ehpb+waga*rdis*rdis
6105 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6106 C
6107 C Evaluate gradient.
6108 C
6109             fac=waga*rdis/dd
6110           endif
6111           endif
6112           do j=1,3
6113             ggg(j)=fac*(c(j,jj)-c(j,ii))
6114           enddo
6115           do j=1,3
6116             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6117             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6118           enddo
6119           do k=1,3
6120             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6121             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6122           enddo
6123         else
6124 C Calculate the distance between the two points and its difference from the
6125 C target distance.
6126           dd=dist(ii,jj)
6127           if (constr_dist.eq.11) then
6128             ehpb=ehpb+fordepth(i)**4.0d0
6129      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6130             fac=fordepth(i)**4.0d0
6131      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6132           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6133      &    ehpb,fordepth(i),dd
6134            else
6135           if (dhpb1(i).gt.0.0d0) then
6136             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6137             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6138 c            write (iout,*) "alph nmr",
6139 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6140           else
6141             rdis=dd-dhpb(i)
6142 C Get the force constant corresponding to this distance.
6143             waga=forcon(i)
6144 C Calculate the contribution to energy.
6145             ehpb=ehpb+waga*rdis*rdis
6146 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6147 C
6148 C Evaluate gradient.
6149 C
6150             fac=waga*rdis/dd
6151           endif
6152           endif
6153             do j=1,3
6154               ggg(j)=fac*(c(j,jj)-c(j,ii))
6155             enddo
6156 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6157 C If this is a SC-SC distance, we need to calculate the contributions to the
6158 C Cartesian gradient in the SC vectors (ghpbx).
6159           if (iii.lt.ii) then
6160           do j=1,3
6161             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6162             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6163           enddo
6164           endif
6165 cgrad        do j=iii,jjj-1
6166 cgrad          do k=1,3
6167 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6168 cgrad          enddo
6169 cgrad        enddo
6170           do k=1,3
6171             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6172             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6173           enddo
6174         endif
6175       enddo
6176       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6177       return
6178       end
6179 C--------------------------------------------------------------------------
6180       subroutine ssbond_ene(i,j,eij)
6181 C
6182 C Calculate the distance and angle dependent SS-bond potential energy
6183 C using a free-energy function derived based on RHF/6-31G** ab initio
6184 C calculations of diethyl disulfide.
6185 C
6186 C A. Liwo and U. Kozlowska, 11/24/03
6187 C
6188       implicit real*8 (a-h,o-z)
6189       include 'DIMENSIONS'
6190       include 'COMMON.SBRIDGE'
6191       include 'COMMON.CHAIN'
6192       include 'COMMON.DERIV'
6193       include 'COMMON.LOCAL'
6194       include 'COMMON.INTERACT'
6195       include 'COMMON.VAR'
6196       include 'COMMON.IOUNITS'
6197       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6198       itypi=iabs(itype(i))
6199       xi=c(1,nres+i)
6200       yi=c(2,nres+i)
6201       zi=c(3,nres+i)
6202       dxi=dc_norm(1,nres+i)
6203       dyi=dc_norm(2,nres+i)
6204       dzi=dc_norm(3,nres+i)
6205 c      dsci_inv=dsc_inv(itypi)
6206       dsci_inv=vbld_inv(nres+i)
6207       itypj=iabs(itype(j))
6208 c      dscj_inv=dsc_inv(itypj)
6209       dscj_inv=vbld_inv(nres+j)
6210       xj=c(1,nres+j)-xi
6211       yj=c(2,nres+j)-yi
6212       zj=c(3,nres+j)-zi
6213       dxj=dc_norm(1,nres+j)
6214       dyj=dc_norm(2,nres+j)
6215       dzj=dc_norm(3,nres+j)
6216       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6217       rij=dsqrt(rrij)
6218       erij(1)=xj*rij
6219       erij(2)=yj*rij
6220       erij(3)=zj*rij
6221       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6222       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6223       om12=dxi*dxj+dyi*dyj+dzi*dzj
6224       do k=1,3
6225         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6226         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6227       enddo
6228       rij=1.0d0/rij
6229       deltad=rij-d0cm
6230       deltat1=1.0d0-om1
6231       deltat2=1.0d0+om2
6232       deltat12=om2-om1+2.0d0
6233       cosphi=om12-om1*om2
6234       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6235      &  +akct*deltad*deltat12
6236      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6237 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6238 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6239 c     &  " deltat12",deltat12," eij",eij
6240       ed=2*akcm*deltad+akct*deltat12
6241       pom1=akct*deltad
6242       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6243       eom1=-2*akth*deltat1-pom1-om2*pom2
6244       eom2= 2*akth*deltat2+pom1-om1*pom2
6245       eom12=pom2
6246       do k=1,3
6247         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6248         ghpbx(k,i)=ghpbx(k,i)-ggk
6249      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6250      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6251         ghpbx(k,j)=ghpbx(k,j)+ggk
6252      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6253      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6254         ghpbc(k,i)=ghpbc(k,i)-ggk
6255         ghpbc(k,j)=ghpbc(k,j)+ggk
6256       enddo
6257 C
6258 C Calculate the components of the gradient in DC and X
6259 C
6260 cgrad      do k=i,j-1
6261 cgrad        do l=1,3
6262 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6263 cgrad        enddo
6264 cgrad      enddo
6265       return
6266       end
6267 C--------------------------------------------------------------------------
6268       subroutine ebond(estr)
6269 c
6270 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6271 c
6272       implicit real*8 (a-h,o-z)
6273       include 'DIMENSIONS'
6274       include 'COMMON.LOCAL'
6275       include 'COMMON.GEO'
6276       include 'COMMON.INTERACT'
6277       include 'COMMON.DERIV'
6278       include 'COMMON.VAR'
6279       include 'COMMON.CHAIN'
6280       include 'COMMON.IOUNITS'
6281       include 'COMMON.NAMES'
6282       include 'COMMON.FFIELD'
6283       include 'COMMON.CONTROL'
6284       include 'COMMON.SETUP'
6285       double precision u(3),ud(3)
6286       estr=0.0d0
6287       estr1=0.0d0
6288       do i=ibondp_start,ibondp_end
6289         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6290 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6291 c          do j=1,3
6292 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6293 c     &      *dc(j,i-1)/vbld(i)
6294 c          enddo
6295 c          if (energy_dec) write(iout,*)
6296 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6297 c        else
6298 C       Checking if it involves dummy (NH3+ or COO-) group
6299          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6300 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6301         diff = vbld(i)-vbldpDUM
6302         if (energy_dec) write(iout,*) "dum_bond",i,diff
6303          else
6304 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6305         diff = vbld(i)-vbldp0
6306          endif
6307         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6308      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6309         estr=estr+diff*diff
6310         do j=1,3
6311           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6312         enddo
6313 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6314 c        endif
6315       enddo
6316
6317       estr=0.5d0*AKP*estr+estr1
6318 c
6319 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6320 c
6321       do i=ibond_start,ibond_end
6322         iti=iabs(itype(i))
6323         if (iti.ne.10 .and. iti.ne.ntyp1) then
6324           nbi=nbondterm(iti)
6325           if (nbi.eq.1) then
6326             diff=vbld(i+nres)-vbldsc0(1,iti)
6327             if (energy_dec)  write (iout,*)
6328      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6329      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6330             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6331             do j=1,3
6332               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6333             enddo
6334           else
6335             do j=1,nbi
6336               diff=vbld(i+nres)-vbldsc0(j,iti)
6337             if (energy_dec)  write (iout,*)
6338      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(j,iti),diff,
6339      &      AKSC(j,iti),AKSC(j,iti)*diff*diff
6340               ud(j)=aksc(j,iti)*diff
6341               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6342             enddo
6343             uprod=u(1)
6344             do j=2,nbi
6345               uprod=uprod*u(j)
6346             enddo
6347             usum=0.0d0
6348             usumsqder=0.0d0
6349             do j=1,nbi
6350               uprod1=1.0d0
6351               uprod2=1.0d0
6352               do k=1,nbi
6353                 if (k.ne.j) then
6354                   uprod1=uprod1*u(k)
6355                   uprod2=uprod2*u(k)*u(k)
6356                 endif
6357               enddo
6358               usum=usum+uprod1
6359               usumsqder=usumsqder+ud(j)*uprod2
6360             enddo
6361             estr=estr+uprod/usum
6362             do j=1,3
6363              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6364             enddo
6365           endif
6366         endif
6367       enddo
6368       return
6369       end
6370 #ifdef CRYST_THETA
6371 C--------------------------------------------------------------------------
6372       subroutine ebend(etheta,ethetacnstr)
6373 C
6374 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6375 C angles gamma and its derivatives in consecutive thetas and gammas.
6376 C
6377       implicit real*8 (a-h,o-z)
6378       include 'DIMENSIONS'
6379       include 'COMMON.LOCAL'
6380       include 'COMMON.GEO'
6381       include 'COMMON.INTERACT'
6382       include 'COMMON.DERIV'
6383       include 'COMMON.VAR'
6384       include 'COMMON.CHAIN'
6385       include 'COMMON.IOUNITS'
6386       include 'COMMON.NAMES'
6387       include 'COMMON.FFIELD'
6388       include 'COMMON.CONTROL'
6389       include 'COMMON.TORCNSTR'
6390       common /calcthet/ term1,term2,termm,diffak,ratak,
6391      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6392      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6393       double precision y(2),z(2)
6394       delta=0.02d0*pi
6395 c      time11=dexp(-2*time)
6396 c      time12=1.0d0
6397       etheta=0.0D0
6398 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6399       do i=ithet_start,ithet_end
6400         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6401      &  .or.itype(i).eq.ntyp1) cycle
6402 C Zero the energy function and its derivative at 0 or pi.
6403         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6404         it=itype(i-1)
6405         ichir1=isign(1,itype(i-2))
6406         ichir2=isign(1,itype(i))
6407          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6408          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6409          if (itype(i-1).eq.10) then
6410           itype1=isign(10,itype(i-2))
6411           ichir11=isign(1,itype(i-2))
6412           ichir12=isign(1,itype(i-2))
6413           itype2=isign(10,itype(i))
6414           ichir21=isign(1,itype(i))
6415           ichir22=isign(1,itype(i))
6416          endif
6417
6418         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6419 #ifdef OSF
6420           phii=phi(i)
6421           if (phii.ne.phii) phii=150.0
6422 #else
6423           phii=phi(i)
6424 #endif
6425           y(1)=dcos(phii)
6426           y(2)=dsin(phii)
6427         else
6428           y(1)=0.0D0
6429           y(2)=0.0D0
6430         endif
6431         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6432 #ifdef OSF
6433           phii1=phi(i+1)
6434           if (phii1.ne.phii1) phii1=150.0
6435           phii1=pinorm(phii1)
6436           z(1)=cos(phii1)
6437 #else
6438           phii1=phi(i+1)
6439 #endif
6440           z(1)=dcos(phii1)
6441           z(2)=dsin(phii1)
6442         else
6443           z(1)=0.0D0
6444           z(2)=0.0D0
6445         endif
6446 C Calculate the "mean" value of theta from the part of the distribution
6447 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6448 C In following comments this theta will be referred to as t_c.
6449         thet_pred_mean=0.0d0
6450         do k=1,2
6451             athetk=athet(k,it,ichir1,ichir2)
6452             bthetk=bthet(k,it,ichir1,ichir2)
6453           if (it.eq.10) then
6454              athetk=athet(k,itype1,ichir11,ichir12)
6455              bthetk=bthet(k,itype2,ichir21,ichir22)
6456           endif
6457          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6458 c         write(iout,*) 'chuj tu', y(k),z(k)
6459         enddo
6460         dthett=thet_pred_mean*ssd
6461         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6462 C Derivatives of the "mean" values in gamma1 and gamma2.
6463         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6464      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6465          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6466      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6467          if (it.eq.10) then
6468       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6469      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6470         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6471      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6472          endif
6473         if (theta(i).gt.pi-delta) then
6474           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6475      &         E_tc0)
6476           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6477           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6478           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6479      &        E_theta)
6480           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6481      &        E_tc)
6482         else if (theta(i).lt.delta) then
6483           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6484           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6485           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6486      &        E_theta)
6487           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6488           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6489      &        E_tc)
6490         else
6491           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6492      &        E_theta,E_tc)
6493         endif
6494         etheta=etheta+ethetai
6495         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6496      &      'ebend',i,ethetai,theta(i),itype(i)
6497         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6498         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6499         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6500       enddo
6501       ethetacnstr=0.0d0
6502 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6503       do i=ithetaconstr_start,ithetaconstr_end
6504         itheta=itheta_constr(i)
6505         thetiii=theta(itheta)
6506         difi=pinorm(thetiii-theta_constr0(i))
6507         if (difi.gt.theta_drange(i)) then
6508           difi=difi-theta_drange(i)
6509           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6510           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6511      &    +for_thet_constr(i)*difi**3
6512         else if (difi.lt.-drange(i)) then
6513           difi=difi+drange(i)
6514           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6515           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6516      &    +for_thet_constr(i)*difi**3
6517         else
6518           difi=0.0
6519         endif
6520        if (energy_dec) then
6521         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6522      &    i,itheta,rad2deg*thetiii,
6523      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6524      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6525      &    gloc(itheta+nphi-2,icg)
6526         endif
6527       enddo
6528
6529 C Ufff.... We've done all this!!!
6530       return
6531       end
6532 C---------------------------------------------------------------------------
6533       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6534      &     E_tc)
6535       implicit real*8 (a-h,o-z)
6536       include 'DIMENSIONS'
6537       include 'COMMON.LOCAL'
6538       include 'COMMON.IOUNITS'
6539       common /calcthet/ term1,term2,termm,diffak,ratak,
6540      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6541      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6542 C Calculate the contributions to both Gaussian lobes.
6543 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6544 C The "polynomial part" of the "standard deviation" of this part of
6545 C the distributioni.
6546 ccc        write (iout,*) thetai,thet_pred_mean
6547         sig=polthet(3,it)
6548         do j=2,0,-1
6549           sig=sig*thet_pred_mean+polthet(j,it)
6550         enddo
6551 C Derivative of the "interior part" of the "standard deviation of the"
6552 C gamma-dependent Gaussian lobe in t_c.
6553         sigtc=3*polthet(3,it)
6554         do j=2,1,-1
6555           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6556         enddo
6557         sigtc=sig*sigtc
6558 C Set the parameters of both Gaussian lobes of the distribution.
6559 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6560         fac=sig*sig+sigc0(it)
6561         sigcsq=fac+fac
6562         sigc=1.0D0/sigcsq
6563 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6564         sigsqtc=-4.0D0*sigcsq*sigtc
6565 c       print *,i,sig,sigtc,sigsqtc
6566 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6567         sigtc=-sigtc/(fac*fac)
6568 C Following variable is sigma(t_c)**(-2)
6569         sigcsq=sigcsq*sigcsq
6570         sig0i=sig0(it)
6571         sig0inv=1.0D0/sig0i**2
6572         delthec=thetai-thet_pred_mean
6573         delthe0=thetai-theta0i
6574         term1=-0.5D0*sigcsq*delthec*delthec
6575         term2=-0.5D0*sig0inv*delthe0*delthe0
6576 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6577 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6578 C NaNs in taking the logarithm. We extract the largest exponent which is added
6579 C to the energy (this being the log of the distribution) at the end of energy
6580 C term evaluation for this virtual-bond angle.
6581         if (term1.gt.term2) then
6582           termm=term1
6583           term2=dexp(term2-termm)
6584           term1=1.0d0
6585         else
6586           termm=term2
6587           term1=dexp(term1-termm)
6588           term2=1.0d0
6589         endif
6590 C The ratio between the gamma-independent and gamma-dependent lobes of
6591 C the distribution is a Gaussian function of thet_pred_mean too.
6592         diffak=gthet(2,it)-thet_pred_mean
6593         ratak=diffak/gthet(3,it)**2
6594         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6595 C Let's differentiate it in thet_pred_mean NOW.
6596         aktc=ak*ratak
6597 C Now put together the distribution terms to make complete distribution.
6598         termexp=term1+ak*term2
6599         termpre=sigc+ak*sig0i
6600 C Contribution of the bending energy from this theta is just the -log of
6601 C the sum of the contributions from the two lobes and the pre-exponential
6602 C factor. Simple enough, isn't it?
6603         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6604 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6605 C NOW the derivatives!!!
6606 C 6/6/97 Take into account the deformation.
6607         E_theta=(delthec*sigcsq*term1
6608      &       +ak*delthe0*sig0inv*term2)/termexp
6609         E_tc=((sigtc+aktc*sig0i)/termpre
6610      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6611      &       aktc*term2)/termexp)
6612       return
6613       end
6614 c-----------------------------------------------------------------------------
6615       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6616       implicit real*8 (a-h,o-z)
6617       include 'DIMENSIONS'
6618       include 'COMMON.LOCAL'
6619       include 'COMMON.IOUNITS'
6620       common /calcthet/ term1,term2,termm,diffak,ratak,
6621      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6622      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6623       delthec=thetai-thet_pred_mean
6624       delthe0=thetai-theta0i
6625 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6626       t3 = thetai-thet_pred_mean
6627       t6 = t3**2
6628       t9 = term1
6629       t12 = t3*sigcsq
6630       t14 = t12+t6*sigsqtc
6631       t16 = 1.0d0
6632       t21 = thetai-theta0i
6633       t23 = t21**2
6634       t26 = term2
6635       t27 = t21*t26
6636       t32 = termexp
6637       t40 = t32**2
6638       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6639      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6640      & *(-t12*t9-ak*sig0inv*t27)
6641       return
6642       end
6643 #else
6644 C--------------------------------------------------------------------------
6645       subroutine ebend(etheta,ethetacnstr)
6646 C
6647 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6648 C angles gamma and its derivatives in consecutive thetas and gammas.
6649 C ab initio-derived potentials from
6650 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6651 C
6652       implicit real*8 (a-h,o-z)
6653       include 'DIMENSIONS'
6654       include 'COMMON.LOCAL'
6655       include 'COMMON.GEO'
6656       include 'COMMON.INTERACT'
6657       include 'COMMON.DERIV'
6658       include 'COMMON.VAR'
6659       include 'COMMON.CHAIN'
6660       include 'COMMON.IOUNITS'
6661       include 'COMMON.NAMES'
6662       include 'COMMON.FFIELD'
6663       include 'COMMON.CONTROL'
6664       include 'COMMON.TORCNSTR'
6665       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6666      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6667      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6668      & sinph1ph2(maxdouble,maxdouble)
6669       logical lprn /.false./, lprn1 /.false./
6670       etheta=0.0D0
6671       do i=ithet_start,ithet_end
6672 c        print *,i,itype(i-1),itype(i),itype(i-2)
6673 C        if (itype(i-1).eq.ntyp1) cycle
6674         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6675      &  .or.itype(i).eq.ntyp1) cycle
6676 C        print *,i,theta(i)
6677         if (iabs(itype(i+1)).eq.20) iblock=2
6678         if (iabs(itype(i+1)).ne.20) iblock=1
6679         dethetai=0.0d0
6680         dephii=0.0d0
6681         dephii1=0.0d0
6682         theti2=0.5d0*theta(i)
6683         ityp2=ithetyp((itype(i-1)))
6684         do k=1,nntheterm
6685           coskt(k)=dcos(k*theti2)
6686           sinkt(k)=dsin(k*theti2)
6687         enddo
6688 C        print *,ethetai
6689         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6690 #ifdef OSF
6691           phii=phi(i)
6692           if (phii.ne.phii) phii=150.0
6693 #else
6694           phii=phi(i)
6695 #endif
6696           ityp1=ithetyp((itype(i-2)))
6697 C propagation of chirality for glycine type
6698           do k=1,nsingle
6699             cosph1(k)=dcos(k*phii)
6700             sinph1(k)=dsin(k*phii)
6701           enddo
6702         else
6703           phii=0.0d0
6704           do k=1,nsingle
6705           ityp1=ithetyp((itype(i-2)))
6706             cosph1(k)=0.0d0
6707             sinph1(k)=0.0d0
6708           enddo
6709         endif
6710         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6711 #ifdef OSF
6712           phii1=phi(i+1)
6713           if (phii1.ne.phii1) phii1=150.0
6714           phii1=pinorm(phii1)
6715 #else
6716           phii1=phi(i+1)
6717 #endif
6718           ityp3=ithetyp((itype(i)))
6719           do k=1,nsingle
6720             cosph2(k)=dcos(k*phii1)
6721             sinph2(k)=dsin(k*phii1)
6722           enddo
6723         else
6724           phii1=0.0d0
6725           ityp3=ithetyp((itype(i)))
6726           do k=1,nsingle
6727             cosph2(k)=0.0d0
6728             sinph2(k)=0.0d0
6729           enddo
6730         endif
6731         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6732         do k=1,ndouble
6733           do l=1,k-1
6734             ccl=cosph1(l)*cosph2(k-l)
6735             ssl=sinph1(l)*sinph2(k-l)
6736             scl=sinph1(l)*cosph2(k-l)
6737             csl=cosph1(l)*sinph2(k-l)
6738             cosph1ph2(l,k)=ccl-ssl
6739             cosph1ph2(k,l)=ccl+ssl
6740             sinph1ph2(l,k)=scl+csl
6741             sinph1ph2(k,l)=scl-csl
6742           enddo
6743         enddo
6744         if (lprn) then
6745         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6746      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6747         write (iout,*) "coskt and sinkt"
6748         do k=1,nntheterm
6749           write (iout,*) k,coskt(k),sinkt(k)
6750         enddo
6751         endif
6752         do k=1,ntheterm
6753           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6754           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6755      &      *coskt(k)
6756           if (lprn)
6757      &    write (iout,*) "k",k,"
6758      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6759      &     " ethetai",ethetai
6760         enddo
6761         if (lprn) then
6762         write (iout,*) "cosph and sinph"
6763         do k=1,nsingle
6764           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6765         enddo
6766         write (iout,*) "cosph1ph2 and sinph2ph2"
6767         do k=2,ndouble
6768           do l=1,k-1
6769             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6770      &         sinph1ph2(l,k),sinph1ph2(k,l)
6771           enddo
6772         enddo
6773         write(iout,*) "ethetai",ethetai
6774         endif
6775 C       print *,ethetai
6776         do m=1,ntheterm2
6777           do k=1,nsingle
6778             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6779      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6780      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6781      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6782             ethetai=ethetai+sinkt(m)*aux
6783             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6784             dephii=dephii+k*sinkt(m)*(
6785      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6786      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6787             dephii1=dephii1+k*sinkt(m)*(
6788      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6789      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6790             if (lprn)
6791      &      write (iout,*) "m",m," k",k," bbthet",
6792      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6793      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6794      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6795      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6796 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6797           enddo
6798         enddo
6799 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6800 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6801 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6802 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6803         if (lprn)
6804      &  write(iout,*) "ethetai",ethetai
6805 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6806         do m=1,ntheterm3
6807           do k=2,ndouble
6808             do l=1,k-1
6809               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6810      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6811      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6812      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6813               ethetai=ethetai+sinkt(m)*aux
6814               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6815               dephii=dephii+l*sinkt(m)*(
6816      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6820               dephii1=dephii1+(k-l)*sinkt(m)*(
6821      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6822      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6823      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6824      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6825               if (lprn) then
6826               write (iout,*) "m",m," k",k," l",l," ffthet",
6827      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6828      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6829      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6830      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6831      &            " ethetai",ethetai
6832               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6833      &            cosph1ph2(k,l)*sinkt(m),
6834      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6835               endif
6836             enddo
6837           enddo
6838         enddo
6839 10      continue
6840 c        lprn1=.true.
6841 C        print *,ethetai
6842         if (lprn1)
6843      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6844      &   i,theta(i)*rad2deg,phii*rad2deg,
6845      &   phii1*rad2deg,ethetai
6846 c        lprn1=.false.
6847         etheta=etheta+ethetai
6848         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6849         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6850         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6851       enddo
6852 C now constrains
6853       ethetacnstr=0.0d0
6854 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6855       do i=ithetaconstr_start,ithetaconstr_end
6856         itheta=itheta_constr(i)
6857         thetiii=theta(itheta)
6858         difi=pinorm(thetiii-theta_constr0(i))
6859         if (difi.gt.theta_drange(i)) then
6860           difi=difi-theta_drange(i)
6861           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6862           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6863      &    +for_thet_constr(i)*difi**3
6864         else if (difi.lt.-drange(i)) then
6865           difi=difi+drange(i)
6866           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6867           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6868      &    +for_thet_constr(i)*difi**3
6869         else
6870           difi=0.0
6871         endif
6872        if (energy_dec) then
6873         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6874      &    i,itheta,rad2deg*thetiii,
6875      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6876      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6877      &    gloc(itheta+nphi-2,icg)
6878         endif
6879       enddo
6880
6881       return
6882       end
6883 #endif
6884 #ifdef CRYST_SC
6885 c-----------------------------------------------------------------------------
6886       subroutine esc(escloc)
6887 C Calculate the local energy of a side chain and its derivatives in the
6888 C corresponding virtual-bond valence angles THETA and the spherical angles
6889 C ALPHA and OMEGA.
6890       implicit real*8 (a-h,o-z)
6891       include 'DIMENSIONS'
6892       include 'COMMON.GEO'
6893       include 'COMMON.LOCAL'
6894       include 'COMMON.VAR'
6895       include 'COMMON.INTERACT'
6896       include 'COMMON.DERIV'
6897       include 'COMMON.CHAIN'
6898       include 'COMMON.IOUNITS'
6899       include 'COMMON.NAMES'
6900       include 'COMMON.FFIELD'
6901       include 'COMMON.CONTROL'
6902       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6903      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6904       common /sccalc/ time11,time12,time112,theti,it,nlobit
6905       delta=0.02d0*pi
6906       escloc=0.0D0
6907 c     write (iout,'(a)') 'ESC'
6908       do i=loc_start,loc_end
6909         it=itype(i)
6910         if (it.eq.ntyp1) cycle
6911         if (it.eq.10) goto 1
6912         nlobit=nlob(iabs(it))
6913 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6914 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6915         theti=theta(i+1)-pipol
6916         x(1)=dtan(theti)
6917         x(2)=alph(i)
6918         x(3)=omeg(i)
6919
6920         if (x(2).gt.pi-delta) then
6921           xtemp(1)=x(1)
6922           xtemp(2)=pi-delta
6923           xtemp(3)=x(3)
6924           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6925           xtemp(2)=pi
6926           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6927           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6928      &        escloci,dersc(2))
6929           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6930      &        ddersc0(1),dersc(1))
6931           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6932      &        ddersc0(3),dersc(3))
6933           xtemp(2)=pi-delta
6934           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6935           xtemp(2)=pi
6936           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6937           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6938      &            dersc0(2),esclocbi,dersc02)
6939           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6940      &            dersc12,dersc01)
6941           call splinthet(x(2),0.5d0*delta,ss,ssd)
6942           dersc0(1)=dersc01
6943           dersc0(2)=dersc02
6944           dersc0(3)=0.0d0
6945           do k=1,3
6946             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6947           enddo
6948           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6949 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6950 c    &             esclocbi,ss,ssd
6951           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6952 c         escloci=esclocbi
6953 c         write (iout,*) escloci
6954         else if (x(2).lt.delta) then
6955           xtemp(1)=x(1)
6956           xtemp(2)=delta
6957           xtemp(3)=x(3)
6958           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6959           xtemp(2)=0.0d0
6960           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6961           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6962      &        escloci,dersc(2))
6963           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6964      &        ddersc0(1),dersc(1))
6965           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6966      &        ddersc0(3),dersc(3))
6967           xtemp(2)=delta
6968           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6969           xtemp(2)=0.0d0
6970           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6971           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6972      &            dersc0(2),esclocbi,dersc02)
6973           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6974      &            dersc12,dersc01)
6975           dersc0(1)=dersc01
6976           dersc0(2)=dersc02
6977           dersc0(3)=0.0d0
6978           call splinthet(x(2),0.5d0*delta,ss,ssd)
6979           do k=1,3
6980             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6981           enddo
6982           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6983 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6984 c    &             esclocbi,ss,ssd
6985           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6986 c         write (iout,*) escloci
6987         else
6988           call enesc(x,escloci,dersc,ddummy,.false.)
6989         endif
6990
6991         escloc=escloc+escloci
6992         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6993      &     'escloc',i,escloci
6994 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6995
6996         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6997      &   wscloc*dersc(1)
6998         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6999         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
7000     1   continue
7001       enddo
7002       return
7003       end
7004 C---------------------------------------------------------------------------
7005       subroutine enesc(x,escloci,dersc,ddersc,mixed)
7006       implicit real*8 (a-h,o-z)
7007       include 'DIMENSIONS'
7008       include 'COMMON.GEO'
7009       include 'COMMON.LOCAL'
7010       include 'COMMON.IOUNITS'
7011       common /sccalc/ time11,time12,time112,theti,it,nlobit
7012       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7013       double precision contr(maxlob,-1:1)
7014       logical mixed
7015 c       write (iout,*) 'it=',it,' nlobit=',nlobit
7016         escloc_i=0.0D0
7017         do j=1,3
7018           dersc(j)=0.0D0
7019           if (mixed) ddersc(j)=0.0d0
7020         enddo
7021         x3=x(3)
7022
7023 C Because of periodicity of the dependence of the SC energy in omega we have
7024 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7025 C To avoid underflows, first compute & store the exponents.
7026
7027         do iii=-1,1
7028
7029           x(3)=x3+iii*dwapi
7030
7031           do j=1,nlobit
7032             do k=1,3
7033               z(k)=x(k)-censc(k,j,it)
7034             enddo
7035             do k=1,3
7036               Axk=0.0D0
7037               do l=1,3
7038                 Axk=Axk+gaussc(l,k,j,it)*z(l)
7039               enddo
7040               Ax(k,j,iii)=Axk
7041             enddo
7042             expfac=0.0D0
7043             do k=1,3
7044               expfac=expfac+Ax(k,j,iii)*z(k)
7045             enddo
7046             contr(j,iii)=expfac
7047           enddo ! j
7048
7049         enddo ! iii
7050
7051         x(3)=x3
7052 C As in the case of ebend, we want to avoid underflows in exponentiation and
7053 C subsequent NaNs and INFs in energy calculation.
7054 C Find the largest exponent
7055         emin=contr(1,-1)
7056         do iii=-1,1
7057           do j=1,nlobit
7058             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7059           enddo
7060         enddo
7061         emin=0.5D0*emin
7062 cd      print *,'it=',it,' emin=',emin
7063
7064 C Compute the contribution to SC energy and derivatives
7065         do iii=-1,1
7066
7067           do j=1,nlobit
7068 #ifdef OSF
7069             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7070             if(adexp.ne.adexp) adexp=1.0
7071             expfac=dexp(adexp)
7072 #else
7073             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7074 #endif
7075 cd          print *,'j=',j,' expfac=',expfac
7076             escloc_i=escloc_i+expfac
7077             do k=1,3
7078               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7079             enddo
7080             if (mixed) then
7081               do k=1,3,2
7082                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7083      &            +gaussc(k,2,j,it))*expfac
7084               enddo
7085             endif
7086           enddo
7087
7088         enddo ! iii
7089
7090         dersc(1)=dersc(1)/cos(theti)**2
7091         ddersc(1)=ddersc(1)/cos(theti)**2
7092         ddersc(3)=ddersc(3)
7093
7094         escloci=-(dlog(escloc_i)-emin)
7095         do j=1,3
7096           dersc(j)=dersc(j)/escloc_i
7097         enddo
7098         if (mixed) then
7099           do j=1,3,2
7100             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7101           enddo
7102         endif
7103       return
7104       end
7105 C------------------------------------------------------------------------------
7106       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7107       implicit real*8 (a-h,o-z)
7108       include 'DIMENSIONS'
7109       include 'COMMON.GEO'
7110       include 'COMMON.LOCAL'
7111       include 'COMMON.IOUNITS'
7112       common /sccalc/ time11,time12,time112,theti,it,nlobit
7113       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7114       double precision contr(maxlob)
7115       logical mixed
7116
7117       escloc_i=0.0D0
7118
7119       do j=1,3
7120         dersc(j)=0.0D0
7121       enddo
7122
7123       do j=1,nlobit
7124         do k=1,2
7125           z(k)=x(k)-censc(k,j,it)
7126         enddo
7127         z(3)=dwapi
7128         do k=1,3
7129           Axk=0.0D0
7130           do l=1,3
7131             Axk=Axk+gaussc(l,k,j,it)*z(l)
7132           enddo
7133           Ax(k,j)=Axk
7134         enddo
7135         expfac=0.0D0
7136         do k=1,3
7137           expfac=expfac+Ax(k,j)*z(k)
7138         enddo
7139         contr(j)=expfac
7140       enddo ! j
7141
7142 C As in the case of ebend, we want to avoid underflows in exponentiation and
7143 C subsequent NaNs and INFs in energy calculation.
7144 C Find the largest exponent
7145       emin=contr(1)
7146       do j=1,nlobit
7147         if (emin.gt.contr(j)) emin=contr(j)
7148       enddo
7149       emin=0.5D0*emin
7150
7151 C Compute the contribution to SC energy and derivatives
7152
7153       dersc12=0.0d0
7154       do j=1,nlobit
7155         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7156         escloc_i=escloc_i+expfac
7157         do k=1,2
7158           dersc(k)=dersc(k)+Ax(k,j)*expfac
7159         enddo
7160         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7161      &            +gaussc(1,2,j,it))*expfac
7162         dersc(3)=0.0d0
7163       enddo
7164
7165       dersc(1)=dersc(1)/cos(theti)**2
7166       dersc12=dersc12/cos(theti)**2
7167       escloci=-(dlog(escloc_i)-emin)
7168       do j=1,2
7169         dersc(j)=dersc(j)/escloc_i
7170       enddo
7171       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7172       return
7173       end
7174 #else
7175 c----------------------------------------------------------------------------------
7176       subroutine esc(escloc)
7177 C Calculate the local energy of a side chain and its derivatives in the
7178 C corresponding virtual-bond valence angles THETA and the spherical angles
7179 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7180 C added by Urszula Kozlowska. 07/11/2007
7181 C
7182       implicit real*8 (a-h,o-z)
7183       include 'DIMENSIONS'
7184       include 'COMMON.GEO'
7185       include 'COMMON.LOCAL'
7186       include 'COMMON.VAR'
7187       include 'COMMON.SCROT'
7188       include 'COMMON.INTERACT'
7189       include 'COMMON.DERIV'
7190       include 'COMMON.CHAIN'
7191       include 'COMMON.IOUNITS'
7192       include 'COMMON.NAMES'
7193       include 'COMMON.FFIELD'
7194       include 'COMMON.CONTROL'
7195       include 'COMMON.VECTORS'
7196       double precision x_prime(3),y_prime(3),z_prime(3)
7197      &    , sumene,dsc_i,dp2_i,x(65),
7198      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7199      &    de_dxx,de_dyy,de_dzz,de_dt
7200       double precision s1_t,s1_6_t,s2_t,s2_6_t
7201       double precision
7202      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7203      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7204      & dt_dCi(3),dt_dCi1(3)
7205       common /sccalc/ time11,time12,time112,theti,it,nlobit
7206       delta=0.02d0*pi
7207       escloc=0.0D0
7208       do i=loc_start,loc_end
7209         if (itype(i).eq.ntyp1) cycle
7210         costtab(i+1) =dcos(theta(i+1))
7211         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7212         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7213         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7214         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7215         cosfac=dsqrt(cosfac2)
7216         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7217         sinfac=dsqrt(sinfac2)
7218         it=iabs(itype(i))
7219         if (it.eq.10) goto 1
7220 c
7221 C  Compute the axes of tghe local cartesian coordinates system; store in
7222 c   x_prime, y_prime and z_prime
7223 c
7224         do j=1,3
7225           x_prime(j) = 0.00
7226           y_prime(j) = 0.00
7227           z_prime(j) = 0.00
7228         enddo
7229 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7230 C     &   dc_norm(3,i+nres)
7231         do j = 1,3
7232           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7233           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7234         enddo
7235         do j = 1,3
7236           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7237         enddo
7238 c       write (2,*) "i",i
7239 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7240 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7241 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7242 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7243 c      & " xy",scalar(x_prime(1),y_prime(1)),
7244 c      & " xz",scalar(x_prime(1),z_prime(1)),
7245 c      & " yy",scalar(y_prime(1),y_prime(1)),
7246 c      & " yz",scalar(y_prime(1),z_prime(1)),
7247 c      & " zz",scalar(z_prime(1),z_prime(1))
7248 c
7249 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7250 C to local coordinate system. Store in xx, yy, zz.
7251 c
7252         xx=0.0d0
7253         yy=0.0d0
7254         zz=0.0d0
7255         do j = 1,3
7256           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7257           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7258           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7259         enddo
7260
7261         xxtab(i)=xx
7262         yytab(i)=yy
7263         zztab(i)=zz
7264 C
7265 C Compute the energy of the ith side cbain
7266 C
7267 c        write (2,*) "xx",xx," yy",yy," zz",zz
7268         it=iabs(itype(i))
7269         do j = 1,65
7270           x(j) = sc_parmin(j,it)
7271         enddo
7272 #ifdef CHECK_COORD
7273 Cc diagnostics - remove later
7274         xx1 = dcos(alph(2))
7275         yy1 = dsin(alph(2))*dcos(omeg(2))
7276         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7277         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7278      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7279      &    xx1,yy1,zz1
7280 C,"  --- ", xx_w,yy_w,zz_w
7281 c end diagnostics
7282 #endif
7283         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7284      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7285      &   + x(10)*yy*zz
7286         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7287      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7288      & + x(20)*yy*zz
7289         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7290      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7291      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7292      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7293      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7294      &  +x(40)*xx*yy*zz
7295         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7296      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7297      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7298      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7299      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7300      &  +x(60)*xx*yy*zz
7301         dsc_i   = 0.743d0+x(61)
7302         dp2_i   = 1.9d0+x(62)
7303         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7304      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7305         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7306      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7307         s1=(1+x(63))/(0.1d0 + dscp1)
7308         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7309         s2=(1+x(65))/(0.1d0 + dscp2)
7310         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7311         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7312      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7313 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7314 c     &   sumene4,
7315 c     &   dscp1,dscp2,sumene
7316 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7317         escloc = escloc + sumene
7318 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7319 c     & ,zz,xx,yy
7320 c#define DEBUG
7321 #ifdef DEBUG
7322 C
7323 C This section to check the numerical derivatives of the energy of ith side
7324 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7325 C #define DEBUG in the code to turn it on.
7326 C
7327         write (2,*) "sumene               =",sumene
7328         aincr=1.0d-7
7329         xxsave=xx
7330         xx=xx+aincr
7331         write (2,*) xx,yy,zz
7332         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7333         de_dxx_num=(sumenep-sumene)/aincr
7334         xx=xxsave
7335         write (2,*) "xx+ sumene from enesc=",sumenep
7336         yysave=yy
7337         yy=yy+aincr
7338         write (2,*) xx,yy,zz
7339         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7340         de_dyy_num=(sumenep-sumene)/aincr
7341         yy=yysave
7342         write (2,*) "yy+ sumene from enesc=",sumenep
7343         zzsave=zz
7344         zz=zz+aincr
7345         write (2,*) xx,yy,zz
7346         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7347         de_dzz_num=(sumenep-sumene)/aincr
7348         zz=zzsave
7349         write (2,*) "zz+ sumene from enesc=",sumenep
7350         costsave=cost2tab(i+1)
7351         sintsave=sint2tab(i+1)
7352         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7353         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7354         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7355         de_dt_num=(sumenep-sumene)/aincr
7356         write (2,*) " t+ sumene from enesc=",sumenep
7357         cost2tab(i+1)=costsave
7358         sint2tab(i+1)=sintsave
7359 C End of diagnostics section.
7360 #endif
7361 C
7362 C Compute the gradient of esc
7363 C
7364 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7365         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7366         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7367         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7368         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7369         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7370         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7371         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7372         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7373         pom1=(sumene3*sint2tab(i+1)+sumene1)
7374      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7375         pom2=(sumene4*cost2tab(i+1)+sumene2)
7376      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7377         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7378         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7379      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7380      &  +x(40)*yy*zz
7381         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7382         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7383      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7384      &  +x(60)*yy*zz
7385         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7386      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7387      &        +(pom1+pom2)*pom_dx
7388 #ifdef DEBUG
7389         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7390 #endif
7391 C
7392         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7393         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7394      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7395      &  +x(40)*xx*zz
7396         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7397         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7398      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7399      &  +x(59)*zz**2 +x(60)*xx*zz
7400         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7401      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7402      &        +(pom1-pom2)*pom_dy
7403 #ifdef DEBUG
7404         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7405 #endif
7406 C
7407         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7408      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7409      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7410      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7411      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7412      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7413      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7414      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7415 #ifdef DEBUG
7416         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7417 #endif
7418 C
7419         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7420      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7421      &  +pom1*pom_dt1+pom2*pom_dt2
7422 #ifdef DEBUG
7423         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7424 #endif
7425 c#undef DEBUG
7426 c
7427 C
7428        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7429        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7430        cosfac2xx=cosfac2*xx
7431        sinfac2yy=sinfac2*yy
7432        do k = 1,3
7433          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7434      &      vbld_inv(i+1)
7435          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7436      &      vbld_inv(i)
7437          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7438          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7439 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7440 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7441 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7442 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7443          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7444          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7445          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7446          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7447          dZZ_Ci1(k)=0.0d0
7448          dZZ_Ci(k)=0.0d0
7449          do j=1,3
7450            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7451      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7452            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7453      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7454          enddo
7455
7456          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7457          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7458          dZZ_XYZ(k)=vbld_inv(i+nres)*
7459      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7460 c
7461          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7462          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7463        enddo
7464
7465        do k=1,3
7466          dXX_Ctab(k,i)=dXX_Ci(k)
7467          dXX_C1tab(k,i)=dXX_Ci1(k)
7468          dYY_Ctab(k,i)=dYY_Ci(k)
7469          dYY_C1tab(k,i)=dYY_Ci1(k)
7470          dZZ_Ctab(k,i)=dZZ_Ci(k)
7471          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7472          dXX_XYZtab(k,i)=dXX_XYZ(k)
7473          dYY_XYZtab(k,i)=dYY_XYZ(k)
7474          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7475        enddo
7476
7477        do k = 1,3
7478 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7479 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7480 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7481 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7482 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7483 c     &    dt_dci(k)
7484 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7485 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7486          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7487      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7488          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7489      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7490          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7491      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7492        enddo
7493 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7494 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7495
7496 C to check gradient call subroutine check_grad
7497
7498     1 continue
7499       enddo
7500       return
7501       end
7502 c------------------------------------------------------------------------------
7503       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7504       implicit none
7505       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7506      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7507       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7508      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7509      &   + x(10)*yy*zz
7510       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7511      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7512      & + x(20)*yy*zz
7513       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7514      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7515      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7516      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7517      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7518      &  +x(40)*xx*yy*zz
7519       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7520      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7521      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7522      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7523      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7524      &  +x(60)*xx*yy*zz
7525       dsc_i   = 0.743d0+x(61)
7526       dp2_i   = 1.9d0+x(62)
7527       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7528      &          *(xx*cost2+yy*sint2))
7529       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7530      &          *(xx*cost2-yy*sint2))
7531       s1=(1+x(63))/(0.1d0 + dscp1)
7532       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7533       s2=(1+x(65))/(0.1d0 + dscp2)
7534       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7535       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7536      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7537       enesc=sumene
7538       return
7539       end
7540 #endif
7541 c------------------------------------------------------------------------------
7542       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7543 C
7544 C This procedure calculates two-body contact function g(rij) and its derivative:
7545 C
7546 C           eps0ij                                     !       x < -1
7547 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7548 C            0                                         !       x > 1
7549 C
7550 C where x=(rij-r0ij)/delta
7551 C
7552 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7553 C
7554       implicit none
7555       double precision rij,r0ij,eps0ij,fcont,fprimcont
7556       double precision x,x2,x4,delta
7557 c     delta=0.02D0*r0ij
7558 c      delta=0.2D0*r0ij
7559       x=(rij-r0ij)/delta
7560       if (x.lt.-1.0D0) then
7561         fcont=eps0ij
7562         fprimcont=0.0D0
7563       else if (x.le.1.0D0) then
7564         x2=x*x
7565         x4=x2*x2
7566         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7567         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7568       else
7569         fcont=0.0D0
7570         fprimcont=0.0D0
7571       endif
7572       return
7573       end
7574 c------------------------------------------------------------------------------
7575       subroutine splinthet(theti,delta,ss,ssder)
7576       implicit real*8 (a-h,o-z)
7577       include 'DIMENSIONS'
7578       include 'COMMON.VAR'
7579       include 'COMMON.GEO'
7580       thetup=pi-delta
7581       thetlow=delta
7582       if (theti.gt.pipol) then
7583         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7584       else
7585         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7586         ssder=-ssder
7587       endif
7588       return
7589       end
7590 c------------------------------------------------------------------------------
7591       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7592       implicit none
7593       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7594       double precision ksi,ksi2,ksi3,a1,a2,a3
7595       a1=fprim0*delta/(f1-f0)
7596       a2=3.0d0-2.0d0*a1
7597       a3=a1-2.0d0
7598       ksi=(x-x0)/delta
7599       ksi2=ksi*ksi
7600       ksi3=ksi2*ksi
7601       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7602       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7603       return
7604       end
7605 c------------------------------------------------------------------------------
7606       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7607       implicit none
7608       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7609       double precision ksi,ksi2,ksi3,a1,a2,a3
7610       ksi=(x-x0)/delta
7611       ksi2=ksi*ksi
7612       ksi3=ksi2*ksi
7613       a1=fprim0x*delta
7614       a2=3*(f1x-f0x)-2*fprim0x*delta
7615       a3=fprim0x*delta-2*(f1x-f0x)
7616       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7617       return
7618       end
7619 C-----------------------------------------------------------------------------
7620 #ifdef CRYST_TOR
7621 C-----------------------------------------------------------------------------
7622       subroutine etor(etors,edihcnstr)
7623       implicit real*8 (a-h,o-z)
7624       include 'DIMENSIONS'
7625       include 'COMMON.VAR'
7626       include 'COMMON.GEO'
7627       include 'COMMON.LOCAL'
7628       include 'COMMON.TORSION'
7629       include 'COMMON.INTERACT'
7630       include 'COMMON.DERIV'
7631       include 'COMMON.CHAIN'
7632       include 'COMMON.NAMES'
7633       include 'COMMON.IOUNITS'
7634       include 'COMMON.FFIELD'
7635       include 'COMMON.TORCNSTR'
7636       include 'COMMON.CONTROL'
7637       logical lprn
7638 C Set lprn=.true. for debugging
7639       lprn=.false.
7640 c      lprn=.true.
7641       etors=0.0D0
7642       do i=iphi_start,iphi_end
7643       etors_ii=0.0D0
7644         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7645      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7646         itori=itortyp(itype(i-2))
7647         itori1=itortyp(itype(i-1))
7648         phii=phi(i)
7649         gloci=0.0D0
7650 C Proline-Proline pair is a special case...
7651         if (itori.eq.3 .and. itori1.eq.3) then
7652           if (phii.gt.-dwapi3) then
7653             cosphi=dcos(3*phii)
7654             fac=1.0D0/(1.0D0-cosphi)
7655             etorsi=v1(1,3,3)*fac
7656             etorsi=etorsi+etorsi
7657             etors=etors+etorsi-v1(1,3,3)
7658             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7659             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7660           endif
7661           do j=1,3
7662             v1ij=v1(j+1,itori,itori1)
7663             v2ij=v2(j+1,itori,itori1)
7664             cosphi=dcos(j*phii)
7665             sinphi=dsin(j*phii)
7666             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7667             if (energy_dec) etors_ii=etors_ii+
7668      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7669             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7670           enddo
7671         else
7672           do j=1,nterm_old
7673             v1ij=v1(j,itori,itori1)
7674             v2ij=v2(j,itori,itori1)
7675             cosphi=dcos(j*phii)
7676             sinphi=dsin(j*phii)
7677             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7678             if (energy_dec) etors_ii=etors_ii+
7679      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7680             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7681           enddo
7682         endif
7683         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7684              'etor',i,etors_ii
7685         if (lprn)
7686      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7687      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7688      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7689         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7690 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7691       enddo
7692 ! 6/20/98 - dihedral angle constraints
7693       edihcnstr=0.0d0
7694       do i=1,ndih_constr
7695         itori=idih_constr(i)
7696         phii=phi(itori)
7697         difi=phii-phi0(i)
7698         if (difi.gt.drange(i)) then
7699           difi=difi-drange(i)
7700           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7701           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7702         else if (difi.lt.-drange(i)) then
7703           difi=difi+drange(i)
7704           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7705           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7706         endif
7707 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7708 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7709       enddo
7710 !      write (iout,*) 'edihcnstr',edihcnstr
7711       return
7712       end
7713 c------------------------------------------------------------------------------
7714       subroutine etor_d(etors_d)
7715       etors_d=0.0d0
7716       return
7717       end
7718 c----------------------------------------------------------------------------
7719 #else
7720       subroutine etor(etors,edihcnstr)
7721       implicit real*8 (a-h,o-z)
7722       include 'DIMENSIONS'
7723       include 'COMMON.VAR'
7724       include 'COMMON.GEO'
7725       include 'COMMON.LOCAL'
7726       include 'COMMON.TORSION'
7727       include 'COMMON.INTERACT'
7728       include 'COMMON.DERIV'
7729       include 'COMMON.CHAIN'
7730       include 'COMMON.NAMES'
7731       include 'COMMON.IOUNITS'
7732       include 'COMMON.FFIELD'
7733       include 'COMMON.TORCNSTR'
7734       include 'COMMON.CONTROL'
7735       logical lprn
7736 C Set lprn=.true. for debugging
7737       lprn=.false.
7738 c     lprn=.true.
7739       etors=0.0D0
7740       do i=iphi_start,iphi_end
7741 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7742 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7743 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7744 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7745         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7746      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7747 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7748 C For introducing the NH3+ and COO- group please check the etor_d for reference
7749 C and guidance
7750         etors_ii=0.0D0
7751          if (iabs(itype(i)).eq.20) then
7752          iblock=2
7753          else
7754          iblock=1
7755          endif
7756         itori=itortyp(itype(i-2))
7757         itori1=itortyp(itype(i-1))
7758         phii=phi(i)
7759         gloci=0.0D0
7760 C Regular cosine and sine terms
7761         do j=1,nterm(itori,itori1,iblock)
7762           v1ij=v1(j,itori,itori1,iblock)
7763           v2ij=v2(j,itori,itori1,iblock)
7764           cosphi=dcos(j*phii)
7765           sinphi=dsin(j*phii)
7766           etors=etors+v1ij*cosphi+v2ij*sinphi
7767           if (energy_dec) etors_ii=etors_ii+
7768      &                v1ij*cosphi+v2ij*sinphi
7769           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7770         enddo
7771 C Lorentz terms
7772 C                         v1
7773 C  E = SUM ----------------------------------- - v1
7774 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7775 C
7776         cosphi=dcos(0.5d0*phii)
7777         sinphi=dsin(0.5d0*phii)
7778         do j=1,nlor(itori,itori1,iblock)
7779           vl1ij=vlor1(j,itori,itori1)
7780           vl2ij=vlor2(j,itori,itori1)
7781           vl3ij=vlor3(j,itori,itori1)
7782           pom=vl2ij*cosphi+vl3ij*sinphi
7783           pom1=1.0d0/(pom*pom+1.0d0)
7784           etors=etors+vl1ij*pom1
7785           if (energy_dec) etors_ii=etors_ii+
7786      &                vl1ij*pom1
7787           pom=-pom*pom1*pom1
7788           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7789         enddo
7790 C Subtract the constant term
7791         etors=etors-v0(itori,itori1,iblock)
7792           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7793      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7794         if (lprn)
7795      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7796      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7797      &  (v1(j,itori,itori1,iblock),j=1,6),
7798      &  (v2(j,itori,itori1,iblock),j=1,6)
7799         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7800 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7801       enddo
7802 ! 6/20/98 - dihedral angle constraints
7803       edihcnstr=0.0d0
7804 c      do i=1,ndih_constr
7805       do i=idihconstr_start,idihconstr_end
7806         itori=idih_constr(i)
7807         phii=phi(itori)
7808         difi=pinorm(phii-phi0(i))
7809         if (difi.gt.drange(i)) then
7810           difi=difi-drange(i)
7811           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7812           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7813         else if (difi.lt.-drange(i)) then
7814           difi=difi+drange(i)
7815           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7816           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7817         else
7818           difi=0.0
7819         endif
7820        if (energy_dec) then
7821         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7822      &    i,itori,rad2deg*phii,
7823      &    rad2deg*phi0(i),  rad2deg*drange(i),
7824      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7825         endif
7826       enddo
7827 cd       write (iout,*) 'edihcnstr',edihcnstr
7828       return
7829       end
7830 c----------------------------------------------------------------------------
7831       subroutine etor_d(etors_d)
7832 C 6/23/01 Compute double torsional energy
7833       implicit real*8 (a-h,o-z)
7834       include 'DIMENSIONS'
7835       include 'COMMON.VAR'
7836       include 'COMMON.GEO'
7837       include 'COMMON.LOCAL'
7838       include 'COMMON.TORSION'
7839       include 'COMMON.INTERACT'
7840       include 'COMMON.DERIV'
7841       include 'COMMON.CHAIN'
7842       include 'COMMON.NAMES'
7843       include 'COMMON.IOUNITS'
7844       include 'COMMON.FFIELD'
7845       include 'COMMON.TORCNSTR'
7846       logical lprn
7847 C Set lprn=.true. for debugging
7848       lprn=.false.
7849 c     lprn=.true.
7850       etors_d=0.0D0
7851 c      write(iout,*) "a tu??"
7852       do i=iphid_start,iphid_end
7853 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7854 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7855 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7856 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7857 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7858          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7859      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7860      &  (itype(i+1).eq.ntyp1)) cycle
7861 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7862         itori=itortyp(itype(i-2))
7863         itori1=itortyp(itype(i-1))
7864         itori2=itortyp(itype(i))
7865         phii=phi(i)
7866         phii1=phi(i+1)
7867         gloci1=0.0D0
7868         gloci2=0.0D0
7869         iblock=1
7870         if (iabs(itype(i+1)).eq.20) iblock=2
7871 C Iblock=2 Proline type
7872 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7873 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7874 C        if (itype(i+1).eq.ntyp1) iblock=3
7875 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7876 C IS or IS NOT need for this
7877 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7878 C        is (itype(i-3).eq.ntyp1) ntblock=2
7879 C        ntblock is N-terminal blocking group
7880
7881 C Regular cosine and sine terms
7882         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7883 C Example of changes for NH3+ blocking group
7884 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7885 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7886           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7887           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7888           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7889           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7890           cosphi1=dcos(j*phii)
7891           sinphi1=dsin(j*phii)
7892           cosphi2=dcos(j*phii1)
7893           sinphi2=dsin(j*phii1)
7894           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7895      &     v2cij*cosphi2+v2sij*sinphi2
7896           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7897           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7898         enddo
7899         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7900           do l=1,k-1
7901             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7902             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7903             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7904             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7905             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7906             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7907             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7908             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7909             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7910      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7911             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7912      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7913             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7914      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7915           enddo
7916         enddo
7917         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7918         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7919       enddo
7920       return
7921       end
7922 #endif
7923 C----------------------------------------------------------------------------------
7924 C The rigorous attempt to derive energy function
7925       subroutine etor_kcc(etors,edihcnstr)
7926       implicit real*8 (a-h,o-z)
7927       include 'DIMENSIONS'
7928       include 'COMMON.VAR'
7929       include 'COMMON.GEO'
7930       include 'COMMON.LOCAL'
7931       include 'COMMON.TORSION'
7932       include 'COMMON.INTERACT'
7933       include 'COMMON.DERIV'
7934       include 'COMMON.CHAIN'
7935       include 'COMMON.NAMES'
7936       include 'COMMON.IOUNITS'
7937       include 'COMMON.FFIELD'
7938       include 'COMMON.TORCNSTR'
7939       include 'COMMON.CONTROL'
7940       logical lprn
7941 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7942 C Set lprn=.true. for debugging
7943       lprn=.false.
7944 c     lprn=.true.
7945 C      print *,"wchodze kcc"
7946       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7947       if (tor_mode.ne.2) then
7948       etors=0.0D0
7949       endif
7950       do i=iphi_start,iphi_end
7951 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7952 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7953 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7954 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7955         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7956      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7957         itori=itortyp_kcc(itype(i-2))
7958         itori1=itortyp_kcc(itype(i-1))
7959         phii=phi(i)
7960         glocig=0.0D0
7961         glocit1=0.0d0
7962         glocit2=0.0d0
7963         sumnonchebyshev=0.0d0
7964         sumchebyshev=0.0d0
7965 C to avoid multiple devision by 2
7966 c        theti22=0.5d0*theta(i)
7967 C theta 12 is the theta_1 /2
7968 C theta 22 is theta_2 /2
7969 c        theti12=0.5d0*theta(i-1)
7970 C and appropriate sinus function
7971         sinthet1=dsin(theta(i-1))
7972         sinthet2=dsin(theta(i))
7973         costhet1=dcos(theta(i-1))
7974         costhet2=dcos(theta(i))
7975 c Cosines of halves thetas
7976         costheti12=0.5d0*(1.0d0+costhet1)
7977         costheti22=0.5d0*(1.0d0+costhet2)
7978 C to speed up lets store its mutliplication
7979         sint1t2=sinthet2*sinthet1
7980         sint1t2n=1.0d0
7981 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7982 C +d_n*sin(n*gamma)) *
7983 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7984 C we have two sum 1) Non-Chebyshev which is with n and gamma
7985         etori=0.0d0
7986         do j=1,nterm_kcc(itori,itori1)
7987
7988           nval=nterm_kcc_Tb(itori,itori1)
7989           v1ij=v1_kcc(j,itori,itori1)
7990           v2ij=v2_kcc(j,itori,itori1)
7991 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7992 C v1ij is c_n and d_n in euation above
7993           cosphi=dcos(j*phii)
7994           sinphi=dsin(j*phii)
7995           sint1t2n1=sint1t2n
7996           sint1t2n=sint1t2n*sint1t2
7997           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7998      &        costheti12)
7999           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8000      &        v11_chyb(1,j,itori,itori1),costheti12)
8001 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
8002 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
8003           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
8004      &        costheti22)
8005           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8006      &        v21_chyb(1,j,itori,itori1),costheti22)
8007 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
8008 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
8009           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
8010      &        costheti12)
8011           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8012      &        v12_chyb(1,j,itori,itori1),costheti12)
8013 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8014 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8015           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8016      &        costheti22)
8017           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8018      &        v22_chyb(1,j,itori,itori1),costheti22)
8019 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8020 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8021 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8022 C          if (energy_dec) etors_ii=etors_ii+
8023 C     &                v1ij*cosphi+v2ij*sinphi
8024 C glocig is the gradient local i site in gamma
8025           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8026           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8027           etori=etori+sint1t2n*(actval1+actval2)
8028           glocig=glocig+
8029      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8030      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8031 C now gradient over theta_1
8032           glocit1=glocit1+
8033      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8034      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8035           glocit2=glocit2+
8036      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8037      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8038
8039 C now the Czebyshev polinominal sum
8040 c        do k=1,nterm_kcc_Tb(itori,itori1)
8041 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
8042 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
8043 C         thybt1(k)=0.0
8044 C         thybt2(k)=0.0
8045 c        enddo
8046 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8047 C     &         gradtschebyshev
8048 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8049 C     &         dcos(theti22)**2),
8050 C     &         dsin(theti22)
8051
8052 C now overal sumation
8053 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8054         enddo ! j
8055         etors=etors+etori
8056 C derivative over gamma
8057         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8058 C derivative over theta1
8059         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8060 C now derivative over theta2
8061         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8062         if (lprn)
8063      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8064      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8065       enddo
8066 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8067 ! 6/20/98 - dihedral angle constraints
8068       if (tor_mode.ne.2) then
8069       edihcnstr=0.0d0
8070 c      do i=1,ndih_constr
8071       do i=idihconstr_start,idihconstr_end
8072         itori=idih_constr(i)
8073         phii=phi(itori)
8074         difi=pinorm(phii-phi0(i))
8075         if (difi.gt.drange(i)) then
8076           difi=difi-drange(i)
8077           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8078           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8079         else if (difi.lt.-drange(i)) then
8080           difi=difi+drange(i)
8081           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8082           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8083         else
8084           difi=0.0
8085         endif
8086        enddo
8087        endif
8088       return
8089       end
8090
8091 C The rigorous attempt to derive energy function
8092       subroutine ebend_kcc(etheta,ethetacnstr)
8093
8094       implicit real*8 (a-h,o-z)
8095       include 'DIMENSIONS'
8096       include 'COMMON.VAR'
8097       include 'COMMON.GEO'
8098       include 'COMMON.LOCAL'
8099       include 'COMMON.TORSION'
8100       include 'COMMON.INTERACT'
8101       include 'COMMON.DERIV'
8102       include 'COMMON.CHAIN'
8103       include 'COMMON.NAMES'
8104       include 'COMMON.IOUNITS'
8105       include 'COMMON.FFIELD'
8106       include 'COMMON.TORCNSTR'
8107       include 'COMMON.CONTROL'
8108       logical lprn
8109       double precision thybt1(maxtermkcc)
8110 C Set lprn=.true. for debugging
8111       lprn=.false.
8112 c     lprn=.true.
8113 C      print *,"wchodze kcc"
8114       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8115       if (tor_mode.ne.2) etheta=0.0D0
8116       do i=ithet_start,ithet_end
8117 c        print *,i,itype(i-1),itype(i),itype(i-2)
8118         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8119      &  .or.itype(i).eq.ntyp1) cycle
8120          iti=itortyp_kcc(itype(i-1))
8121         sinthet=dsin(theta(i)/2.0d0)
8122         costhet=dcos(theta(i)/2.0d0)
8123          do j=1,nbend_kcc_Tb(iti)
8124           thybt1(j)=v1bend_chyb(j,iti)
8125          enddo
8126          sumth1thyb=tschebyshev
8127      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8128         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8129      &    sumth1thyb
8130         ihelp=nbend_kcc_Tb(iti)-1
8131         gradthybt1=gradtschebyshev
8132      &         (0,ihelp,thybt1(1),costhet)
8133         etheta=etheta+sumth1thyb
8134 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8135         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8136      &   gradthybt1*sinthet*(-0.5d0)
8137       enddo
8138       if (tor_mode.ne.2) then
8139       ethetacnstr=0.0d0
8140 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8141       do i=ithetaconstr_start,ithetaconstr_end
8142         itheta=itheta_constr(i)
8143         thetiii=theta(itheta)
8144         difi=pinorm(thetiii-theta_constr0(i))
8145         if (difi.gt.theta_drange(i)) then
8146           difi=difi-theta_drange(i)
8147           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8148           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8149      &    +for_thet_constr(i)*difi**3
8150         else if (difi.lt.-drange(i)) then
8151           difi=difi+drange(i)
8152           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8153           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8154      &    +for_thet_constr(i)*difi**3
8155         else
8156           difi=0.0
8157         endif
8158        if (energy_dec) then
8159         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8160      &    i,itheta,rad2deg*thetiii,
8161      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8162      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8163      &    gloc(itheta+nphi-2,icg)
8164         endif
8165       enddo
8166       endif
8167       return
8168       end
8169 c------------------------------------------------------------------------------
8170       subroutine eback_sc_corr(esccor)
8171 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8172 c        conformational states; temporarily implemented as differences
8173 c        between UNRES torsional potentials (dependent on three types of
8174 c        residues) and the torsional potentials dependent on all 20 types
8175 c        of residues computed from AM1  energy surfaces of terminally-blocked
8176 c        amino-acid residues.
8177       implicit real*8 (a-h,o-z)
8178       include 'DIMENSIONS'
8179       include 'COMMON.VAR'
8180       include 'COMMON.GEO'
8181       include 'COMMON.LOCAL'
8182       include 'COMMON.TORSION'
8183       include 'COMMON.SCCOR'
8184       include 'COMMON.INTERACT'
8185       include 'COMMON.DERIV'
8186       include 'COMMON.CHAIN'
8187       include 'COMMON.NAMES'
8188       include 'COMMON.IOUNITS'
8189       include 'COMMON.FFIELD'
8190       include 'COMMON.CONTROL'
8191       logical lprn
8192 C Set lprn=.true. for debugging
8193       lprn=.false.
8194 c      lprn=.true.
8195 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8196       esccor=0.0D0
8197       do i=itau_start,itau_end
8198         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8199         esccor_ii=0.0D0
8200         isccori=isccortyp(itype(i-2))
8201         isccori1=isccortyp(itype(i-1))
8202 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8203         phii=phi(i)
8204         do intertyp=1,3 !intertyp
8205 cc Added 09 May 2012 (Adasko)
8206 cc  Intertyp means interaction type of backbone mainchain correlation:
8207 c   1 = SC...Ca...Ca...Ca
8208 c   2 = Ca...Ca...Ca...SC
8209 c   3 = SC...Ca...Ca...SCi
8210         gloci=0.0D0
8211         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8212      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8213      &      (itype(i-1).eq.ntyp1)))
8214      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8215      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8216      &     .or.(itype(i).eq.ntyp1)))
8217      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8218      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8219      &      (itype(i-3).eq.ntyp1)))) cycle
8220         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8221         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8222      & cycle
8223        do j=1,nterm_sccor(isccori,isccori1)
8224           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8225           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8226           cosphi=dcos(j*tauangle(intertyp,i))
8227           sinphi=dsin(j*tauangle(intertyp,i))
8228           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8229           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8230         enddo
8231         if (energy_dec) write(iout,'(a9,2i4,f8.3,3i4)') "esccor",i,j,
8232      & esccor,intertyp,
8233      & isccori, isccori1
8234 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8235         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8236         if (lprn)
8237      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8238      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8239      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8240      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8241         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8242        enddo !intertyp
8243       enddo
8244
8245       return
8246       end
8247 c----------------------------------------------------------------------------
8248       subroutine multibody(ecorr)
8249 C This subroutine calculates multi-body contributions to energy following
8250 C the idea of Skolnick et al. If side chains I and J make a contact and
8251 C at the same time side chains I+1 and J+1 make a contact, an extra
8252 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8253       implicit real*8 (a-h,o-z)
8254       include 'DIMENSIONS'
8255       include 'COMMON.IOUNITS'
8256       include 'COMMON.DERIV'
8257       include 'COMMON.INTERACT'
8258       include 'COMMON.CONTACTS'
8259       double precision gx(3),gx1(3)
8260       logical lprn
8261
8262 C Set lprn=.true. for debugging
8263       lprn=.false.
8264
8265       if (lprn) then
8266         write (iout,'(a)') 'Contact function values:'
8267         do i=nnt,nct-2
8268           write (iout,'(i2,20(1x,i2,f10.5))')
8269      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8270         enddo
8271       endif
8272       ecorr=0.0D0
8273       do i=nnt,nct
8274         do j=1,3
8275           gradcorr(j,i)=0.0D0
8276           gradxorr(j,i)=0.0D0
8277         enddo
8278       enddo
8279       do i=nnt,nct-2
8280
8281         DO ISHIFT = 3,4
8282
8283         i1=i+ishift
8284         num_conti=num_cont(i)
8285         num_conti1=num_cont(i1)
8286         do jj=1,num_conti
8287           j=jcont(jj,i)
8288           do kk=1,num_conti1
8289             j1=jcont(kk,i1)
8290             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8291 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8292 cd   &                   ' ishift=',ishift
8293 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8294 C The system gains extra energy.
8295               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8296             endif   ! j1==j+-ishift
8297           enddo     ! kk
8298         enddo       ! jj
8299
8300         ENDDO ! ISHIFT
8301
8302       enddo         ! i
8303       return
8304       end
8305 c------------------------------------------------------------------------------
8306       double precision function esccorr(i,j,k,l,jj,kk)
8307       implicit real*8 (a-h,o-z)
8308       include 'DIMENSIONS'
8309       include 'COMMON.IOUNITS'
8310       include 'COMMON.DERIV'
8311       include 'COMMON.INTERACT'
8312       include 'COMMON.CONTACTS'
8313       include 'COMMON.SHIELD'
8314       double precision gx(3),gx1(3)
8315       logical lprn
8316       lprn=.false.
8317       eij=facont(jj,i)
8318       ekl=facont(kk,k)
8319 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8320 C Calculate the multi-body contribution to energy.
8321 C Calculate multi-body contributions to the gradient.
8322 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8323 cd   & k,l,(gacont(m,kk,k),m=1,3)
8324       do m=1,3
8325         gx(m) =ekl*gacont(m,jj,i)
8326         gx1(m)=eij*gacont(m,kk,k)
8327         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8328         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8329         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8330         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8331       enddo
8332       do m=i,j-1
8333         do ll=1,3
8334           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8335         enddo
8336       enddo
8337       do m=k,l-1
8338         do ll=1,3
8339           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8340         enddo
8341       enddo
8342       esccorr=-eij*ekl
8343       return
8344       end
8345 c------------------------------------------------------------------------------
8346       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8347 C This subroutine calculates multi-body contributions to hydrogen-bonding
8348       implicit real*8 (a-h,o-z)
8349       include 'DIMENSIONS'
8350       include 'COMMON.IOUNITS'
8351 #ifdef MPI
8352       include "mpif.h"
8353       parameter (max_cont=maxconts)
8354       parameter (max_dim=26)
8355       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8356       double precision zapas(max_dim,maxconts,max_fg_procs),
8357      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8358       common /przechowalnia/ zapas
8359       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8360      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8361 #endif
8362       include 'COMMON.SETUP'
8363       include 'COMMON.FFIELD'
8364       include 'COMMON.DERIV'
8365       include 'COMMON.INTERACT'
8366       include 'COMMON.CONTACTS'
8367       include 'COMMON.CONTROL'
8368       include 'COMMON.LOCAL'
8369       double precision gx(3),gx1(3),time00
8370       logical lprn,ldone
8371
8372 C Set lprn=.true. for debugging
8373       lprn=.false.
8374 #ifdef MPI
8375       n_corr=0
8376       n_corr1=0
8377       if (nfgtasks.le.1) goto 30
8378       if (lprn) then
8379         write (iout,'(a)') 'Contact function values before RECEIVE:'
8380         do i=nnt,nct-2
8381           write (iout,'(2i3,50(1x,i2,f5.2))')
8382      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8383      &    j=1,num_cont_hb(i))
8384         enddo
8385       endif
8386       call flush(iout)
8387       do i=1,ntask_cont_from
8388         ncont_recv(i)=0
8389       enddo
8390       do i=1,ntask_cont_to
8391         ncont_sent(i)=0
8392       enddo
8393 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8394 c     & ntask_cont_to
8395 C Make the list of contacts to send to send to other procesors
8396 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8397 c      call flush(iout)
8398       do i=iturn3_start,iturn3_end
8399 c        write (iout,*) "make contact list turn3",i," num_cont",
8400 c     &    num_cont_hb(i)
8401         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8402       enddo
8403       do i=iturn4_start,iturn4_end
8404 c        write (iout,*) "make contact list turn4",i," num_cont",
8405 c     &   num_cont_hb(i)
8406         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8407       enddo
8408       do ii=1,nat_sent
8409         i=iat_sent(ii)
8410 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8411 c     &    num_cont_hb(i)
8412         do j=1,num_cont_hb(i)
8413         do k=1,4
8414           jjc=jcont_hb(j,i)
8415           iproc=iint_sent_local(k,jjc,ii)
8416 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8417           if (iproc.gt.0) then
8418             ncont_sent(iproc)=ncont_sent(iproc)+1
8419             nn=ncont_sent(iproc)
8420             zapas(1,nn,iproc)=i
8421             zapas(2,nn,iproc)=jjc
8422             zapas(3,nn,iproc)=facont_hb(j,i)
8423             zapas(4,nn,iproc)=ees0p(j,i)
8424             zapas(5,nn,iproc)=ees0m(j,i)
8425             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8426             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8427             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8428             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8429             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8430             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8431             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8432             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8433             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8434             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8435             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8436             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8437             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8438             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8439             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8440             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8441             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8442             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8443             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8444             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8445             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8446           endif
8447         enddo
8448         enddo
8449       enddo
8450       if (lprn) then
8451       write (iout,*)
8452      &  "Numbers of contacts to be sent to other processors",
8453      &  (ncont_sent(i),i=1,ntask_cont_to)
8454       write (iout,*) "Contacts sent"
8455       do ii=1,ntask_cont_to
8456         nn=ncont_sent(ii)
8457         iproc=itask_cont_to(ii)
8458         write (iout,*) nn," contacts to processor",iproc,
8459      &   " of CONT_TO_COMM group"
8460         do i=1,nn
8461           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8462         enddo
8463       enddo
8464       call flush(iout)
8465       endif
8466       CorrelType=477
8467       CorrelID=fg_rank+1
8468       CorrelType1=478
8469       CorrelID1=nfgtasks+fg_rank+1
8470       ireq=0
8471 C Receive the numbers of needed contacts from other processors
8472       do ii=1,ntask_cont_from
8473         iproc=itask_cont_from(ii)
8474         ireq=ireq+1
8475         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8476      &    FG_COMM,req(ireq),IERR)
8477       enddo
8478 c      write (iout,*) "IRECV ended"
8479 c      call flush(iout)
8480 C Send the number of contacts needed by other processors
8481       do ii=1,ntask_cont_to
8482         iproc=itask_cont_to(ii)
8483         ireq=ireq+1
8484         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8485      &    FG_COMM,req(ireq),IERR)
8486       enddo
8487 c      write (iout,*) "ISEND ended"
8488 c      write (iout,*) "number of requests (nn)",ireq
8489       call flush(iout)
8490       if (ireq.gt.0)
8491      &  call MPI_Waitall(ireq,req,status_array,ierr)
8492 c      write (iout,*)
8493 c     &  "Numbers of contacts to be received from other processors",
8494 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8495 c      call flush(iout)
8496 C Receive contacts
8497       ireq=0
8498       do ii=1,ntask_cont_from
8499         iproc=itask_cont_from(ii)
8500         nn=ncont_recv(ii)
8501 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8502 c     &   " of CONT_TO_COMM group"
8503         call flush(iout)
8504         if (nn.gt.0) then
8505           ireq=ireq+1
8506           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8507      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8508 c          write (iout,*) "ireq,req",ireq,req(ireq)
8509         endif
8510       enddo
8511 C Send the contacts to processors that need them
8512       do ii=1,ntask_cont_to
8513         iproc=itask_cont_to(ii)
8514         nn=ncont_sent(ii)
8515 c        write (iout,*) nn," contacts to processor",iproc,
8516 c     &   " of CONT_TO_COMM group"
8517         if (nn.gt.0) then
8518           ireq=ireq+1
8519           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8520      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8521 c          write (iout,*) "ireq,req",ireq,req(ireq)
8522 c          do i=1,nn
8523 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8524 c          enddo
8525         endif
8526       enddo
8527 c      write (iout,*) "number of requests (contacts)",ireq
8528 c      write (iout,*) "req",(req(i),i=1,4)
8529 c      call flush(iout)
8530       if (ireq.gt.0)
8531      & call MPI_Waitall(ireq,req,status_array,ierr)
8532       do iii=1,ntask_cont_from
8533         iproc=itask_cont_from(iii)
8534         nn=ncont_recv(iii)
8535         if (lprn) then
8536         write (iout,*) "Received",nn," contacts from processor",iproc,
8537      &   " of CONT_FROM_COMM group"
8538         call flush(iout)
8539         do i=1,nn
8540           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8541         enddo
8542         call flush(iout)
8543         endif
8544         do i=1,nn
8545           ii=zapas_recv(1,i,iii)
8546 c Flag the received contacts to prevent double-counting
8547           jj=-zapas_recv(2,i,iii)
8548 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8549 c          call flush(iout)
8550           nnn=num_cont_hb(ii)+1
8551           num_cont_hb(ii)=nnn
8552           jcont_hb(nnn,ii)=jj
8553           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8554           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8555           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8556           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8557           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8558           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8559           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8560           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8561           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8562           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8563           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8564           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8565           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8566           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8567           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8568           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8569           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8570           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8571           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8572           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8573           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8574           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8575           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8576           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8577         enddo
8578       enddo
8579       call flush(iout)
8580       if (lprn) then
8581         write (iout,'(a)') 'Contact function values after receive:'
8582         do i=nnt,nct-2
8583           write (iout,'(2i3,50(1x,i3,f5.2))')
8584      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8585      &    j=1,num_cont_hb(i))
8586         enddo
8587         call flush(iout)
8588       endif
8589    30 continue
8590 #endif
8591       if (lprn) then
8592         write (iout,'(a)') 'Contact function values:'
8593         do i=nnt,nct-2
8594           write (iout,'(2i3,50(1x,i3,f5.2))')
8595      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8596      &    j=1,num_cont_hb(i))
8597         enddo
8598       endif
8599       ecorr=0.0D0
8600 C Remove the loop below after debugging !!!
8601       do i=nnt,nct
8602         do j=1,3
8603           gradcorr(j,i)=0.0D0
8604           gradxorr(j,i)=0.0D0
8605         enddo
8606       enddo
8607 C Calculate the local-electrostatic correlation terms
8608       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8609         i1=i+1
8610         num_conti=num_cont_hb(i)
8611         num_conti1=num_cont_hb(i+1)
8612         do jj=1,num_conti
8613           j=jcont_hb(jj,i)
8614           jp=iabs(j)
8615           do kk=1,num_conti1
8616             j1=jcont_hb(kk,i1)
8617             jp1=iabs(j1)
8618 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8619 c     &         ' jj=',jj,' kk=',kk
8620             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8621      &          .or. j.lt.0 .and. j1.gt.0) .and.
8622      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8623 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8624 C The system gains extra energy.
8625               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8626               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8627      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8628               n_corr=n_corr+1
8629             else if (j1.eq.j) then
8630 C Contacts I-J and I-(J+1) occur simultaneously.
8631 C The system loses extra energy.
8632 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8633             endif
8634           enddo ! kk
8635           do kk=1,num_conti
8636             j1=jcont_hb(kk,i)
8637 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8638 c    &         ' jj=',jj,' kk=',kk
8639             if (j1.eq.j+1) then
8640 C Contacts I-J and (I+1)-J occur simultaneously.
8641 C The system loses extra energy.
8642 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8643             endif ! j1==j+1
8644           enddo ! kk
8645         enddo ! jj
8646       enddo ! i
8647       return
8648       end
8649 c------------------------------------------------------------------------------
8650       subroutine add_hb_contact(ii,jj,itask)
8651       implicit real*8 (a-h,o-z)
8652       include "DIMENSIONS"
8653       include "COMMON.IOUNITS"
8654       integer max_cont
8655       integer max_dim
8656       parameter (max_cont=maxconts)
8657       parameter (max_dim=26)
8658       include "COMMON.CONTACTS"
8659       double precision zapas(max_dim,maxconts,max_fg_procs),
8660      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8661       common /przechowalnia/ zapas
8662       integer i,j,ii,jj,iproc,itask(4),nn
8663 c      write (iout,*) "itask",itask
8664       do i=1,2
8665         iproc=itask(i)
8666         if (iproc.gt.0) then
8667           do j=1,num_cont_hb(ii)
8668             jjc=jcont_hb(j,ii)
8669 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8670             if (jjc.eq.jj) then
8671               ncont_sent(iproc)=ncont_sent(iproc)+1
8672               nn=ncont_sent(iproc)
8673               zapas(1,nn,iproc)=ii
8674               zapas(2,nn,iproc)=jjc
8675               zapas(3,nn,iproc)=facont_hb(j,ii)
8676               zapas(4,nn,iproc)=ees0p(j,ii)
8677               zapas(5,nn,iproc)=ees0m(j,ii)
8678               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8679               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8680               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8681               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8682               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8683               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8684               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8685               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8686               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8687               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8688               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8689               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8690               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8691               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8692               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8693               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8694               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8695               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8696               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8697               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8698               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8699               exit
8700             endif
8701           enddo
8702         endif
8703       enddo
8704       return
8705       end
8706 c------------------------------------------------------------------------------
8707       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8708      &  n_corr1)
8709 C This subroutine calculates multi-body contributions to hydrogen-bonding
8710       implicit real*8 (a-h,o-z)
8711       include 'DIMENSIONS'
8712       include 'COMMON.IOUNITS'
8713 #ifdef MPI
8714       include "mpif.h"
8715       parameter (max_cont=maxconts)
8716       parameter (max_dim=70)
8717       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8718       double precision zapas(max_dim,maxconts,max_fg_procs),
8719      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8720       common /przechowalnia/ zapas
8721       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8722      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8723 #endif
8724       include 'COMMON.SETUP'
8725       include 'COMMON.FFIELD'
8726       include 'COMMON.DERIV'
8727       include 'COMMON.LOCAL'
8728       include 'COMMON.INTERACT'
8729       include 'COMMON.CONTACTS'
8730       include 'COMMON.CHAIN'
8731       include 'COMMON.CONTROL'
8732       include 'COMMON.SHIELD'
8733       double precision gx(3),gx1(3)
8734       integer num_cont_hb_old(maxres)
8735       logical lprn,ldone
8736       double precision eello4,eello5,eelo6,eello_turn6
8737       external eello4,eello5,eello6,eello_turn6
8738 C Set lprn=.true. for debugging
8739       lprn=.false.
8740       eturn6=0.0d0
8741 #ifdef MPI
8742       do i=1,nres
8743         num_cont_hb_old(i)=num_cont_hb(i)
8744       enddo
8745       n_corr=0
8746       n_corr1=0
8747       if (nfgtasks.le.1) goto 30
8748       if (lprn) then
8749         write (iout,'(a)') 'Contact function values before RECEIVE:'
8750         do i=nnt,nct-2
8751           write (iout,'(2i3,50(1x,i2,f5.2))')
8752      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8753      &    j=1,num_cont_hb(i))
8754         enddo
8755       endif
8756       call flush(iout)
8757       do i=1,ntask_cont_from
8758         ncont_recv(i)=0
8759       enddo
8760       do i=1,ntask_cont_to
8761         ncont_sent(i)=0
8762       enddo
8763 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8764 c     & ntask_cont_to
8765 C Make the list of contacts to send to send to other procesors
8766       do i=iturn3_start,iturn3_end
8767 c        write (iout,*) "make contact list turn3",i," num_cont",
8768 c     &    num_cont_hb(i)
8769         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8770       enddo
8771       do i=iturn4_start,iturn4_end
8772 c        write (iout,*) "make contact list turn4",i," num_cont",
8773 c     &   num_cont_hb(i)
8774         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8775       enddo
8776       do ii=1,nat_sent
8777         i=iat_sent(ii)
8778 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8779 c     &    num_cont_hb(i)
8780         do j=1,num_cont_hb(i)
8781         do k=1,4
8782           jjc=jcont_hb(j,i)
8783           iproc=iint_sent_local(k,jjc,ii)
8784 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8785           if (iproc.ne.0) then
8786             ncont_sent(iproc)=ncont_sent(iproc)+1
8787             nn=ncont_sent(iproc)
8788             zapas(1,nn,iproc)=i
8789             zapas(2,nn,iproc)=jjc
8790             zapas(3,nn,iproc)=d_cont(j,i)
8791             ind=3
8792             do kk=1,3
8793               ind=ind+1
8794               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8795             enddo
8796             do kk=1,2
8797               do ll=1,2
8798                 ind=ind+1
8799                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8800               enddo
8801             enddo
8802             do jj=1,5
8803               do kk=1,3
8804                 do ll=1,2
8805                   do mm=1,2
8806                     ind=ind+1
8807                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8808                   enddo
8809                 enddo
8810               enddo
8811             enddo
8812           endif
8813         enddo
8814         enddo
8815       enddo
8816       if (lprn) then
8817       write (iout,*)
8818      &  "Numbers of contacts to be sent to other processors",
8819      &  (ncont_sent(i),i=1,ntask_cont_to)
8820       write (iout,*) "Contacts sent"
8821       do ii=1,ntask_cont_to
8822         nn=ncont_sent(ii)
8823         iproc=itask_cont_to(ii)
8824         write (iout,*) nn," contacts to processor",iproc,
8825      &   " of CONT_TO_COMM group"
8826         do i=1,nn
8827           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8828         enddo
8829       enddo
8830       call flush(iout)
8831       endif
8832       CorrelType=477
8833       CorrelID=fg_rank+1
8834       CorrelType1=478
8835       CorrelID1=nfgtasks+fg_rank+1
8836       ireq=0
8837 C Receive the numbers of needed contacts from other processors
8838       do ii=1,ntask_cont_from
8839         iproc=itask_cont_from(ii)
8840         ireq=ireq+1
8841         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8842      &    FG_COMM,req(ireq),IERR)
8843       enddo
8844 c      write (iout,*) "IRECV ended"
8845 c      call flush(iout)
8846 C Send the number of contacts needed by other processors
8847       do ii=1,ntask_cont_to
8848         iproc=itask_cont_to(ii)
8849         ireq=ireq+1
8850         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8851      &    FG_COMM,req(ireq),IERR)
8852       enddo
8853 c      write (iout,*) "ISEND ended"
8854 c      write (iout,*) "number of requests (nn)",ireq
8855       call flush(iout)
8856       if (ireq.gt.0)
8857      &  call MPI_Waitall(ireq,req,status_array,ierr)
8858 c      write (iout,*)
8859 c     &  "Numbers of contacts to be received from other processors",
8860 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8861 c      call flush(iout)
8862 C Receive contacts
8863       ireq=0
8864       do ii=1,ntask_cont_from
8865         iproc=itask_cont_from(ii)
8866         nn=ncont_recv(ii)
8867 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8868 c     &   " of CONT_TO_COMM group"
8869         call flush(iout)
8870         if (nn.gt.0) then
8871           ireq=ireq+1
8872           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8873      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8874 c          write (iout,*) "ireq,req",ireq,req(ireq)
8875         endif
8876       enddo
8877 C Send the contacts to processors that need them
8878       do ii=1,ntask_cont_to
8879         iproc=itask_cont_to(ii)
8880         nn=ncont_sent(ii)
8881 c        write (iout,*) nn," contacts to processor",iproc,
8882 c     &   " of CONT_TO_COMM group"
8883         if (nn.gt.0) then
8884           ireq=ireq+1
8885           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8886      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8887 c          write (iout,*) "ireq,req",ireq,req(ireq)
8888 c          do i=1,nn
8889 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8890 c          enddo
8891         endif
8892       enddo
8893 c      write (iout,*) "number of requests (contacts)",ireq
8894 c      write (iout,*) "req",(req(i),i=1,4)
8895 c      call flush(iout)
8896       if (ireq.gt.0)
8897      & call MPI_Waitall(ireq,req,status_array,ierr)
8898       do iii=1,ntask_cont_from
8899         iproc=itask_cont_from(iii)
8900         nn=ncont_recv(iii)
8901         if (lprn) then
8902         write (iout,*) "Received",nn," contacts from processor",iproc,
8903      &   " of CONT_FROM_COMM group"
8904         call flush(iout)
8905         do i=1,nn
8906           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8907         enddo
8908         call flush(iout)
8909         endif
8910         do i=1,nn
8911           ii=zapas_recv(1,i,iii)
8912 c Flag the received contacts to prevent double-counting
8913           jj=-zapas_recv(2,i,iii)
8914 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8915 c          call flush(iout)
8916           nnn=num_cont_hb(ii)+1
8917           num_cont_hb(ii)=nnn
8918           jcont_hb(nnn,ii)=jj
8919           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8920           ind=3
8921           do kk=1,3
8922             ind=ind+1
8923             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8924           enddo
8925           do kk=1,2
8926             do ll=1,2
8927               ind=ind+1
8928               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8929             enddo
8930           enddo
8931           do jj=1,5
8932             do kk=1,3
8933               do ll=1,2
8934                 do mm=1,2
8935                   ind=ind+1
8936                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8937                 enddo
8938               enddo
8939             enddo
8940           enddo
8941         enddo
8942       enddo
8943       call flush(iout)
8944       if (lprn) then
8945         write (iout,'(a)') 'Contact function values after receive:'
8946         do i=nnt,nct-2
8947           write (iout,'(2i3,50(1x,i3,5f6.3))')
8948      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8949      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8950         enddo
8951         call flush(iout)
8952       endif
8953    30 continue
8954 #endif
8955       if (lprn) then
8956         write (iout,'(a)') 'Contact function values:'
8957         do i=nnt,nct-2
8958           write (iout,'(2i3,50(1x,i2,5f6.3))')
8959      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8960      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8961         enddo
8962       endif
8963       ecorr=0.0D0
8964       ecorr5=0.0d0
8965       ecorr6=0.0d0
8966 C Remove the loop below after debugging !!!
8967       do i=nnt,nct
8968         do j=1,3
8969           gradcorr(j,i)=0.0D0
8970           gradxorr(j,i)=0.0D0
8971         enddo
8972       enddo
8973 C Calculate the dipole-dipole interaction energies
8974       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8975       do i=iatel_s,iatel_e+1
8976         num_conti=num_cont_hb(i)
8977         do jj=1,num_conti
8978           j=jcont_hb(jj,i)
8979 #ifdef MOMENT
8980           call dipole(i,j,jj)
8981 #endif
8982         enddo
8983       enddo
8984       endif
8985 C Calculate the local-electrostatic correlation terms
8986 c                write (iout,*) "gradcorr5 in eello5 before loop"
8987 c                do iii=1,nres
8988 c                  write (iout,'(i5,3f10.5)')
8989 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8990 c                enddo
8991       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8992 c        write (iout,*) "corr loop i",i
8993         i1=i+1
8994         num_conti=num_cont_hb(i)
8995         num_conti1=num_cont_hb(i+1)
8996         do jj=1,num_conti
8997           j=jcont_hb(jj,i)
8998           jp=iabs(j)
8999           do kk=1,num_conti1
9000             j1=jcont_hb(kk,i1)
9001             jp1=iabs(j1)
9002 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9003 c     &         ' jj=',jj,' kk=',kk
9004 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9005             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9006      &          .or. j.lt.0 .and. j1.gt.0) .and.
9007      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9008 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9009 C The system gains extra energy.
9010               n_corr=n_corr+1
9011               sqd1=dsqrt(d_cont(jj,i))
9012               sqd2=dsqrt(d_cont(kk,i1))
9013               sred_geom = sqd1*sqd2
9014               IF (sred_geom.lt.cutoff_corr) THEN
9015                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9016      &            ekont,fprimcont)
9017 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9018 cd     &         ' jj=',jj,' kk=',kk
9019                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9020                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9021                 do l=1,3
9022                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9023                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9024                 enddo
9025                 n_corr1=n_corr1+1
9026 cd               write (iout,*) 'sred_geom=',sred_geom,
9027 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9028 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9029 cd               write (iout,*) "g_contij",g_contij
9030 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9031 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9032                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9033                 if (wcorr4.gt.0.0d0)
9034      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9035 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9036                   if (energy_dec.and.wcorr4.gt.0.0d0)
9037      1                 write (iout,'(a6,4i5,0pf7.3)')
9038      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9039 c                write (iout,*) "gradcorr5 before eello5"
9040 c                do iii=1,nres
9041 c                  write (iout,'(i5,3f10.5)')
9042 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9043 c                enddo
9044                 if (wcorr5.gt.0.0d0)
9045      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9046 c                write (iout,*) "gradcorr5 after eello5"
9047 c                do iii=1,nres
9048 c                  write (iout,'(i5,3f10.5)')
9049 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9050 c                enddo
9051                   if (energy_dec.and.wcorr5.gt.0.0d0)
9052      1                 write (iout,'(a6,4i5,0pf7.3)')
9053      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9054 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9055 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9056                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9057      &               .or. wturn6.eq.0.0d0))then
9058 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9059                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9060                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9061      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9062 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9063 cd     &            'ecorr6=',ecorr6
9064 cd                write (iout,'(4e15.5)') sred_geom,
9065 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9066 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9067 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9068                 else if (wturn6.gt.0.0d0
9069      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9070 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9071                   eturn6=eturn6+eello_turn6(i,jj,kk)
9072                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9073      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9074 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9075                 endif
9076               ENDIF
9077 1111          continue
9078             endif
9079           enddo ! kk
9080         enddo ! jj
9081       enddo ! i
9082       do i=1,nres
9083         num_cont_hb(i)=num_cont_hb_old(i)
9084       enddo
9085 c                write (iout,*) "gradcorr5 in eello5"
9086 c                do iii=1,nres
9087 c                  write (iout,'(i5,3f10.5)')
9088 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9089 c                enddo
9090       return
9091       end
9092 c------------------------------------------------------------------------------
9093       subroutine add_hb_contact_eello(ii,jj,itask)
9094       implicit real*8 (a-h,o-z)
9095       include "DIMENSIONS"
9096       include "COMMON.IOUNITS"
9097       integer max_cont
9098       integer max_dim
9099       parameter (max_cont=maxconts)
9100       parameter (max_dim=70)
9101       include "COMMON.CONTACTS"
9102       double precision zapas(max_dim,maxconts,max_fg_procs),
9103      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9104       common /przechowalnia/ zapas
9105       integer i,j,ii,jj,iproc,itask(4),nn
9106 c      write (iout,*) "itask",itask
9107       do i=1,2
9108         iproc=itask(i)
9109         if (iproc.gt.0) then
9110           do j=1,num_cont_hb(ii)
9111             jjc=jcont_hb(j,ii)
9112 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9113             if (jjc.eq.jj) then
9114               ncont_sent(iproc)=ncont_sent(iproc)+1
9115               nn=ncont_sent(iproc)
9116               zapas(1,nn,iproc)=ii
9117               zapas(2,nn,iproc)=jjc
9118               zapas(3,nn,iproc)=d_cont(j,ii)
9119               ind=3
9120               do kk=1,3
9121                 ind=ind+1
9122                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9123               enddo
9124               do kk=1,2
9125                 do ll=1,2
9126                   ind=ind+1
9127                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9128                 enddo
9129               enddo
9130               do jj=1,5
9131                 do kk=1,3
9132                   do ll=1,2
9133                     do mm=1,2
9134                       ind=ind+1
9135                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9136                     enddo
9137                   enddo
9138                 enddo
9139               enddo
9140               exit
9141             endif
9142           enddo
9143         endif
9144       enddo
9145       return
9146       end
9147 c------------------------------------------------------------------------------
9148       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9149       implicit real*8 (a-h,o-z)
9150       include 'DIMENSIONS'
9151       include 'COMMON.IOUNITS'
9152       include 'COMMON.DERIV'
9153       include 'COMMON.INTERACT'
9154       include 'COMMON.CONTACTS'
9155       include 'COMMON.SHIELD'
9156       include 'COMMON.CONTROL'
9157       double precision gx(3),gx1(3)
9158       logical lprn
9159       lprn=.false.
9160 C      print *,"wchodze",fac_shield(i),shield_mode
9161       eij=facont_hb(jj,i)
9162       ekl=facont_hb(kk,k)
9163       ees0pij=ees0p(jj,i)
9164       ees0pkl=ees0p(kk,k)
9165       ees0mij=ees0m(jj,i)
9166       ees0mkl=ees0m(kk,k)
9167       ekont=eij*ekl
9168       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9169 C*
9170 C     & fac_shield(i)**2*fac_shield(j)**2
9171 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9172 C Following 4 lines for diagnostics.
9173 cd    ees0pkl=0.0D0
9174 cd    ees0pij=1.0D0
9175 cd    ees0mkl=0.0D0
9176 cd    ees0mij=1.0D0
9177 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9178 c     & 'Contacts ',i,j,
9179 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9180 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9181 c     & 'gradcorr_long'
9182 C Calculate the multi-body contribution to energy.
9183 C      ecorr=ecorr+ekont*ees
9184 C Calculate multi-body contributions to the gradient.
9185       coeffpees0pij=coeffp*ees0pij
9186       coeffmees0mij=coeffm*ees0mij
9187       coeffpees0pkl=coeffp*ees0pkl
9188       coeffmees0mkl=coeffm*ees0mkl
9189       do ll=1,3
9190 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9191         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9192      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9193      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9194         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9195      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9196      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9197 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9198         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9199      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9200      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9201         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9202      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9203      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9204         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9205      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9206      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9207         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9208         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9209         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9210      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9211      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9212         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9213         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9214 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9215       enddo
9216 c      write (iout,*)
9217 cgrad      do m=i+1,j-1
9218 cgrad        do ll=1,3
9219 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9220 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9221 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9222 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9223 cgrad        enddo
9224 cgrad      enddo
9225 cgrad      do m=k+1,l-1
9226 cgrad        do ll=1,3
9227 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9228 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9229 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9230 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9231 cgrad        enddo
9232 cgrad      enddo
9233 c      write (iout,*) "ehbcorr",ekont*ees
9234 C      print *,ekont,ees,i,k
9235       ehbcorr=ekont*ees
9236 C now gradient over shielding
9237 C      return
9238       if (shield_mode.gt.0) then
9239        j=ees0plist(jj,i)
9240        l=ees0plist(kk,k)
9241 C        print *,i,j,fac_shield(i),fac_shield(j),
9242 C     &fac_shield(k),fac_shield(l)
9243         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9244      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9245           do ilist=1,ishield_list(i)
9246            iresshield=shield_list(ilist,i)
9247            do m=1,3
9248            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9249 C     &      *2.0
9250            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9251      &              rlocshield
9252      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9253             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9254      &+rlocshield
9255            enddo
9256           enddo
9257           do ilist=1,ishield_list(j)
9258            iresshield=shield_list(ilist,j)
9259            do m=1,3
9260            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9261 C     &     *2.0
9262            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9263      &              rlocshield
9264      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9265            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9266      &     +rlocshield
9267            enddo
9268           enddo
9269
9270           do ilist=1,ishield_list(k)
9271            iresshield=shield_list(ilist,k)
9272            do m=1,3
9273            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9274 C     &     *2.0
9275            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9276      &              rlocshield
9277      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9278            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9279      &     +rlocshield
9280            enddo
9281           enddo
9282           do ilist=1,ishield_list(l)
9283            iresshield=shield_list(ilist,l)
9284            do m=1,3
9285            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9286 C     &     *2.0
9287            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9288      &              rlocshield
9289      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9290            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9291      &     +rlocshield
9292            enddo
9293           enddo
9294 C          print *,gshieldx(m,iresshield)
9295           do m=1,3
9296             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9297      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9298             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9299      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9300             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9301      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9302             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9303      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9304
9305             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9306      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9307             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9308      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9309             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9310      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9311             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9312      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9313
9314            enddo
9315       endif
9316       endif
9317       return
9318       end
9319 #ifdef MOMENT
9320 C---------------------------------------------------------------------------
9321       subroutine dipole(i,j,jj)
9322       implicit real*8 (a-h,o-z)
9323       include 'DIMENSIONS'
9324       include 'COMMON.IOUNITS'
9325       include 'COMMON.CHAIN'
9326       include 'COMMON.FFIELD'
9327       include 'COMMON.DERIV'
9328       include 'COMMON.INTERACT'
9329       include 'COMMON.CONTACTS'
9330       include 'COMMON.TORSION'
9331       include 'COMMON.VAR'
9332       include 'COMMON.GEO'
9333       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9334      &  auxmat(2,2)
9335       iti1 = itortyp(itype(i+1))
9336       if (j.lt.nres-1) then
9337         itj1 = itype2loc(itype(j+1))
9338       else
9339         itj1=nloctyp
9340       endif
9341       do iii=1,2
9342         dipi(iii,1)=Ub2(iii,i)
9343         dipderi(iii)=Ub2der(iii,i)
9344         dipi(iii,2)=b1(iii,i+1)
9345         dipj(iii,1)=Ub2(iii,j)
9346         dipderj(iii)=Ub2der(iii,j)
9347         dipj(iii,2)=b1(iii,j+1)
9348       enddo
9349       kkk=0
9350       do iii=1,2
9351         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9352         do jjj=1,2
9353           kkk=kkk+1
9354           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9355         enddo
9356       enddo
9357       do kkk=1,5
9358         do lll=1,3
9359           mmm=0
9360           do iii=1,2
9361             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9362      &        auxvec(1))
9363             do jjj=1,2
9364               mmm=mmm+1
9365               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9366             enddo
9367           enddo
9368         enddo
9369       enddo
9370       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9371       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9372       do iii=1,2
9373         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9374       enddo
9375       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9376       do iii=1,2
9377         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9378       enddo
9379       return
9380       end
9381 #endif
9382 C---------------------------------------------------------------------------
9383       subroutine calc_eello(i,j,k,l,jj,kk)
9384 C
9385 C This subroutine computes matrices and vectors needed to calculate
9386 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9387 C
9388       implicit real*8 (a-h,o-z)
9389       include 'DIMENSIONS'
9390       include 'COMMON.IOUNITS'
9391       include 'COMMON.CHAIN'
9392       include 'COMMON.DERIV'
9393       include 'COMMON.INTERACT'
9394       include 'COMMON.CONTACTS'
9395       include 'COMMON.TORSION'
9396       include 'COMMON.VAR'
9397       include 'COMMON.GEO'
9398       include 'COMMON.FFIELD'
9399       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9400      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9401       logical lprn
9402       common /kutas/ lprn
9403 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9404 cd     & ' jj=',jj,' kk=',kk
9405 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9406 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9407 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9408       do iii=1,2
9409         do jjj=1,2
9410           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9411           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9412         enddo
9413       enddo
9414       call transpose2(aa1(1,1),aa1t(1,1))
9415       call transpose2(aa2(1,1),aa2t(1,1))
9416       do kkk=1,5
9417         do lll=1,3
9418           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9419      &      aa1tder(1,1,lll,kkk))
9420           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9421      &      aa2tder(1,1,lll,kkk))
9422         enddo
9423       enddo
9424       if (l.eq.j+1) then
9425 C parallel orientation of the two CA-CA-CA frames.
9426         if (i.gt.1) then
9427           iti=itype2loc(itype(i))
9428         else
9429           iti=nloctyp
9430         endif
9431         itk1=itype2loc(itype(k+1))
9432         itj=itype2loc(itype(j))
9433         if (l.lt.nres-1) then
9434           itl1=itype2loc(itype(l+1))
9435         else
9436           itl1=nloctyp
9437         endif
9438 C A1 kernel(j+1) A2T
9439 cd        do iii=1,2
9440 cd          write (iout,'(3f10.5,5x,3f10.5)')
9441 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9442 cd        enddo
9443         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9444      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9445      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9446 C Following matrices are needed only for 6-th order cumulants
9447         IF (wcorr6.gt.0.0d0) THEN
9448         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9449      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9450      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9451         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9452      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9453      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9454      &   ADtEAderx(1,1,1,1,1,1))
9455         lprn=.false.
9456         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9457      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9458      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9459      &   ADtEA1derx(1,1,1,1,1,1))
9460         ENDIF
9461 C End 6-th order cumulants
9462 cd        lprn=.false.
9463 cd        if (lprn) then
9464 cd        write (2,*) 'In calc_eello6'
9465 cd        do iii=1,2
9466 cd          write (2,*) 'iii=',iii
9467 cd          do kkk=1,5
9468 cd            write (2,*) 'kkk=',kkk
9469 cd            do jjj=1,2
9470 cd              write (2,'(3(2f10.5),5x)')
9471 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9472 cd            enddo
9473 cd          enddo
9474 cd        enddo
9475 cd        endif
9476         call transpose2(EUgder(1,1,k),auxmat(1,1))
9477         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9478         call transpose2(EUg(1,1,k),auxmat(1,1))
9479         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9480         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9481         do iii=1,2
9482           do kkk=1,5
9483             do lll=1,3
9484               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9485      &          EAEAderx(1,1,lll,kkk,iii,1))
9486             enddo
9487           enddo
9488         enddo
9489 C A1T kernel(i+1) A2
9490         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9491      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9492      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9493 C Following matrices are needed only for 6-th order cumulants
9494         IF (wcorr6.gt.0.0d0) THEN
9495         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9496      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9497      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9498         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9499      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9500      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9501      &   ADtEAderx(1,1,1,1,1,2))
9502         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9503      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9504      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9505      &   ADtEA1derx(1,1,1,1,1,2))
9506         ENDIF
9507 C End 6-th order cumulants
9508         call transpose2(EUgder(1,1,l),auxmat(1,1))
9509         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9510         call transpose2(EUg(1,1,l),auxmat(1,1))
9511         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9512         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9513         do iii=1,2
9514           do kkk=1,5
9515             do lll=1,3
9516               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9517      &          EAEAderx(1,1,lll,kkk,iii,2))
9518             enddo
9519           enddo
9520         enddo
9521 C AEAb1 and AEAb2
9522 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9523 C They are needed only when the fifth- or the sixth-order cumulants are
9524 C indluded.
9525         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9526         call transpose2(AEA(1,1,1),auxmat(1,1))
9527         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9528         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9529         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9530         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9531         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9532         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9533         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9534         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9535         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9536         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9537         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9538         call transpose2(AEA(1,1,2),auxmat(1,1))
9539         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9540         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9541         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9542         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9543         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9544         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9545         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9546         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9547         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9548         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9549         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9550 C Calculate the Cartesian derivatives of the vectors.
9551         do iii=1,2
9552           do kkk=1,5
9553             do lll=1,3
9554               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9555               call matvec2(auxmat(1,1),b1(1,i),
9556      &          AEAb1derx(1,lll,kkk,iii,1,1))
9557               call matvec2(auxmat(1,1),Ub2(1,i),
9558      &          AEAb2derx(1,lll,kkk,iii,1,1))
9559               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9560      &          AEAb1derx(1,lll,kkk,iii,2,1))
9561               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9562      &          AEAb2derx(1,lll,kkk,iii,2,1))
9563               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9564               call matvec2(auxmat(1,1),b1(1,j),
9565      &          AEAb1derx(1,lll,kkk,iii,1,2))
9566               call matvec2(auxmat(1,1),Ub2(1,j),
9567      &          AEAb2derx(1,lll,kkk,iii,1,2))
9568               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9569      &          AEAb1derx(1,lll,kkk,iii,2,2))
9570               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9571      &          AEAb2derx(1,lll,kkk,iii,2,2))
9572             enddo
9573           enddo
9574         enddo
9575         ENDIF
9576 C End vectors
9577       else
9578 C Antiparallel orientation of the two CA-CA-CA frames.
9579         if (i.gt.1) then
9580           iti=itype2loc(itype(i))
9581         else
9582           iti=nloctyp
9583         endif
9584         itk1=itype2loc(itype(k+1))
9585         itl=itype2loc(itype(l))
9586         itj=itype2loc(itype(j))
9587         if (j.lt.nres-1) then
9588           itj1=itype2loc(itype(j+1))
9589         else
9590           itj1=nloctyp
9591         endif
9592 C A2 kernel(j-1)T A1T
9593         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9594      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9595      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9596 C Following matrices are needed only for 6-th order cumulants
9597         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9598      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9599         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9600      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9601      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9602         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9603      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9604      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9605      &   ADtEAderx(1,1,1,1,1,1))
9606         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9607      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9608      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9609      &   ADtEA1derx(1,1,1,1,1,1))
9610         ENDIF
9611 C End 6-th order cumulants
9612         call transpose2(EUgder(1,1,k),auxmat(1,1))
9613         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9614         call transpose2(EUg(1,1,k),auxmat(1,1))
9615         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9616         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9617         do iii=1,2
9618           do kkk=1,5
9619             do lll=1,3
9620               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9621      &          EAEAderx(1,1,lll,kkk,iii,1))
9622             enddo
9623           enddo
9624         enddo
9625 C A2T kernel(i+1)T A1
9626         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9627      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9628      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9629 C Following matrices are needed only for 6-th order cumulants
9630         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9631      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9632         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9633      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9634      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9635         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9636      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9637      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9638      &   ADtEAderx(1,1,1,1,1,2))
9639         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9640      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9641      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9642      &   ADtEA1derx(1,1,1,1,1,2))
9643         ENDIF
9644 C End 6-th order cumulants
9645         call transpose2(EUgder(1,1,j),auxmat(1,1))
9646         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9647         call transpose2(EUg(1,1,j),auxmat(1,1))
9648         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9649         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9650         do iii=1,2
9651           do kkk=1,5
9652             do lll=1,3
9653               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9654      &          EAEAderx(1,1,lll,kkk,iii,2))
9655             enddo
9656           enddo
9657         enddo
9658 C AEAb1 and AEAb2
9659 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9660 C They are needed only when the fifth- or the sixth-order cumulants are
9661 C indluded.
9662         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9663      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9664         call transpose2(AEA(1,1,1),auxmat(1,1))
9665         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9666         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9667         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9668         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9669         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9670         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9671         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9672         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9673         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9674         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9675         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9676         call transpose2(AEA(1,1,2),auxmat(1,1))
9677         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9678         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9679         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9680         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9681         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9682         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9683         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9684         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9685         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9686         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9687         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9688 C Calculate the Cartesian derivatives of the vectors.
9689         do iii=1,2
9690           do kkk=1,5
9691             do lll=1,3
9692               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9693               call matvec2(auxmat(1,1),b1(1,i),
9694      &          AEAb1derx(1,lll,kkk,iii,1,1))
9695               call matvec2(auxmat(1,1),Ub2(1,i),
9696      &          AEAb2derx(1,lll,kkk,iii,1,1))
9697               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9698      &          AEAb1derx(1,lll,kkk,iii,2,1))
9699               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9700      &          AEAb2derx(1,lll,kkk,iii,2,1))
9701               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9702               call matvec2(auxmat(1,1),b1(1,l),
9703      &          AEAb1derx(1,lll,kkk,iii,1,2))
9704               call matvec2(auxmat(1,1),Ub2(1,l),
9705      &          AEAb2derx(1,lll,kkk,iii,1,2))
9706               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9707      &          AEAb1derx(1,lll,kkk,iii,2,2))
9708               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9709      &          AEAb2derx(1,lll,kkk,iii,2,2))
9710             enddo
9711           enddo
9712         enddo
9713         ENDIF
9714 C End vectors
9715       endif
9716       return
9717       end
9718 C---------------------------------------------------------------------------
9719       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9720      &  KK,KKderg,AKA,AKAderg,AKAderx)
9721       implicit none
9722       integer nderg
9723       logical transp
9724       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9725      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9726      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9727       integer iii,kkk,lll
9728       integer jjj,mmm
9729       logical lprn
9730       common /kutas/ lprn
9731       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9732       do iii=1,nderg
9733         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9734      &    AKAderg(1,1,iii))
9735       enddo
9736 cd      if (lprn) write (2,*) 'In kernel'
9737       do kkk=1,5
9738 cd        if (lprn) write (2,*) 'kkk=',kkk
9739         do lll=1,3
9740           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9741      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9742 cd          if (lprn) then
9743 cd            write (2,*) 'lll=',lll
9744 cd            write (2,*) 'iii=1'
9745 cd            do jjj=1,2
9746 cd              write (2,'(3(2f10.5),5x)')
9747 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9748 cd            enddo
9749 cd          endif
9750           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9751      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9752 cd          if (lprn) then
9753 cd            write (2,*) 'lll=',lll
9754 cd            write (2,*) 'iii=2'
9755 cd            do jjj=1,2
9756 cd              write (2,'(3(2f10.5),5x)')
9757 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9758 cd            enddo
9759 cd          endif
9760         enddo
9761       enddo
9762       return
9763       end
9764 C---------------------------------------------------------------------------
9765       double precision function eello4(i,j,k,l,jj,kk)
9766       implicit real*8 (a-h,o-z)
9767       include 'DIMENSIONS'
9768       include 'COMMON.IOUNITS'
9769       include 'COMMON.CHAIN'
9770       include 'COMMON.DERIV'
9771       include 'COMMON.INTERACT'
9772       include 'COMMON.CONTACTS'
9773       include 'COMMON.TORSION'
9774       include 'COMMON.VAR'
9775       include 'COMMON.GEO'
9776       double precision pizda(2,2),ggg1(3),ggg2(3)
9777 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9778 cd        eello4=0.0d0
9779 cd        return
9780 cd      endif
9781 cd      print *,'eello4:',i,j,k,l,jj,kk
9782 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9783 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9784 cold      eij=facont_hb(jj,i)
9785 cold      ekl=facont_hb(kk,k)
9786 cold      ekont=eij*ekl
9787       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9788 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9789       gcorr_loc(k-1)=gcorr_loc(k-1)
9790      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9791       if (l.eq.j+1) then
9792         gcorr_loc(l-1)=gcorr_loc(l-1)
9793      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9794       else
9795         gcorr_loc(j-1)=gcorr_loc(j-1)
9796      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9797       endif
9798       do iii=1,2
9799         do kkk=1,5
9800           do lll=1,3
9801             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9802      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9803 cd            derx(lll,kkk,iii)=0.0d0
9804           enddo
9805         enddo
9806       enddo
9807 cd      gcorr_loc(l-1)=0.0d0
9808 cd      gcorr_loc(j-1)=0.0d0
9809 cd      gcorr_loc(k-1)=0.0d0
9810 cd      eel4=1.0d0
9811 cd      write (iout,*)'Contacts have occurred for peptide groups',
9812 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9813 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9814       if (j.lt.nres-1) then
9815         j1=j+1
9816         j2=j-1
9817       else
9818         j1=j-1
9819         j2=j-2
9820       endif
9821       if (l.lt.nres-1) then
9822         l1=l+1
9823         l2=l-1
9824       else
9825         l1=l-1
9826         l2=l-2
9827       endif
9828       do ll=1,3
9829 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9830 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9831         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9832         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9833 cgrad        ghalf=0.5d0*ggg1(ll)
9834         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9835         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9836         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9837         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9838         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9839         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9840 cgrad        ghalf=0.5d0*ggg2(ll)
9841         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9842         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9843         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9844         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9845         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9846         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9847       enddo
9848 cgrad      do m=i+1,j-1
9849 cgrad        do ll=1,3
9850 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9851 cgrad        enddo
9852 cgrad      enddo
9853 cgrad      do m=k+1,l-1
9854 cgrad        do ll=1,3
9855 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9856 cgrad        enddo
9857 cgrad      enddo
9858 cgrad      do m=i+2,j2
9859 cgrad        do ll=1,3
9860 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9861 cgrad        enddo
9862 cgrad      enddo
9863 cgrad      do m=k+2,l2
9864 cgrad        do ll=1,3
9865 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9866 cgrad        enddo
9867 cgrad      enddo
9868 cd      do iii=1,nres-3
9869 cd        write (2,*) iii,gcorr_loc(iii)
9870 cd      enddo
9871       eello4=ekont*eel4
9872 cd      write (2,*) 'ekont',ekont
9873 cd      write (iout,*) 'eello4',ekont*eel4
9874       return
9875       end
9876 C---------------------------------------------------------------------------
9877       double precision function eello5(i,j,k,l,jj,kk)
9878       implicit real*8 (a-h,o-z)
9879       include 'DIMENSIONS'
9880       include 'COMMON.IOUNITS'
9881       include 'COMMON.CHAIN'
9882       include 'COMMON.DERIV'
9883       include 'COMMON.INTERACT'
9884       include 'COMMON.CONTACTS'
9885       include 'COMMON.TORSION'
9886       include 'COMMON.VAR'
9887       include 'COMMON.GEO'
9888       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9889       double precision ggg1(3),ggg2(3)
9890 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9891 C                                                                              C
9892 C                            Parallel chains                                   C
9893 C                                                                              C
9894 C          o             o                   o             o                   C
9895 C         /l\           / \             \   / \           / \   /              C
9896 C        /   \         /   \             \ /   \         /   \ /               C
9897 C       j| o |l1       | o |              o| o |         | o |o                C
9898 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9899 C      \i/   \         /   \ /             /   \         /   \                 C
9900 C       o    k1             o                                                  C
9901 C         (I)          (II)                (III)          (IV)                 C
9902 C                                                                              C
9903 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9904 C                                                                              C
9905 C                            Antiparallel chains                               C
9906 C                                                                              C
9907 C          o             o                   o             o                   C
9908 C         /j\           / \             \   / \           / \   /              C
9909 C        /   \         /   \             \ /   \         /   \ /               C
9910 C      j1| o |l        | o |              o| o |         | o |o                C
9911 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9912 C      \i/   \         /   \ /             /   \         /   \                 C
9913 C       o     k1            o                                                  C
9914 C         (I)          (II)                (III)          (IV)                 C
9915 C                                                                              C
9916 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9917 C                                                                              C
9918 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9919 C                                                                              C
9920 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9921 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9922 cd        eello5=0.0d0
9923 cd        return
9924 cd      endif
9925 cd      write (iout,*)
9926 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9927 cd     &   ' and',k,l
9928       itk=itype2loc(itype(k))
9929       itl=itype2loc(itype(l))
9930       itj=itype2loc(itype(j))
9931       eello5_1=0.0d0
9932       eello5_2=0.0d0
9933       eello5_3=0.0d0
9934       eello5_4=0.0d0
9935 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9936 cd     &   eel5_3_num,eel5_4_num)
9937       do iii=1,2
9938         do kkk=1,5
9939           do lll=1,3
9940             derx(lll,kkk,iii)=0.0d0
9941           enddo
9942         enddo
9943       enddo
9944 cd      eij=facont_hb(jj,i)
9945 cd      ekl=facont_hb(kk,k)
9946 cd      ekont=eij*ekl
9947 cd      write (iout,*)'Contacts have occurred for peptide groups',
9948 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9949 cd      goto 1111
9950 C Contribution from the graph I.
9951 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9952 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9953       call transpose2(EUg(1,1,k),auxmat(1,1))
9954       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9955       vv(1)=pizda(1,1)-pizda(2,2)
9956       vv(2)=pizda(1,2)+pizda(2,1)
9957       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9958      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9959 C Explicit gradient in virtual-dihedral angles.
9960       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9961      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9962      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9963       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9964       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9965       vv(1)=pizda(1,1)-pizda(2,2)
9966       vv(2)=pizda(1,2)+pizda(2,1)
9967       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9968      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9969      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9970       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9971       vv(1)=pizda(1,1)-pizda(2,2)
9972       vv(2)=pizda(1,2)+pizda(2,1)
9973       if (l.eq.j+1) then
9974         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9975      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9976      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9977       else
9978         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9979      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9980      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9981       endif
9982 C Cartesian gradient
9983       do iii=1,2
9984         do kkk=1,5
9985           do lll=1,3
9986             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9987      &        pizda(1,1))
9988             vv(1)=pizda(1,1)-pizda(2,2)
9989             vv(2)=pizda(1,2)+pizda(2,1)
9990             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9991      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9992      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9993           enddo
9994         enddo
9995       enddo
9996 c      goto 1112
9997 c1111  continue
9998 C Contribution from graph II
9999       call transpose2(EE(1,1,k),auxmat(1,1))
10000       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10001       vv(1)=pizda(1,1)+pizda(2,2)
10002       vv(2)=pizda(2,1)-pizda(1,2)
10003       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10004      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10005 C Explicit gradient in virtual-dihedral angles.
10006       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10007      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10008       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10009       vv(1)=pizda(1,1)+pizda(2,2)
10010       vv(2)=pizda(2,1)-pizda(1,2)
10011       if (l.eq.j+1) then
10012         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10013      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10014      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10015       else
10016         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10017      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10018      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10019       endif
10020 C Cartesian gradient
10021       do iii=1,2
10022         do kkk=1,5
10023           do lll=1,3
10024             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10025      &        pizda(1,1))
10026             vv(1)=pizda(1,1)+pizda(2,2)
10027             vv(2)=pizda(2,1)-pizda(1,2)
10028             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10029      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10030      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10031           enddo
10032         enddo
10033       enddo
10034 cd      goto 1112
10035 cd1111  continue
10036       if (l.eq.j+1) then
10037 cd        goto 1110
10038 C Parallel orientation
10039 C Contribution from graph III
10040         call transpose2(EUg(1,1,l),auxmat(1,1))
10041         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10042         vv(1)=pizda(1,1)-pizda(2,2)
10043         vv(2)=pizda(1,2)+pizda(2,1)
10044         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10045      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10046 C Explicit gradient in virtual-dihedral angles.
10047         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10048      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10049      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10050         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10051         vv(1)=pizda(1,1)-pizda(2,2)
10052         vv(2)=pizda(1,2)+pizda(2,1)
10053         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10054      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10055      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10056         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10057         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10058         vv(1)=pizda(1,1)-pizda(2,2)
10059         vv(2)=pizda(1,2)+pizda(2,1)
10060         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10061      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10062      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10063 C Cartesian gradient
10064         do iii=1,2
10065           do kkk=1,5
10066             do lll=1,3
10067               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10068      &          pizda(1,1))
10069               vv(1)=pizda(1,1)-pizda(2,2)
10070               vv(2)=pizda(1,2)+pizda(2,1)
10071               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10072      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10073      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10074             enddo
10075           enddo
10076         enddo
10077 cd        goto 1112
10078 C Contribution from graph IV
10079 cd1110    continue
10080         call transpose2(EE(1,1,l),auxmat(1,1))
10081         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10082         vv(1)=pizda(1,1)+pizda(2,2)
10083         vv(2)=pizda(2,1)-pizda(1,2)
10084         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10085      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10086 C Explicit gradient in virtual-dihedral angles.
10087         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10088      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10089         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10090         vv(1)=pizda(1,1)+pizda(2,2)
10091         vv(2)=pizda(2,1)-pizda(1,2)
10092         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10093      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10094      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10095 C Cartesian gradient
10096         do iii=1,2
10097           do kkk=1,5
10098             do lll=1,3
10099               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10100      &          pizda(1,1))
10101               vv(1)=pizda(1,1)+pizda(2,2)
10102               vv(2)=pizda(2,1)-pizda(1,2)
10103               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10104      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10105      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10106             enddo
10107           enddo
10108         enddo
10109       else
10110 C Antiparallel orientation
10111 C Contribution from graph III
10112 c        goto 1110
10113         call transpose2(EUg(1,1,j),auxmat(1,1))
10114         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10115         vv(1)=pizda(1,1)-pizda(2,2)
10116         vv(2)=pizda(1,2)+pizda(2,1)
10117         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10118      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10119 C Explicit gradient in virtual-dihedral angles.
10120         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10121      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10122      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10123         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10124         vv(1)=pizda(1,1)-pizda(2,2)
10125         vv(2)=pizda(1,2)+pizda(2,1)
10126         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10127      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10128      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10129         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10130         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10131         vv(1)=pizda(1,1)-pizda(2,2)
10132         vv(2)=pizda(1,2)+pizda(2,1)
10133         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10134      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10135      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10136 C Cartesian gradient
10137         do iii=1,2
10138           do kkk=1,5
10139             do lll=1,3
10140               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10141      &          pizda(1,1))
10142               vv(1)=pizda(1,1)-pizda(2,2)
10143               vv(2)=pizda(1,2)+pizda(2,1)
10144               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10145      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10146      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10147             enddo
10148           enddo
10149         enddo
10150 cd        goto 1112
10151 C Contribution from graph IV
10152 1110    continue
10153         call transpose2(EE(1,1,j),auxmat(1,1))
10154         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10155         vv(1)=pizda(1,1)+pizda(2,2)
10156         vv(2)=pizda(2,1)-pizda(1,2)
10157         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10158      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10159 C Explicit gradient in virtual-dihedral angles.
10160         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10161      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10162         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10163         vv(1)=pizda(1,1)+pizda(2,2)
10164         vv(2)=pizda(2,1)-pizda(1,2)
10165         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10166      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10167      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10168 C Cartesian gradient
10169         do iii=1,2
10170           do kkk=1,5
10171             do lll=1,3
10172               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10173      &          pizda(1,1))
10174               vv(1)=pizda(1,1)+pizda(2,2)
10175               vv(2)=pizda(2,1)-pizda(1,2)
10176               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10177      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10178      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10179             enddo
10180           enddo
10181         enddo
10182       endif
10183 1112  continue
10184       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10185 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10186 cd        write (2,*) 'ijkl',i,j,k,l
10187 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10188 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10189 cd      endif
10190 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10191 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10192 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10193 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10194       if (j.lt.nres-1) then
10195         j1=j+1
10196         j2=j-1
10197       else
10198         j1=j-1
10199         j2=j-2
10200       endif
10201       if (l.lt.nres-1) then
10202         l1=l+1
10203         l2=l-1
10204       else
10205         l1=l-1
10206         l2=l-2
10207       endif
10208 cd      eij=1.0d0
10209 cd      ekl=1.0d0
10210 cd      ekont=1.0d0
10211 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10212 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10213 C        summed up outside the subrouine as for the other subroutines
10214 C        handling long-range interactions. The old code is commented out
10215 C        with "cgrad" to keep track of changes.
10216       do ll=1,3
10217 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10218 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10219         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10220         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10221 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10222 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10223 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10224 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10225 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10226 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10227 c     &   gradcorr5ij,
10228 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10229 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10230 cgrad        ghalf=0.5d0*ggg1(ll)
10231 cd        ghalf=0.0d0
10232         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10233         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10234         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10235         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10236         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10237         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10238 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10239 cgrad        ghalf=0.5d0*ggg2(ll)
10240 cd        ghalf=0.0d0
10241         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10242         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10243         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10244         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10245         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10246         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10247       enddo
10248 cd      goto 1112
10249 cgrad      do m=i+1,j-1
10250 cgrad        do ll=1,3
10251 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10252 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10253 cgrad        enddo
10254 cgrad      enddo
10255 cgrad      do m=k+1,l-1
10256 cgrad        do ll=1,3
10257 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10258 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10259 cgrad        enddo
10260 cgrad      enddo
10261 c1112  continue
10262 cgrad      do m=i+2,j2
10263 cgrad        do ll=1,3
10264 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10265 cgrad        enddo
10266 cgrad      enddo
10267 cgrad      do m=k+2,l2
10268 cgrad        do ll=1,3
10269 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10270 cgrad        enddo
10271 cgrad      enddo
10272 cd      do iii=1,nres-3
10273 cd        write (2,*) iii,g_corr5_loc(iii)
10274 cd      enddo
10275       eello5=ekont*eel5
10276 cd      write (2,*) 'ekont',ekont
10277 cd      write (iout,*) 'eello5',ekont*eel5
10278       return
10279       end
10280 c--------------------------------------------------------------------------
10281       double precision function eello6(i,j,k,l,jj,kk)
10282       implicit real*8 (a-h,o-z)
10283       include 'DIMENSIONS'
10284       include 'COMMON.IOUNITS'
10285       include 'COMMON.CHAIN'
10286       include 'COMMON.DERIV'
10287       include 'COMMON.INTERACT'
10288       include 'COMMON.CONTACTS'
10289       include 'COMMON.TORSION'
10290       include 'COMMON.VAR'
10291       include 'COMMON.GEO'
10292       include 'COMMON.FFIELD'
10293       double precision ggg1(3),ggg2(3)
10294 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10295 cd        eello6=0.0d0
10296 cd        return
10297 cd      endif
10298 cd      write (iout,*)
10299 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10300 cd     &   ' and',k,l
10301       eello6_1=0.0d0
10302       eello6_2=0.0d0
10303       eello6_3=0.0d0
10304       eello6_4=0.0d0
10305       eello6_5=0.0d0
10306       eello6_6=0.0d0
10307 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10308 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10309       do iii=1,2
10310         do kkk=1,5
10311           do lll=1,3
10312             derx(lll,kkk,iii)=0.0d0
10313           enddo
10314         enddo
10315       enddo
10316 cd      eij=facont_hb(jj,i)
10317 cd      ekl=facont_hb(kk,k)
10318 cd      ekont=eij*ekl
10319 cd      eij=1.0d0
10320 cd      ekl=1.0d0
10321 cd      ekont=1.0d0
10322       if (l.eq.j+1) then
10323         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10324         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10325         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10326         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10327         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10328         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10329       else
10330         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10331         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10332         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10333         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10334         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10335           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10336         else
10337           eello6_5=0.0d0
10338         endif
10339         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10340       endif
10341 C If turn contributions are considered, they will be handled separately.
10342       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10343 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10344 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10345 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10346 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10347 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10348 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10349 cd      goto 1112
10350       if (j.lt.nres-1) then
10351         j1=j+1
10352         j2=j-1
10353       else
10354         j1=j-1
10355         j2=j-2
10356       endif
10357       if (l.lt.nres-1) then
10358         l1=l+1
10359         l2=l-1
10360       else
10361         l1=l-1
10362         l2=l-2
10363       endif
10364       do ll=1,3
10365 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10366 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10367 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10368 cgrad        ghalf=0.5d0*ggg1(ll)
10369 cd        ghalf=0.0d0
10370         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10371         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10372         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10373         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10374         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10375         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10376         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10377         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10378 cgrad        ghalf=0.5d0*ggg2(ll)
10379 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10380 cd        ghalf=0.0d0
10381         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10382         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10383         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10384         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10385         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10386         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10387       enddo
10388 cd      goto 1112
10389 cgrad      do m=i+1,j-1
10390 cgrad        do ll=1,3
10391 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10392 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10393 cgrad        enddo
10394 cgrad      enddo
10395 cgrad      do m=k+1,l-1
10396 cgrad        do ll=1,3
10397 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10398 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10399 cgrad        enddo
10400 cgrad      enddo
10401 cgrad1112  continue
10402 cgrad      do m=i+2,j2
10403 cgrad        do ll=1,3
10404 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10405 cgrad        enddo
10406 cgrad      enddo
10407 cgrad      do m=k+2,l2
10408 cgrad        do ll=1,3
10409 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10410 cgrad        enddo
10411 cgrad      enddo
10412 cd      do iii=1,nres-3
10413 cd        write (2,*) iii,g_corr6_loc(iii)
10414 cd      enddo
10415       eello6=ekont*eel6
10416 cd      write (2,*) 'ekont',ekont
10417 cd      write (iout,*) 'eello6',ekont*eel6
10418       return
10419       end
10420 c--------------------------------------------------------------------------
10421       double precision function eello6_graph1(i,j,k,l,imat,swap)
10422       implicit real*8 (a-h,o-z)
10423       include 'DIMENSIONS'
10424       include 'COMMON.IOUNITS'
10425       include 'COMMON.CHAIN'
10426       include 'COMMON.DERIV'
10427       include 'COMMON.INTERACT'
10428       include 'COMMON.CONTACTS'
10429       include 'COMMON.TORSION'
10430       include 'COMMON.VAR'
10431       include 'COMMON.GEO'
10432       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10433       logical swap
10434       logical lprn
10435       common /kutas/ lprn
10436 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10437 C                                                                              C
10438 C      Parallel       Antiparallel                                             C
10439 C                                                                              C
10440 C          o             o                                                     C
10441 C         /l\           /j\                                                    C
10442 C        /   \         /   \                                                   C
10443 C       /| o |         | o |\                                                  C
10444 C     \ j|/k\|  /   \  |/k\|l /                                                C
10445 C      \ /   \ /     \ /   \ /                                                 C
10446 C       o     o       o     o                                                  C
10447 C       i             i                                                        C
10448 C                                                                              C
10449 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10450       itk=itype2loc(itype(k))
10451       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10452       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10453       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10454       call transpose2(EUgC(1,1,k),auxmat(1,1))
10455       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10456       vv1(1)=pizda1(1,1)-pizda1(2,2)
10457       vv1(2)=pizda1(1,2)+pizda1(2,1)
10458       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10459       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10460       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10461       s5=scalar2(vv(1),Dtobr2(1,i))
10462 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10463       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10464       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10465      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10466      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10467      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10468      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10469      & +scalar2(vv(1),Dtobr2der(1,i)))
10470       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10471       vv1(1)=pizda1(1,1)-pizda1(2,2)
10472       vv1(2)=pizda1(1,2)+pizda1(2,1)
10473       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10474       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10475       if (l.eq.j+1) then
10476         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10477      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10478      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10479      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10480      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10481       else
10482         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10483      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10484      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10485      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10486      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10487       endif
10488       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10489       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10490       vv1(1)=pizda1(1,1)-pizda1(2,2)
10491       vv1(2)=pizda1(1,2)+pizda1(2,1)
10492       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10493      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10494      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10495      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10496       do iii=1,2
10497         if (swap) then
10498           ind=3-iii
10499         else
10500           ind=iii
10501         endif
10502         do kkk=1,5
10503           do lll=1,3
10504             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10505             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10506             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10507             call transpose2(EUgC(1,1,k),auxmat(1,1))
10508             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10509      &        pizda1(1,1))
10510             vv1(1)=pizda1(1,1)-pizda1(2,2)
10511             vv1(2)=pizda1(1,2)+pizda1(2,1)
10512             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10513             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10514      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10515             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10516      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10517             s5=scalar2(vv(1),Dtobr2(1,i))
10518             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10519           enddo
10520         enddo
10521       enddo
10522       return
10523       end
10524 c----------------------------------------------------------------------------
10525       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10526       implicit real*8 (a-h,o-z)
10527       include 'DIMENSIONS'
10528       include 'COMMON.IOUNITS'
10529       include 'COMMON.CHAIN'
10530       include 'COMMON.DERIV'
10531       include 'COMMON.INTERACT'
10532       include 'COMMON.CONTACTS'
10533       include 'COMMON.TORSION'
10534       include 'COMMON.VAR'
10535       include 'COMMON.GEO'
10536       logical swap
10537       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10538      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10539       logical lprn
10540       common /kutas/ lprn
10541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10542 C                                                                              C
10543 C      Parallel       Antiparallel                                             C
10544 C                                                                              C
10545 C          o             o                                                     C
10546 C     \   /l\           /j\   /                                                C
10547 C      \ /   \         /   \ /                                                 C
10548 C       o| o |         | o |o                                                  C
10549 C     \ j|/k\|      \  |/k\|l                                                  C
10550 C      \ /   \       \ /   \                                                   C
10551 C       o             o                                                        C
10552 C       i             i                                                        C
10553 C                                                                              C
10554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10555 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10556 C AL 7/4/01 s1 would occur in the sixth-order moment,
10557 C           but not in a cluster cumulant
10558 #ifdef MOMENT
10559       s1=dip(1,jj,i)*dip(1,kk,k)
10560 #endif
10561       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10562       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10563       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10564       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10565       call transpose2(EUg(1,1,k),auxmat(1,1))
10566       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10567       vv(1)=pizda(1,1)-pizda(2,2)
10568       vv(2)=pizda(1,2)+pizda(2,1)
10569       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10570 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10571 #ifdef MOMENT
10572       eello6_graph2=-(s1+s2+s3+s4)
10573 #else
10574       eello6_graph2=-(s2+s3+s4)
10575 #endif
10576 c      eello6_graph2=-s3
10577 C Derivatives in gamma(i-1)
10578       if (i.gt.1) then
10579 #ifdef MOMENT
10580         s1=dipderg(1,jj,i)*dip(1,kk,k)
10581 #endif
10582         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10583         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10584         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10585         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10586 #ifdef MOMENT
10587         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10588 #else
10589         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10590 #endif
10591 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10592       endif
10593 C Derivatives in gamma(k-1)
10594 #ifdef MOMENT
10595       s1=dip(1,jj,i)*dipderg(1,kk,k)
10596 #endif
10597       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10598       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10599       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10600       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10601       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10602       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10603       vv(1)=pizda(1,1)-pizda(2,2)
10604       vv(2)=pizda(1,2)+pizda(2,1)
10605       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10606 #ifdef MOMENT
10607       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10608 #else
10609       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10610 #endif
10611 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10612 C Derivatives in gamma(j-1) or gamma(l-1)
10613       if (j.gt.1) then
10614 #ifdef MOMENT
10615         s1=dipderg(3,jj,i)*dip(1,kk,k)
10616 #endif
10617         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10618         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10619         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10620         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10621         vv(1)=pizda(1,1)-pizda(2,2)
10622         vv(2)=pizda(1,2)+pizda(2,1)
10623         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10624 #ifdef MOMENT
10625         if (swap) then
10626           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10627         else
10628           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10629         endif
10630 #endif
10631         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10632 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10633       endif
10634 C Derivatives in gamma(l-1) or gamma(j-1)
10635       if (l.gt.1) then
10636 #ifdef MOMENT
10637         s1=dip(1,jj,i)*dipderg(3,kk,k)
10638 #endif
10639         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10640         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10641         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10642         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10643         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10644         vv(1)=pizda(1,1)-pizda(2,2)
10645         vv(2)=pizda(1,2)+pizda(2,1)
10646         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10647 #ifdef MOMENT
10648         if (swap) then
10649           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10650         else
10651           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10652         endif
10653 #endif
10654         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10655 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10656       endif
10657 C Cartesian derivatives.
10658       if (lprn) then
10659         write (2,*) 'In eello6_graph2'
10660         do iii=1,2
10661           write (2,*) 'iii=',iii
10662           do kkk=1,5
10663             write (2,*) 'kkk=',kkk
10664             do jjj=1,2
10665               write (2,'(3(2f10.5),5x)')
10666      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10667             enddo
10668           enddo
10669         enddo
10670       endif
10671       do iii=1,2
10672         do kkk=1,5
10673           do lll=1,3
10674 #ifdef MOMENT
10675             if (iii.eq.1) then
10676               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10677             else
10678               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10679             endif
10680 #endif
10681             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10682      &        auxvec(1))
10683             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10684             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10685      &        auxvec(1))
10686             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10687             call transpose2(EUg(1,1,k),auxmat(1,1))
10688             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10689      &        pizda(1,1))
10690             vv(1)=pizda(1,1)-pizda(2,2)
10691             vv(2)=pizda(1,2)+pizda(2,1)
10692             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10693 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10694 #ifdef MOMENT
10695             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10696 #else
10697             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10698 #endif
10699             if (swap) then
10700               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10701             else
10702               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10703             endif
10704           enddo
10705         enddo
10706       enddo
10707       return
10708       end
10709 c----------------------------------------------------------------------------
10710       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10711       implicit real*8 (a-h,o-z)
10712       include 'DIMENSIONS'
10713       include 'COMMON.IOUNITS'
10714       include 'COMMON.CHAIN'
10715       include 'COMMON.DERIV'
10716       include 'COMMON.INTERACT'
10717       include 'COMMON.CONTACTS'
10718       include 'COMMON.TORSION'
10719       include 'COMMON.VAR'
10720       include 'COMMON.GEO'
10721       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10722       logical swap
10723 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10724 C                                                                              C
10725 C      Parallel       Antiparallel                                             C
10726 C                                                                              C
10727 C          o             o                                                     C
10728 C         /l\   /   \   /j\                                                    C
10729 C        /   \ /     \ /   \                                                   C
10730 C       /| o |o       o| o |\                                                  C
10731 C       j|/k\|  /      |/k\|l /                                                C
10732 C        /   \ /       /   \ /                                                 C
10733 C       /     o       /     o                                                  C
10734 C       i             i                                                        C
10735 C                                                                              C
10736 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10737 C
10738 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10739 C           energy moment and not to the cluster cumulant.
10740       iti=itortyp(itype(i))
10741       if (j.lt.nres-1) then
10742         itj1=itype2loc(itype(j+1))
10743       else
10744         itj1=nloctyp
10745       endif
10746       itk=itype2loc(itype(k))
10747       itk1=itype2loc(itype(k+1))
10748       if (l.lt.nres-1) then
10749         itl1=itype2loc(itype(l+1))
10750       else
10751         itl1=nloctyp
10752       endif
10753 #ifdef MOMENT
10754       s1=dip(4,jj,i)*dip(4,kk,k)
10755 #endif
10756       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10757       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10758       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10759       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10760       call transpose2(EE(1,1,k),auxmat(1,1))
10761       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10762       vv(1)=pizda(1,1)+pizda(2,2)
10763       vv(2)=pizda(2,1)-pizda(1,2)
10764       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10765 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10766 cd     & "sum",-(s2+s3+s4)
10767 #ifdef MOMENT
10768       eello6_graph3=-(s1+s2+s3+s4)
10769 #else
10770       eello6_graph3=-(s2+s3+s4)
10771 #endif
10772 c      eello6_graph3=-s4
10773 C Derivatives in gamma(k-1)
10774       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10775       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10776       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10777       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10778 C Derivatives in gamma(l-1)
10779       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10780       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10781       call matmat2(auxmat(1,1),AECAderg(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       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10786 C Cartesian derivatives.
10787       do iii=1,2
10788         do kkk=1,5
10789           do lll=1,3
10790 #ifdef MOMENT
10791             if (iii.eq.1) then
10792               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10793             else
10794               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10795             endif
10796 #endif
10797             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10798      &        auxvec(1))
10799             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10800             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10801      &        auxvec(1))
10802             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10803             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10804      &        pizda(1,1))
10805             vv(1)=pizda(1,1)+pizda(2,2)
10806             vv(2)=pizda(2,1)-pizda(1,2)
10807             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10808 #ifdef MOMENT
10809             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10810 #else
10811             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10812 #endif
10813             if (swap) then
10814               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10815             else
10816               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10817             endif
10818 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10819           enddo
10820         enddo
10821       enddo
10822       return
10823       end
10824 c----------------------------------------------------------------------------
10825       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10826       implicit real*8 (a-h,o-z)
10827       include 'DIMENSIONS'
10828       include 'COMMON.IOUNITS'
10829       include 'COMMON.CHAIN'
10830       include 'COMMON.DERIV'
10831       include 'COMMON.INTERACT'
10832       include 'COMMON.CONTACTS'
10833       include 'COMMON.TORSION'
10834       include 'COMMON.VAR'
10835       include 'COMMON.GEO'
10836       include 'COMMON.FFIELD'
10837       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10838      & auxvec1(2),auxmat1(2,2)
10839       logical swap
10840 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10841 C                                                                              C
10842 C      Parallel       Antiparallel                                             C
10843 C                                                                              C
10844 C          o             o                                                     C
10845 C         /l\   /   \   /j\                                                    C
10846 C        /   \ /     \ /   \                                                   C
10847 C       /| o |o       o| o |\                                                  C
10848 C     \ j|/k\|      \  |/k\|l                                                  C
10849 C      \ /   \       \ /   \                                                   C
10850 C       o     \       o     \                                                  C
10851 C       i             i                                                        C
10852 C                                                                              C
10853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10854 C
10855 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10856 C           energy moment and not to the cluster cumulant.
10857 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10858       iti=itype2loc(itype(i))
10859       itj=itype2loc(itype(j))
10860       if (j.lt.nres-1) then
10861         itj1=itype2loc(itype(j+1))
10862       else
10863         itj1=nloctyp
10864       endif
10865       itk=itype2loc(itype(k))
10866       if (k.lt.nres-1) then
10867         itk1=itype2loc(itype(k+1))
10868       else
10869         itk1=nloctyp
10870       endif
10871       itl=itype2loc(itype(l))
10872       if (l.lt.nres-1) then
10873         itl1=itype2loc(itype(l+1))
10874       else
10875         itl1=nloctyp
10876       endif
10877 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10878 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10879 cd     & ' itl',itl,' itl1',itl1
10880 #ifdef MOMENT
10881       if (imat.eq.1) then
10882         s1=dip(3,jj,i)*dip(3,kk,k)
10883       else
10884         s1=dip(2,jj,j)*dip(2,kk,l)
10885       endif
10886 #endif
10887       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10888       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10889       if (j.eq.l+1) then
10890         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10891         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10892       else
10893         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10894         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10895       endif
10896       call transpose2(EUg(1,1,k),auxmat(1,1))
10897       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10898       vv(1)=pizda(1,1)-pizda(2,2)
10899       vv(2)=pizda(2,1)+pizda(1,2)
10900       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10901 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10902 #ifdef MOMENT
10903       eello6_graph4=-(s1+s2+s3+s4)
10904 #else
10905       eello6_graph4=-(s2+s3+s4)
10906 #endif
10907 C Derivatives in gamma(i-1)
10908       if (i.gt.1) then
10909 #ifdef MOMENT
10910         if (imat.eq.1) then
10911           s1=dipderg(2,jj,i)*dip(3,kk,k)
10912         else
10913           s1=dipderg(4,jj,j)*dip(2,kk,l)
10914         endif
10915 #endif
10916         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10917         if (j.eq.l+1) then
10918           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10919           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10920         else
10921           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10922           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10923         endif
10924         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10925         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10926 cd          write (2,*) 'turn6 derivatives'
10927 #ifdef MOMENT
10928           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10929 #else
10930           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10931 #endif
10932         else
10933 #ifdef MOMENT
10934           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10935 #else
10936           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10937 #endif
10938         endif
10939       endif
10940 C Derivatives in gamma(k-1)
10941 #ifdef MOMENT
10942       if (imat.eq.1) then
10943         s1=dip(3,jj,i)*dipderg(2,kk,k)
10944       else
10945         s1=dip(2,jj,j)*dipderg(4,kk,l)
10946       endif
10947 #endif
10948       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10949       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10950       if (j.eq.l+1) then
10951         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10952         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10953       else
10954         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10955         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10956       endif
10957       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10958       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10959       vv(1)=pizda(1,1)-pizda(2,2)
10960       vv(2)=pizda(2,1)+pizda(1,2)
10961       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10962       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10963 #ifdef MOMENT
10964         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10965 #else
10966         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10967 #endif
10968       else
10969 #ifdef MOMENT
10970         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10971 #else
10972         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10973 #endif
10974       endif
10975 C Derivatives in gamma(j-1) or gamma(l-1)
10976       if (l.eq.j+1 .and. l.gt.1) then
10977         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10978         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10979         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10980         vv(1)=pizda(1,1)-pizda(2,2)
10981         vv(2)=pizda(2,1)+pizda(1,2)
10982         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10983         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10984       else if (j.gt.1) then
10985         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10986         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10987         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10988         vv(1)=pizda(1,1)-pizda(2,2)
10989         vv(2)=pizda(2,1)+pizda(1,2)
10990         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10991         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10992           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10993         else
10994           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10995         endif
10996       endif
10997 C Cartesian derivatives.
10998       do iii=1,2
10999         do kkk=1,5
11000           do lll=1,3
11001 #ifdef MOMENT
11002             if (iii.eq.1) then
11003               if (imat.eq.1) then
11004                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11005               else
11006                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11007               endif
11008             else
11009               if (imat.eq.1) then
11010                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11011               else
11012                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11013               endif
11014             endif
11015 #endif
11016             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11017      &        auxvec(1))
11018             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11019             if (j.eq.l+1) then
11020               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11021      &          b1(1,j+1),auxvec(1))
11022               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11023             else
11024               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11025      &          b1(1,l+1),auxvec(1))
11026               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11027             endif
11028             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11029      &        pizda(1,1))
11030             vv(1)=pizda(1,1)-pizda(2,2)
11031             vv(2)=pizda(2,1)+pizda(1,2)
11032             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11033             if (swap) then
11034               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11035 #ifdef MOMENT
11036                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11037      &             -(s1+s2+s4)
11038 #else
11039                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11040      &             -(s2+s4)
11041 #endif
11042                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11043               else
11044 #ifdef MOMENT
11045                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11046 #else
11047                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11048 #endif
11049                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11050               endif
11051             else
11052 #ifdef MOMENT
11053               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11054 #else
11055               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11056 #endif
11057               if (l.eq.j+1) then
11058                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11059               else
11060                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11061               endif
11062             endif
11063           enddo
11064         enddo
11065       enddo
11066       return
11067       end
11068 c----------------------------------------------------------------------------
11069       double precision function eello_turn6(i,jj,kk)
11070       implicit real*8 (a-h,o-z)
11071       include 'DIMENSIONS'
11072       include 'COMMON.IOUNITS'
11073       include 'COMMON.CHAIN'
11074       include 'COMMON.DERIV'
11075       include 'COMMON.INTERACT'
11076       include 'COMMON.CONTACTS'
11077       include 'COMMON.TORSION'
11078       include 'COMMON.VAR'
11079       include 'COMMON.GEO'
11080       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11081      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11082      &  ggg1(3),ggg2(3)
11083       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11084      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11085 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11086 C           the respective energy moment and not to the cluster cumulant.
11087       s1=0.0d0
11088       s8=0.0d0
11089       s13=0.0d0
11090 c
11091       eello_turn6=0.0d0
11092       j=i+4
11093       k=i+1
11094       l=i+3
11095       iti=itype2loc(itype(i))
11096       itk=itype2loc(itype(k))
11097       itk1=itype2loc(itype(k+1))
11098       itl=itype2loc(itype(l))
11099       itj=itype2loc(itype(j))
11100 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11101 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11102 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11103 cd        eello6=0.0d0
11104 cd        return
11105 cd      endif
11106 cd      write (iout,*)
11107 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11108 cd     &   ' and',k,l
11109 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11110       do iii=1,2
11111         do kkk=1,5
11112           do lll=1,3
11113             derx_turn(lll,kkk,iii)=0.0d0
11114           enddo
11115         enddo
11116       enddo
11117 cd      eij=1.0d0
11118 cd      ekl=1.0d0
11119 cd      ekont=1.0d0
11120       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11121 cd      eello6_5=0.0d0
11122 cd      write (2,*) 'eello6_5',eello6_5
11123 #ifdef MOMENT
11124       call transpose2(AEA(1,1,1),auxmat(1,1))
11125       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11126       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11127       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11128 #endif
11129       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11130       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11131       s2 = scalar2(b1(1,k),vtemp1(1))
11132 #ifdef MOMENT
11133       call transpose2(AEA(1,1,2),atemp(1,1))
11134       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11135       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11136       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11137 #endif
11138       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11139       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11140       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11141 #ifdef MOMENT
11142       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11143       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11144       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11145       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11146       ss13 = scalar2(b1(1,k),vtemp4(1))
11147       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11148 #endif
11149 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11150 c      s1=0.0d0
11151 c      s2=0.0d0
11152 c      s8=0.0d0
11153 c      s12=0.0d0
11154 c      s13=0.0d0
11155       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11156 C Derivatives in gamma(i+2)
11157       s1d =0.0d0
11158       s8d =0.0d0
11159 #ifdef MOMENT
11160       call transpose2(AEA(1,1,1),auxmatd(1,1))
11161       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11162       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11163       call transpose2(AEAderg(1,1,2),atempd(1,1))
11164       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11165       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11166 #endif
11167       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11168       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11169       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11170 c      s1d=0.0d0
11171 c      s2d=0.0d0
11172 c      s8d=0.0d0
11173 c      s12d=0.0d0
11174 c      s13d=0.0d0
11175       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11176 C Derivatives in gamma(i+3)
11177 #ifdef MOMENT
11178       call transpose2(AEA(1,1,1),auxmatd(1,1))
11179       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11180       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11181       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11182 #endif
11183       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11184       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11185       s2d = scalar2(b1(1,k),vtemp1d(1))
11186 #ifdef MOMENT
11187       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11188       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11189 #endif
11190       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11191 #ifdef MOMENT
11192       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11193       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11194       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11195 #endif
11196 c      s1d=0.0d0
11197 c      s2d=0.0d0
11198 c      s8d=0.0d0
11199 c      s12d=0.0d0
11200 c      s13d=0.0d0
11201 #ifdef MOMENT
11202       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11203      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11204 #else
11205       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11206      &               -0.5d0*ekont*(s2d+s12d)
11207 #endif
11208 C Derivatives in gamma(i+4)
11209       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11210       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11211       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11212 #ifdef MOMENT
11213       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11214       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11215       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11216 #endif
11217 c      s1d=0.0d0
11218 c      s2d=0.0d0
11219 c      s8d=0.0d0
11220 C      s12d=0.0d0
11221 c      s13d=0.0d0
11222 #ifdef MOMENT
11223       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11224 #else
11225       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11226 #endif
11227 C Derivatives in gamma(i+5)
11228 #ifdef MOMENT
11229       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11230       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11231       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11232 #endif
11233       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11234       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11235       s2d = scalar2(b1(1,k),vtemp1d(1))
11236 #ifdef MOMENT
11237       call transpose2(AEA(1,1,2),atempd(1,1))
11238       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11239       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11240 #endif
11241       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11242       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11243 #ifdef MOMENT
11244       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11245       ss13d = scalar2(b1(1,k),vtemp4d(1))
11246       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11247 #endif
11248 c      s1d=0.0d0
11249 c      s2d=0.0d0
11250 c      s8d=0.0d0
11251 c      s12d=0.0d0
11252 c      s13d=0.0d0
11253 #ifdef MOMENT
11254       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11255      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11256 #else
11257       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11258      &               -0.5d0*ekont*(s2d+s12d)
11259 #endif
11260 C Cartesian derivatives
11261       do iii=1,2
11262         do kkk=1,5
11263           do lll=1,3
11264 #ifdef MOMENT
11265             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11266             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11267             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11268 #endif
11269             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11270             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11271      &          vtemp1d(1))
11272             s2d = scalar2(b1(1,k),vtemp1d(1))
11273 #ifdef MOMENT
11274             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11275             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11276             s8d = -(atempd(1,1)+atempd(2,2))*
11277      &           scalar2(cc(1,1,itl),vtemp2(1))
11278 #endif
11279             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11280      &           auxmatd(1,1))
11281             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11282             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11283 c      s1d=0.0d0
11284 c      s2d=0.0d0
11285 c      s8d=0.0d0
11286 c      s12d=0.0d0
11287 c      s13d=0.0d0
11288 #ifdef MOMENT
11289             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11290      &        - 0.5d0*(s1d+s2d)
11291 #else
11292             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11293      &        - 0.5d0*s2d
11294 #endif
11295 #ifdef MOMENT
11296             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11297      &        - 0.5d0*(s8d+s12d)
11298 #else
11299             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11300      &        - 0.5d0*s12d
11301 #endif
11302           enddo
11303         enddo
11304       enddo
11305 #ifdef MOMENT
11306       do kkk=1,5
11307         do lll=1,3
11308           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11309      &      achuj_tempd(1,1))
11310           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11311           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11312           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11313           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11314           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11315      &      vtemp4d(1))
11316           ss13d = scalar2(b1(1,k),vtemp4d(1))
11317           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11318           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11319         enddo
11320       enddo
11321 #endif
11322 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11323 cd     &  16*eel_turn6_num
11324 cd      goto 1112
11325       if (j.lt.nres-1) then
11326         j1=j+1
11327         j2=j-1
11328       else
11329         j1=j-1
11330         j2=j-2
11331       endif
11332       if (l.lt.nres-1) then
11333         l1=l+1
11334         l2=l-1
11335       else
11336         l1=l-1
11337         l2=l-2
11338       endif
11339       do ll=1,3
11340 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11341 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11342 cgrad        ghalf=0.5d0*ggg1(ll)
11343 cd        ghalf=0.0d0
11344         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11345         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11346         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11347      &    +ekont*derx_turn(ll,2,1)
11348         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11349         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11350      &    +ekont*derx_turn(ll,4,1)
11351         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11352         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11353         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11354 cgrad        ghalf=0.5d0*ggg2(ll)
11355 cd        ghalf=0.0d0
11356         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11357      &    +ekont*derx_turn(ll,2,2)
11358         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11359         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11360      &    +ekont*derx_turn(ll,4,2)
11361         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11362         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11363         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11364       enddo
11365 cd      goto 1112
11366 cgrad      do m=i+1,j-1
11367 cgrad        do ll=1,3
11368 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11369 cgrad        enddo
11370 cgrad      enddo
11371 cgrad      do m=k+1,l-1
11372 cgrad        do ll=1,3
11373 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11374 cgrad        enddo
11375 cgrad      enddo
11376 cgrad1112  continue
11377 cgrad      do m=i+2,j2
11378 cgrad        do ll=1,3
11379 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11380 cgrad        enddo
11381 cgrad      enddo
11382 cgrad      do m=k+2,l2
11383 cgrad        do ll=1,3
11384 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11385 cgrad        enddo
11386 cgrad      enddo
11387 cd      do iii=1,nres-3
11388 cd        write (2,*) iii,g_corr6_loc(iii)
11389 cd      enddo
11390       eello_turn6=ekont*eel_turn6
11391 cd      write (2,*) 'ekont',ekont
11392 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11393       return
11394       end
11395
11396 C-----------------------------------------------------------------------------
11397       double precision function scalar(u,v)
11398 !DIR$ INLINEALWAYS scalar
11399 #ifndef OSF
11400 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11401 #endif
11402       implicit none
11403       double precision u(3),v(3)
11404 cd      double precision sc
11405 cd      integer i
11406 cd      sc=0.0d0
11407 cd      do i=1,3
11408 cd        sc=sc+u(i)*v(i)
11409 cd      enddo
11410 cd      scalar=sc
11411
11412       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11413       return
11414       end
11415 crc-------------------------------------------------
11416       SUBROUTINE MATVEC2(A1,V1,V2)
11417 !DIR$ INLINEALWAYS MATVEC2
11418 #ifndef OSF
11419 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11420 #endif
11421       implicit real*8 (a-h,o-z)
11422       include 'DIMENSIONS'
11423       DIMENSION A1(2,2),V1(2),V2(2)
11424 c      DO 1 I=1,2
11425 c        VI=0.0
11426 c        DO 3 K=1,2
11427 c    3     VI=VI+A1(I,K)*V1(K)
11428 c        Vaux(I)=VI
11429 c    1 CONTINUE
11430
11431       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11432       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11433
11434       v2(1)=vaux1
11435       v2(2)=vaux2
11436       END
11437 C---------------------------------------
11438       SUBROUTINE MATMAT2(A1,A2,A3)
11439 #ifndef OSF
11440 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11441 #endif
11442       implicit real*8 (a-h,o-z)
11443       include 'DIMENSIONS'
11444       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11445 c      DIMENSION AI3(2,2)
11446 c        DO  J=1,2
11447 c          A3IJ=0.0
11448 c          DO K=1,2
11449 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11450 c          enddo
11451 c          A3(I,J)=A3IJ
11452 c       enddo
11453 c      enddo
11454
11455       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11456       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11457       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11458       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11459
11460       A3(1,1)=AI3_11
11461       A3(2,1)=AI3_21
11462       A3(1,2)=AI3_12
11463       A3(2,2)=AI3_22
11464       END
11465
11466 c-------------------------------------------------------------------------
11467       double precision function scalar2(u,v)
11468 !DIR$ INLINEALWAYS scalar2
11469       implicit none
11470       double precision u(2),v(2)
11471       double precision sc
11472       integer i
11473       scalar2=u(1)*v(1)+u(2)*v(2)
11474       return
11475       end
11476
11477 C-----------------------------------------------------------------------------
11478
11479       subroutine transpose2(a,at)
11480 !DIR$ INLINEALWAYS transpose2
11481 #ifndef OSF
11482 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11483 #endif
11484       implicit none
11485       double precision a(2,2),at(2,2)
11486       at(1,1)=a(1,1)
11487       at(1,2)=a(2,1)
11488       at(2,1)=a(1,2)
11489       at(2,2)=a(2,2)
11490       return
11491       end
11492 c--------------------------------------------------------------------------
11493       subroutine transpose(n,a,at)
11494       implicit none
11495       integer n,i,j
11496       double precision a(n,n),at(n,n)
11497       do i=1,n
11498         do j=1,n
11499           at(j,i)=a(i,j)
11500         enddo
11501       enddo
11502       return
11503       end
11504 C---------------------------------------------------------------------------
11505       subroutine prodmat3(a1,a2,kk,transp,prod)
11506 !DIR$ INLINEALWAYS prodmat3
11507 #ifndef OSF
11508 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11509 #endif
11510       implicit none
11511       integer i,j
11512       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11513       logical transp
11514 crc      double precision auxmat(2,2),prod_(2,2)
11515
11516       if (transp) then
11517 crc        call transpose2(kk(1,1),auxmat(1,1))
11518 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11519 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11520
11521            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11522      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11523            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11524      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11525            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11526      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11527            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11528      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11529
11530       else
11531 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11532 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11533
11534            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11535      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11536            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11537      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11538            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11539      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11540            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11541      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11542
11543       endif
11544 c      call transpose2(a2(1,1),a2t(1,1))
11545
11546 crc      print *,transp
11547 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11548 crc      print *,((prod(i,j),i=1,2),j=1,2)
11549
11550       return
11551       end
11552 CCC----------------------------------------------
11553       subroutine Eliptransfer(eliptran)
11554       implicit real*8 (a-h,o-z)
11555       include 'DIMENSIONS'
11556       include 'COMMON.GEO'
11557       include 'COMMON.VAR'
11558       include 'COMMON.LOCAL'
11559       include 'COMMON.CHAIN'
11560       include 'COMMON.DERIV'
11561       include 'COMMON.NAMES'
11562       include 'COMMON.INTERACT'
11563       include 'COMMON.IOUNITS'
11564       include 'COMMON.CALC'
11565       include 'COMMON.CONTROL'
11566       include 'COMMON.SPLITELE'
11567       include 'COMMON.SBRIDGE'
11568 C this is done by Adasko
11569 C      print *,"wchodze"
11570 C structure of box:
11571 C      water
11572 C--bordliptop-- buffore starts
11573 C--bufliptop--- here true lipid starts
11574 C      lipid
11575 C--buflipbot--- lipid ends buffore starts
11576 C--bordlipbot--buffore ends
11577       eliptran=0.0
11578       do i=ilip_start,ilip_end
11579 C       do i=1,1
11580         if (itype(i).eq.ntyp1) cycle
11581
11582         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11583         if (positi.le.0.0) positi=positi+boxzsize
11584 C        print *,i
11585 C first for peptide groups
11586 c for each residue check if it is in lipid or lipid water border area
11587        if ((positi.gt.bordlipbot)
11588      &.and.(positi.lt.bordliptop)) then
11589 C the energy transfer exist
11590         if (positi.lt.buflipbot) then
11591 C what fraction I am in
11592          fracinbuf=1.0d0-
11593      &        ((positi-bordlipbot)/lipbufthick)
11594 C lipbufthick is thickenes of lipid buffore
11595          sslip=sscalelip(fracinbuf)
11596          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11597          eliptran=eliptran+sslip*pepliptran
11598          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11599          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11600 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11601
11602 C        print *,"doing sccale for lower part"
11603 C         print *,i,sslip,fracinbuf,ssgradlip
11604         elseif (positi.gt.bufliptop) then
11605          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11606          sslip=sscalelip(fracinbuf)
11607          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11608          eliptran=eliptran+sslip*pepliptran
11609          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11610          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11611 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11612 C          print *, "doing sscalefor top part"
11613 C         print *,i,sslip,fracinbuf,ssgradlip
11614         else
11615          eliptran=eliptran+pepliptran
11616 C         print *,"I am in true lipid"
11617         endif
11618 C       else
11619 C       eliptran=elpitran+0.0 ! I am in water
11620        endif
11621        enddo
11622 C       print *, "nic nie bylo w lipidzie?"
11623 C now multiply all by the peptide group transfer factor
11624 C       eliptran=eliptran*pepliptran
11625 C now the same for side chains
11626 CV       do i=1,1
11627        do i=ilip_start,ilip_end
11628         if (itype(i).eq.ntyp1) cycle
11629         positi=(mod(c(3,i+nres),boxzsize))
11630         if (positi.le.0) positi=positi+boxzsize
11631 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11632 c for each residue check if it is in lipid or lipid water border area
11633 C       respos=mod(c(3,i+nres),boxzsize)
11634 C       print *,positi,bordlipbot,buflipbot
11635        if ((positi.gt.bordlipbot)
11636      & .and.(positi.lt.bordliptop)) then
11637 C the energy transfer exist
11638         if (positi.lt.buflipbot) then
11639          fracinbuf=1.0d0-
11640      &     ((positi-bordlipbot)/lipbufthick)
11641 C lipbufthick is thickenes of lipid buffore
11642          sslip=sscalelip(fracinbuf)
11643          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11644          eliptran=eliptran+sslip*liptranene(itype(i))
11645          gliptranx(3,i)=gliptranx(3,i)
11646      &+ssgradlip*liptranene(itype(i))
11647          gliptranc(3,i-1)= gliptranc(3,i-1)
11648      &+ssgradlip*liptranene(itype(i))
11649 C         print *,"doing sccale for lower part"
11650         elseif (positi.gt.bufliptop) then
11651          fracinbuf=1.0d0-
11652      &((bordliptop-positi)/lipbufthick)
11653          sslip=sscalelip(fracinbuf)
11654          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11655          eliptran=eliptran+sslip*liptranene(itype(i))
11656          gliptranx(3,i)=gliptranx(3,i)
11657      &+ssgradlip*liptranene(itype(i))
11658          gliptranc(3,i-1)= gliptranc(3,i-1)
11659      &+ssgradlip*liptranene(itype(i))
11660 C          print *, "doing sscalefor top part",sslip,fracinbuf
11661         else
11662          eliptran=eliptran+liptranene(itype(i))
11663 C         print *,"I am in true lipid"
11664         endif
11665         endif ! if in lipid or buffor
11666 C       else
11667 C       eliptran=elpitran+0.0 ! I am in water
11668        enddo
11669        return
11670        end
11671 C---------------------------------------------------------
11672 C AFM soubroutine for constant force
11673        subroutine AFMforce(Eafmforce)
11674        implicit real*8 (a-h,o-z)
11675       include 'DIMENSIONS'
11676       include 'COMMON.GEO'
11677       include 'COMMON.VAR'
11678       include 'COMMON.LOCAL'
11679       include 'COMMON.CHAIN'
11680       include 'COMMON.DERIV'
11681       include 'COMMON.NAMES'
11682       include 'COMMON.INTERACT'
11683       include 'COMMON.IOUNITS'
11684       include 'COMMON.CALC'
11685       include 'COMMON.CONTROL'
11686       include 'COMMON.SPLITELE'
11687       include 'COMMON.SBRIDGE'
11688       real*8 diffafm(3)
11689       dist=0.0d0
11690       Eafmforce=0.0d0
11691       do i=1,3
11692       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11693       dist=dist+diffafm(i)**2
11694       enddo
11695       dist=dsqrt(dist)
11696       Eafmforce=-forceAFMconst*(dist-distafminit)
11697       do i=1,3
11698       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11699       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11700       enddo
11701 C      print *,'AFM',Eafmforce
11702       return
11703       end
11704 C---------------------------------------------------------
11705 C AFM subroutine with pseudoconstant velocity
11706        subroutine AFMvel(Eafmforce)
11707        implicit real*8 (a-h,o-z)
11708       include 'DIMENSIONS'
11709       include 'COMMON.GEO'
11710       include 'COMMON.VAR'
11711       include 'COMMON.LOCAL'
11712       include 'COMMON.CHAIN'
11713       include 'COMMON.DERIV'
11714       include 'COMMON.NAMES'
11715       include 'COMMON.INTERACT'
11716       include 'COMMON.IOUNITS'
11717       include 'COMMON.CALC'
11718       include 'COMMON.CONTROL'
11719       include 'COMMON.SPLITELE'
11720       include 'COMMON.SBRIDGE'
11721       real*8 diffafm(3)
11722 C Only for check grad COMMENT if not used for checkgrad
11723 C      totT=3.0d0
11724 C--------------------------------------------------------
11725 C      print *,"wchodze"
11726       dist=0.0d0
11727       Eafmforce=0.0d0
11728       do i=1,3
11729       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11730       dist=dist+diffafm(i)**2
11731       enddo
11732       dist=dsqrt(dist)
11733       Eafmforce=0.5d0*forceAFMconst
11734      & *(distafminit+totTafm*velAFMconst-dist)**2
11735 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11736       do i=1,3
11737       gradafm(i,afmend-1)=-forceAFMconst*
11738      &(distafminit+totTafm*velAFMconst-dist)
11739      &*diffafm(i)/dist
11740       gradafm(i,afmbeg-1)=forceAFMconst*
11741      &(distafminit+totTafm*velAFMconst-dist)
11742      &*diffafm(i)/dist
11743       enddo
11744 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11745       return
11746       end
11747 C-----------------------------------------------------------
11748 C first for shielding is setting of function of side-chains
11749        subroutine set_shield_fac
11750       implicit real*8 (a-h,o-z)
11751       include 'DIMENSIONS'
11752       include 'COMMON.CHAIN'
11753       include 'COMMON.DERIV'
11754       include 'COMMON.IOUNITS'
11755       include 'COMMON.SHIELD'
11756       include 'COMMON.INTERACT'
11757 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11758       double precision div77_81/0.974996043d0/,
11759      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11760
11761 C the vector between center of side_chain and peptide group
11762        double precision pep_side(3),long,side_calf(3),
11763      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11764      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11765 C the line belowe needs to be changed for FGPROC>1
11766       do i=1,nres-1
11767       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11768       ishield_list(i)=0
11769 Cif there two consequtive dummy atoms there is no peptide group between them
11770 C the line below has to be changed for FGPROC>1
11771       VolumeTotal=0.0
11772       do k=1,nres
11773        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11774        dist_pep_side=0.0
11775        dist_side_calf=0.0
11776        do j=1,3
11777 C first lets set vector conecting the ithe side-chain with kth side-chain
11778       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11779 C      pep_side(j)=2.0d0
11780 C and vector conecting the side-chain with its proper calfa
11781       side_calf(j)=c(j,k+nres)-c(j,k)
11782 C      side_calf(j)=2.0d0
11783       pept_group(j)=c(j,i)-c(j,i+1)
11784 C lets have their lenght
11785       dist_pep_side=pep_side(j)**2+dist_pep_side
11786       dist_side_calf=dist_side_calf+side_calf(j)**2
11787       dist_pept_group=dist_pept_group+pept_group(j)**2
11788       enddo
11789        dist_pep_side=dsqrt(dist_pep_side)
11790        dist_pept_group=dsqrt(dist_pept_group)
11791        dist_side_calf=dsqrt(dist_side_calf)
11792       do j=1,3
11793         pep_side_norm(j)=pep_side(j)/dist_pep_side
11794         side_calf_norm(j)=dist_side_calf
11795       enddo
11796 C now sscale fraction
11797        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11798 C       print *,buff_shield,"buff"
11799 C now sscale
11800         if (sh_frac_dist.le.0.0) cycle
11801 C If we reach here it means that this side chain reaches the shielding sphere
11802 C Lets add him to the list for gradient
11803         ishield_list(i)=ishield_list(i)+1
11804 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11805 C this list is essential otherwise problem would be O3
11806         shield_list(ishield_list(i),i)=k
11807 C Lets have the sscale value
11808         if (sh_frac_dist.gt.1.0) then
11809          scale_fac_dist=1.0d0
11810          do j=1,3
11811          sh_frac_dist_grad(j)=0.0d0
11812          enddo
11813         else
11814          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11815      &                   *(2.0*sh_frac_dist-3.0d0)
11816          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11817      &                  /dist_pep_side/buff_shield*0.5
11818 C remember for the final gradient multiply sh_frac_dist_grad(j)
11819 C for side_chain by factor -2 !
11820          do j=1,3
11821          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11822 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11823 C     &                    sh_frac_dist_grad(j)
11824          enddo
11825         endif
11826 C        if ((i.eq.3).and.(k.eq.2)) then
11827 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11828 C     & ,"TU"
11829 C        endif
11830
11831 C this is what is now we have the distance scaling now volume...
11832       short=short_r_sidechain(itype(k))
11833       long=long_r_sidechain(itype(k))
11834       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11835 C now costhet_grad
11836 C       costhet=0.0d0
11837        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11838 C       costhet_fac=0.0d0
11839        do j=1,3
11840          costhet_grad(j)=costhet_fac*pep_side(j)
11841        enddo
11842 C remember for the final gradient multiply costhet_grad(j)
11843 C for side_chain by factor -2 !
11844 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11845 C pep_side0pept_group is vector multiplication
11846       pep_side0pept_group=0.0
11847       do j=1,3
11848       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11849       enddo
11850       cosalfa=(pep_side0pept_group/
11851      & (dist_pep_side*dist_side_calf))
11852       fac_alfa_sin=1.0-cosalfa**2
11853       fac_alfa_sin=dsqrt(fac_alfa_sin)
11854       rkprim=fac_alfa_sin*(long-short)+short
11855 C now costhet_grad
11856        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11857        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11858
11859        do j=1,3
11860          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11861      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11862      &*(long-short)/fac_alfa_sin*cosalfa/
11863      &((dist_pep_side*dist_side_calf))*
11864      &((side_calf(j))-cosalfa*
11865      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11866
11867         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11868      &*(long-short)/fac_alfa_sin*cosalfa
11869      &/((dist_pep_side*dist_side_calf))*
11870      &(pep_side(j)-
11871      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11872        enddo
11873
11874       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11875      &                    /VSolvSphere_div
11876      &                    *wshield
11877 C now the gradient...
11878 C grad_shield is gradient of Calfa for peptide groups
11879 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11880 C     &               costhet,cosphi
11881 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11882 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11883       do j=1,3
11884       grad_shield(j,i)=grad_shield(j,i)
11885 C gradient po skalowaniu
11886      &                +(sh_frac_dist_grad(j)
11887 C  gradient po costhet
11888      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11889      &-scale_fac_dist*(cosphi_grad_long(j))
11890      &/(1.0-cosphi) )*div77_81
11891      &*VofOverlap
11892 C grad_shield_side is Cbeta sidechain gradient
11893       grad_shield_side(j,ishield_list(i),i)=
11894      &        (sh_frac_dist_grad(j)*-2.0d0
11895      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11896      &       +scale_fac_dist*(cosphi_grad_long(j))
11897      &        *2.0d0/(1.0-cosphi))
11898      &        *div77_81*VofOverlap
11899
11900        grad_shield_loc(j,ishield_list(i),i)=
11901      &   scale_fac_dist*cosphi_grad_loc(j)
11902      &        *2.0d0/(1.0-cosphi)
11903      &        *div77_81*VofOverlap
11904       enddo
11905       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11906       enddo
11907       fac_shield(i)=VolumeTotal*div77_81+div4_81
11908 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11909       enddo
11910       return
11911       end
11912 C--------------------------------------------------------------------------
11913       double precision function tschebyshev(m,n,x,y)
11914       implicit none
11915       include "DIMENSIONS"
11916       integer i,m,n
11917       double precision x(n),y,yy(0:maxvar),aux
11918 c Tschebyshev polynomial. Note that the first term is omitted
11919 c m=0: the constant term is included
11920 c m=1: the constant term is not included
11921       yy(0)=1.0d0
11922       yy(1)=y
11923       do i=2,n
11924         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11925       enddo
11926       aux=0.0d0
11927       do i=m,n
11928         aux=aux+x(i)*yy(i)
11929       enddo
11930       tschebyshev=aux
11931       return
11932       end
11933 C--------------------------------------------------------------------------
11934       double precision function gradtschebyshev(m,n,x,y)
11935       implicit none
11936       include "DIMENSIONS"
11937       integer i,m,n
11938       double precision x(n+1),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)=2.0d0*y
11944       do i=2,n
11945         yy(i)=2*y*yy(i-1)-yy(i-2)
11946       enddo
11947       aux=0.0d0
11948       do i=m,n
11949         aux=aux+x(i+1)*yy(i)*(i+1)
11950 C        print *, x(i+1),yy(i),i
11951       enddo
11952       gradtschebyshev=aux
11953       return
11954       end
11955 C------------------------------------------------------------------------
11956 C first for shielding is setting of function of side-chains
11957        subroutine set_shield_fac2
11958       implicit real*8 (a-h,o-z)
11959       include 'DIMENSIONS'
11960       include 'COMMON.CHAIN'
11961       include 'COMMON.DERIV'
11962       include 'COMMON.IOUNITS'
11963       include 'COMMON.SHIELD'
11964       include 'COMMON.INTERACT'
11965       include 'COMMON.LOCAL'
11966
11967 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11968       double precision div77_81/0.974996043d0/,
11969      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11970
11971 C the vector between center of side_chain and peptide group
11972        double precision pep_side(3),long,side_calf(3),
11973      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11974      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11975 C      write(2,*) "ivec",ivec_start,ivec_end
11976       do i=1,nres
11977         fac_shield(i)=0.0d0
11978         do j=1,3
11979         grad_shield(j,i)=0.0d0
11980         enddo
11981       enddo
11982 C the line belowe needs to be changed for FGPROC>1
11983       do i=ivec_start,ivec_end
11984 C      do i=1,nres-1
11985 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11986       ishield_list(i)=0
11987       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11988 Cif there two consequtive dummy atoms there is no peptide group between them
11989 C the line below has to be changed for FGPROC>1
11990       VolumeTotal=0.0
11991       do k=1,nres
11992        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11993        dist_pep_side=0.0
11994        dist_side_calf=0.0
11995        do j=1,3
11996 C first lets set vector conecting the ithe side-chain with kth side-chain
11997       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11998 C      pep_side(j)=2.0d0
11999 C and vector conecting the side-chain with its proper calfa
12000       side_calf(j)=c(j,k+nres)-c(j,k)
12001 C      side_calf(j)=2.0d0
12002       pept_group(j)=c(j,i)-c(j,i+1)
12003 C lets have their lenght
12004       dist_pep_side=pep_side(j)**2+dist_pep_side
12005       dist_side_calf=dist_side_calf+side_calf(j)**2
12006       dist_pept_group=dist_pept_group+pept_group(j)**2
12007       enddo
12008        dist_pep_side=dsqrt(dist_pep_side)
12009        dist_pept_group=dsqrt(dist_pept_group)
12010        dist_side_calf=dsqrt(dist_side_calf)
12011       do j=1,3
12012         pep_side_norm(j)=pep_side(j)/dist_pep_side
12013         side_calf_norm(j)=dist_side_calf
12014       enddo
12015 C now sscale fraction
12016        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12017 C       print *,buff_shield,"buff"
12018 C now sscale
12019         if (sh_frac_dist.le.0.0) cycle
12020 C        print *,ishield_list(i),i
12021 C If we reach here it means that this side chain reaches the shielding sphere
12022 C Lets add him to the list for gradient
12023         ishield_list(i)=ishield_list(i)+1
12024 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12025 C this list is essential otherwise problem would be O3
12026         shield_list(ishield_list(i),i)=k
12027 C Lets have the sscale value
12028         if (sh_frac_dist.gt.1.0) then
12029          scale_fac_dist=1.0d0
12030          do j=1,3
12031          sh_frac_dist_grad(j)=0.0d0
12032          enddo
12033         else
12034          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12035      &                   *(2.0d0*sh_frac_dist-3.0d0)
12036          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12037      &                  /dist_pep_side/buff_shield*0.5d0
12038 C remember for the final gradient multiply sh_frac_dist_grad(j)
12039 C for side_chain by factor -2 !
12040          do j=1,3
12041          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12042 C         sh_frac_dist_grad(j)=0.0d0
12043 C         scale_fac_dist=1.0d0
12044 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12045 C     &                    sh_frac_dist_grad(j)
12046          enddo
12047         endif
12048 C this is what is now we have the distance scaling now volume...
12049       short=short_r_sidechain(itype(k))
12050       long=long_r_sidechain(itype(k))
12051       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12052       sinthet=short/dist_pep_side*costhet
12053 C now costhet_grad
12054 C       costhet=0.6d0
12055 C       sinthet=0.8
12056        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12057 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12058 C     &             -short/dist_pep_side**2/costhet)
12059 C       costhet_fac=0.0d0
12060        do j=1,3
12061          costhet_grad(j)=costhet_fac*pep_side(j)
12062        enddo
12063 C remember for the final gradient multiply costhet_grad(j)
12064 C for side_chain by factor -2 !
12065 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12066 C pep_side0pept_group is vector multiplication
12067       pep_side0pept_group=0.0d0
12068       do j=1,3
12069       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12070       enddo
12071       cosalfa=(pep_side0pept_group/
12072      & (dist_pep_side*dist_side_calf))
12073       fac_alfa_sin=1.0d0-cosalfa**2
12074       fac_alfa_sin=dsqrt(fac_alfa_sin)
12075       rkprim=fac_alfa_sin*(long-short)+short
12076 C      rkprim=short
12077
12078 C now costhet_grad
12079        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12080 C       cosphi=0.6
12081        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12082        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12083      &      dist_pep_side**2)
12084 C       sinphi=0.8
12085        do j=1,3
12086          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12087      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12088      &*(long-short)/fac_alfa_sin*cosalfa/
12089      &((dist_pep_side*dist_side_calf))*
12090      &((side_calf(j))-cosalfa*
12091      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12092 C       cosphi_grad_long(j)=0.0d0
12093         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12094      &*(long-short)/fac_alfa_sin*cosalfa
12095      &/((dist_pep_side*dist_side_calf))*
12096      &(pep_side(j)-
12097      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12098 C       cosphi_grad_loc(j)=0.0d0
12099        enddo
12100 C      print *,sinphi,sinthet
12101       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12102      &                    /VSolvSphere_div
12103 C     &                    *wshield
12104 C now the gradient...
12105       do j=1,3
12106       grad_shield(j,i)=grad_shield(j,i)
12107 C gradient po skalowaniu
12108      &                +(sh_frac_dist_grad(j)*VofOverlap
12109 C  gradient po costhet
12110      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12111      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12112      &       sinphi/sinthet*costhet*costhet_grad(j)
12113      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12114      & )*wshield
12115 C grad_shield_side is Cbeta sidechain gradient
12116       grad_shield_side(j,ishield_list(i),i)=
12117      &        (sh_frac_dist_grad(j)*-2.0d0
12118      &        *VofOverlap
12119      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12120      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12121      &       sinphi/sinthet*costhet*costhet_grad(j)
12122      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12123      &       )*wshield
12124
12125        grad_shield_loc(j,ishield_list(i),i)=
12126      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12127      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12128      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12129      &        ))
12130      &        *wshield
12131       enddo
12132       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12133       enddo
12134       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12135 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12136       enddo
12137       return
12138       end
12139 C-----------------------------------------------------------------------
12140 C-----------------------------------------------------------
12141 C This subroutine is to mimic the histone like structure but as well can be
12142 C utilizet to nanostructures (infinit) small modification has to be used to
12143 C make it finite (z gradient at the ends has to be changes as well as the x,y
12144 C gradient has to be modified at the ends
12145 C The energy function is Kihara potential
12146 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12147 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12148 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12149 C simple Kihara potential
12150       subroutine calctube(Etube)
12151        implicit real*8 (a-h,o-z)
12152       include 'DIMENSIONS'
12153       include 'COMMON.GEO'
12154       include 'COMMON.VAR'
12155       include 'COMMON.LOCAL'
12156       include 'COMMON.CHAIN'
12157       include 'COMMON.DERIV'
12158       include 'COMMON.NAMES'
12159       include 'COMMON.INTERACT'
12160       include 'COMMON.IOUNITS'
12161       include 'COMMON.CALC'
12162       include 'COMMON.CONTROL'
12163       include 'COMMON.SPLITELE'
12164       include 'COMMON.SBRIDGE'
12165       double precision tub_r,vectube(3),enetube(maxres*2)
12166       Etube=0.0d0
12167       do i=itube_start,itube_end
12168         enetube(i)=0.0d0
12169         enetube(i+nres)=0.0d0
12170       enddo
12171 C first we calculate the distance from tube center
12172 C first sugare-phosphate group for NARES this would be peptide group
12173 C for UNRES
12174        do i=itube_start,itube_end
12175 C lets ommit dummy atoms for now
12176        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12177 C now calculate distance from center of tube and direction vectors
12178       xmin=boxxsize
12179       ymin=boxysize
12180         do j=-1,1
12181          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12182          vectube(1)=vectube(1)+boxxsize*j
12183          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12184          vectube(2)=vectube(2)+boxysize*j
12185
12186          xminact=abs(vectube(1)-tubecenter(1))
12187          yminact=abs(vectube(2)-tubecenter(2))
12188            if (xmin.gt.xminact) then
12189             xmin=xminact
12190             xtemp=vectube(1)
12191            endif
12192            if (ymin.gt.yminact) then
12193              ymin=yminact
12194              ytemp=vectube(2)
12195             endif
12196          enddo
12197       vectube(1)=xtemp
12198       vectube(2)=ytemp
12199       vectube(1)=vectube(1)-tubecenter(1)
12200       vectube(2)=vectube(2)-tubecenter(2)
12201
12202 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12203 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12204
12205 C as the tube is infinity we do not calculate the Z-vector use of Z
12206 C as chosen axis
12207       vectube(3)=0.0d0
12208 C now calculte the distance
12209        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12210 C now normalize vector
12211       vectube(1)=vectube(1)/tub_r
12212       vectube(2)=vectube(2)/tub_r
12213 C calculte rdiffrence between r and r0
12214       rdiff=tub_r-tubeR0
12215 C and its 6 power
12216       rdiff6=rdiff**6.0d0
12217 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12218        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12219 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12220 C       print *,rdiff,rdiff6,pep_aa_tube
12221 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12222 C now we calculate gradient
12223        fac=(-12.0d0*pep_aa_tube/rdiff6-
12224      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12225 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12226 C     &rdiff,fac
12227
12228 C now direction of gg_tube vector
12229         do j=1,3
12230         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12231         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12232         enddo
12233         enddo
12234 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12235 C        print *,gg_tube(1,0),"TU"
12236
12237
12238        do i=itube_start,itube_end
12239 C Lets not jump over memory as we use many times iti
12240          iti=itype(i)
12241 C lets ommit dummy atoms for now
12242          if ((iti.eq.ntyp1)
12243 C in UNRES uncomment the line below as GLY has no side-chain...
12244 C      .or.(iti.eq.10)
12245      &   ) cycle
12246       xmin=boxxsize
12247       ymin=boxysize
12248         do j=-1,1
12249          vectube(1)=mod((c(1,i+nres)),boxxsize)
12250          vectube(1)=vectube(1)+boxxsize*j
12251          vectube(2)=mod((c(2,i+nres)),boxysize)
12252          vectube(2)=vectube(2)+boxysize*j
12253
12254          xminact=abs(vectube(1)-tubecenter(1))
12255          yminact=abs(vectube(2)-tubecenter(2))
12256            if (xmin.gt.xminact) then
12257             xmin=xminact
12258             xtemp=vectube(1)
12259            endif
12260            if (ymin.gt.yminact) then
12261              ymin=yminact
12262              ytemp=vectube(2)
12263             endif
12264          enddo
12265       vectube(1)=xtemp
12266       vectube(2)=ytemp
12267 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12268 C     &     tubecenter(2)
12269       vectube(1)=vectube(1)-tubecenter(1)
12270       vectube(2)=vectube(2)-tubecenter(2)
12271
12272 C as the tube is infinity we do not calculate the Z-vector use of Z
12273 C as chosen axis
12274       vectube(3)=0.0d0
12275 C now calculte the distance
12276        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12277 C now normalize vector
12278       vectube(1)=vectube(1)/tub_r
12279       vectube(2)=vectube(2)/tub_r
12280
12281 C calculte rdiffrence between r and r0
12282       rdiff=tub_r-tubeR0
12283 C and its 6 power
12284       rdiff6=rdiff**6.0d0
12285 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12286        sc_aa_tube=sc_aa_tube_par(iti)
12287        sc_bb_tube=sc_bb_tube_par(iti)
12288        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12289 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12290 C now we calculate gradient
12291        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12292      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12293 C now direction of gg_tube vector
12294          do j=1,3
12295           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12296           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12297          enddo
12298         enddo
12299         do i=itube_start,itube_end
12300           Etube=Etube+enetube(i)+enetube(i+nres)
12301         enddo
12302 C        print *,"ETUBE", etube
12303         return
12304         end
12305 C TO DO 1) add to total energy
12306 C       2) add to gradient summation
12307 C       3) add reading parameters (AND of course oppening of PARAM file)
12308 C       4) add reading the center of tube
12309 C       5) add COMMONs
12310 C       6) add to zerograd
12311
12312 C-----------------------------------------------------------------------
12313 C-----------------------------------------------------------
12314 C This subroutine is to mimic the histone like structure but as well can be
12315 C utilizet to nanostructures (infinit) small modification has to be used to
12316 C make it finite (z gradient at the ends has to be changes as well as the x,y
12317 C gradient has to be modified at the ends
12318 C The energy function is Kihara potential
12319 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12320 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12321 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12322 C simple Kihara potential
12323       subroutine calctube2(Etube)
12324        implicit real*8 (a-h,o-z)
12325       include 'DIMENSIONS'
12326       include 'COMMON.GEO'
12327       include 'COMMON.VAR'
12328       include 'COMMON.LOCAL'
12329       include 'COMMON.CHAIN'
12330       include 'COMMON.DERIV'
12331       include 'COMMON.NAMES'
12332       include 'COMMON.INTERACT'
12333       include 'COMMON.IOUNITS'
12334       include 'COMMON.CALC'
12335       include 'COMMON.CONTROL'
12336       include 'COMMON.SPLITELE'
12337       include 'COMMON.SBRIDGE'
12338       double precision tub_r,vectube(3),enetube(maxres*2)
12339       Etube=0.0d0
12340       do i=itube_start,itube_end
12341         enetube(i)=0.0d0
12342         enetube(i+nres)=0.0d0
12343       enddo
12344 C first we calculate the distance from tube center
12345 C first sugare-phosphate group for NARES this would be peptide group
12346 C for UNRES
12347        do i=itube_start,itube_end
12348 C lets ommit dummy atoms for now
12349
12350        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12351 C now calculate distance from center of tube and direction vectors
12352 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12353 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12354 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12355 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12356       xmin=boxxsize
12357       ymin=boxysize
12358         do j=-1,1
12359          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12360          vectube(1)=vectube(1)+boxxsize*j
12361          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12362          vectube(2)=vectube(2)+boxysize*j
12363
12364          xminact=abs(vectube(1)-tubecenter(1))
12365          yminact=abs(vectube(2)-tubecenter(2))
12366            if (xmin.gt.xminact) then
12367             xmin=xminact
12368             xtemp=vectube(1)
12369            endif
12370            if (ymin.gt.yminact) then
12371              ymin=yminact
12372              ytemp=vectube(2)
12373             endif
12374          enddo
12375       vectube(1)=xtemp
12376       vectube(2)=ytemp
12377       vectube(1)=vectube(1)-tubecenter(1)
12378       vectube(2)=vectube(2)-tubecenter(2)
12379
12380 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12381 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12382
12383 C as the tube is infinity we do not calculate the Z-vector use of Z
12384 C as chosen axis
12385       vectube(3)=0.0d0
12386 C now calculte the distance
12387        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12388 C now normalize vector
12389       vectube(1)=vectube(1)/tub_r
12390       vectube(2)=vectube(2)/tub_r
12391 C calculte rdiffrence between r and r0
12392       rdiff=tub_r-tubeR0
12393 C and its 6 power
12394       rdiff6=rdiff**6.0d0
12395 C THIS FRAGMENT MAKES TUBE FINITE
12396         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12397         if (positi.le.0) positi=positi+boxzsize
12398 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12399 c for each residue check if it is in lipid or lipid water border area
12400 C       respos=mod(c(3,i+nres),boxzsize)
12401 C       print *,positi,bordtubebot,buftubebot,bordtubetop
12402        if ((positi.gt.bordtubebot)
12403      & .and.(positi.lt.bordtubetop)) then
12404 C the energy transfer exist
12405         if (positi.lt.buftubebot) then
12406          fracinbuf=1.0d0-
12407      &     ((positi-bordtubebot)/tubebufthick)
12408 C lipbufthick is thickenes of lipid buffore
12409          sstube=sscalelip(fracinbuf)
12410          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12411 C         print *,ssgradtube, sstube,tubetranene(itype(i))
12412          enetube(i)=enetube(i)+sstube*tubetranenepep
12413 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12414 C     &+ssgradtube*tubetranene(itype(i))
12415 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12416 C     &+ssgradtube*tubetranene(itype(i))
12417 C         print *,"doing sccale for lower part"
12418         elseif (positi.gt.buftubetop) then
12419          fracinbuf=1.0d0-
12420      &((bordtubetop-positi)/tubebufthick)
12421          sstube=sscalelip(fracinbuf)
12422          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12423          enetube(i)=enetube(i)+sstube*tubetranenepep
12424 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12425 C     &+ssgradtube*tubetranene(itype(i))
12426 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12427 C     &+ssgradtube*tubetranene(itype(i))
12428 C          print *, "doing sscalefor top part",sslip,fracinbuf
12429         else
12430          sstube=1.0d0
12431          ssgradtube=0.0d0
12432          enetube(i)=enetube(i)+sstube*tubetranenepep
12433 C         print *,"I am in true lipid"
12434         endif
12435         else
12436 C          sstube=0.0d0
12437 C          ssgradtube=0.0d0
12438         cycle
12439         endif ! if in lipid or buffor
12440
12441 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12442        enetube(i)=enetube(i)+sstube*
12443      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
12444 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12445 C       print *,rdiff,rdiff6,pep_aa_tube
12446 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12447 C now we calculate gradient
12448        fac=(-12.0d0*pep_aa_tube/rdiff6-
12449      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
12450 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12451 C     &rdiff,fac
12452
12453 C now direction of gg_tube vector
12454         do j=1,3
12455         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12456         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12457         enddo
12458          gg_tube(3,i)=gg_tube(3,i)
12459      &+ssgradtube*enetube(i)/sstube/2.0d0
12460          gg_tube(3,i-1)= gg_tube(3,i-1)
12461      &+ssgradtube*enetube(i)/sstube/2.0d0
12462
12463         enddo
12464 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12465 C        print *,gg_tube(1,0),"TU"
12466         do i=itube_start,itube_end
12467 C Lets not jump over memory as we use many times iti
12468          iti=itype(i)
12469 C lets ommit dummy atoms for now
12470          if ((iti.eq.ntyp1)
12471 C in UNRES uncomment the line below as GLY has no side-chain...
12472      &      .or.(iti.eq.10)
12473      &   ) cycle
12474           vectube(1)=c(1,i+nres)
12475           vectube(1)=mod(vectube(1),boxxsize)
12476           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12477           vectube(2)=c(2,i+nres)
12478           vectube(2)=mod(vectube(2),boxysize)
12479           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12480
12481       vectube(1)=vectube(1)-tubecenter(1)
12482       vectube(2)=vectube(2)-tubecenter(2)
12483 C THIS FRAGMENT MAKES TUBE FINITE
12484         positi=(mod(c(3,i+nres),boxzsize))
12485         if (positi.le.0) positi=positi+boxzsize
12486 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12487 c for each residue check if it is in lipid or lipid water border area
12488 C       respos=mod(c(3,i+nres),boxzsize)
12489 C       print *,positi,bordtubebot,buftubebot,bordtubetop
12490
12491        if ((positi.gt.bordtubebot)
12492      & .and.(positi.lt.bordtubetop)) then
12493 C the energy transfer exist
12494         if (positi.lt.buftubebot) then
12495          fracinbuf=1.0d0-
12496      &     ((positi-bordtubebot)/tubebufthick)
12497 C lipbufthick is thickenes of lipid buffore
12498          sstube=sscalelip(fracinbuf)
12499          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12500 C         print *,ssgradtube, sstube,tubetranene(itype(i))
12501          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12502 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12503 C     &+ssgradtube*tubetranene(itype(i))
12504 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12505 C     &+ssgradtube*tubetranene(itype(i))
12506 C         print *,"doing sccale for lower part"
12507         elseif (positi.gt.buftubetop) then
12508          fracinbuf=1.0d0-
12509      &((bordtubetop-positi)/tubebufthick)
12510          sstube=sscalelip(fracinbuf)
12511          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12512          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12513 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12514 C     &+ssgradtube*tubetranene(itype(i))
12515 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12516 C     &+ssgradtube*tubetranene(itype(i))
12517 C          print *, "doing sscalefor top part",sslip,fracinbuf
12518         else
12519          sstube=1.0d0
12520          ssgradtube=0.0d0
12521          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12522 C         print *,"I am in true lipid"
12523         endif
12524         else
12525 C          sstube=0.0d0
12526 C          ssgradtube=0.0d0
12527         cycle
12528         endif ! if in lipid or buffor
12529 CEND OF FINITE FRAGMENT
12530 C as the tube is infinity we do not calculate the Z-vector use of Z
12531 C as chosen axis
12532       vectube(3)=0.0d0
12533 C now calculte the distance
12534        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12535 C now normalize vector
12536       vectube(1)=vectube(1)/tub_r
12537       vectube(2)=vectube(2)/tub_r
12538 C calculte rdiffrence between r and r0
12539       rdiff=tub_r-tubeR0
12540 C and its 6 power
12541       rdiff6=rdiff**6.0d0
12542 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12543        sc_aa_tube=sc_aa_tube_par(iti)
12544        sc_bb_tube=sc_bb_tube_par(iti)
12545        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12546      &                 *sstube+enetube(i+nres)
12547 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12548 C now we calculate gradient
12549        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12550      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12551 C now direction of gg_tube vector
12552          do j=1,3
12553           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12554           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12555          enddo
12556          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12557      &+ssgradtube*enetube(i+nres)/sstube
12558          gg_tube(3,i-1)= gg_tube(3,i-1)
12559      &+ssgradtube*enetube(i+nres)/sstube
12560
12561         enddo
12562         do i=itube_start,itube_end
12563           Etube=Etube+enetube(i)+enetube(i+nres)
12564         enddo
12565 C        print *,"ETUBE", etube
12566         return
12567         end
12568 C TO DO 1) add to total energy
12569 C       2) add to gradient summation
12570 C       3) add reading parameters (AND of course oppening of PARAM file)
12571 C       4) add reading the center of tube
12572 C       5) add COMMONs
12573 C       6) add to zerograd
12574
12575
12576 C#-------------------------------------------------------------------------------
12577 C This subroutine is to mimic the histone like structure but as well can be
12578 C utilizet to nanostructures (infinit) small modification has to be used to
12579 C make it finite (z gradient at the ends has to be changes as well as the x,y
12580 C gradient has to be modified at the ends
12581 C The energy function is Kihara potential
12582 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12583 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12584 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12585 C simple Kihara potential
12586       subroutine calcnano(Etube)
12587        implicit real*8 (a-h,o-z)
12588       include 'DIMENSIONS'
12589       include 'COMMON.GEO'
12590       include 'COMMON.VAR'
12591       include 'COMMON.LOCAL'
12592       include 'COMMON.CHAIN'
12593       include 'COMMON.DERIV'
12594       include 'COMMON.NAMES'
12595       include 'COMMON.INTERACT'
12596       include 'COMMON.IOUNITS'
12597       include 'COMMON.CALC'
12598       include 'COMMON.CONTROL'
12599       include 'COMMON.SPLITELE'
12600       include 'COMMON.SBRIDGE'
12601       double precision tub_r,vectube(3),enetube(maxres*2),
12602      & enecavtube(maxres*2)
12603       Etube=0.0d0
12604       do i=itube_start,itube_end
12605         enetube(i)=0.0d0
12606         enetube(i+nres)=0.0d0
12607       enddo
12608 C first we calculate the distance from tube center
12609 C first sugare-phosphate group for NARES this would be peptide group
12610 C for UNRES
12611        do i=itube_start,itube_end
12612 C lets ommit dummy atoms for now
12613        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12614 C now calculate distance from center of tube and direction vectors
12615       xmin=boxxsize
12616       ymin=boxysize
12617       zmin=boxzsize
12618
12619         do j=-1,1
12620          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12621          vectube(1)=vectube(1)+boxxsize*j
12622          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12623          vectube(2)=vectube(2)+boxysize*j
12624          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12625          vectube(3)=vectube(3)+boxzsize*j
12626
12627
12628          xminact=dabs(vectube(1)-tubecenter(1))
12629          yminact=dabs(vectube(2)-tubecenter(2))
12630          zminact=dabs(vectube(3)-tubecenter(3))
12631
12632            if (xmin.gt.xminact) then
12633             xmin=xminact
12634             xtemp=vectube(1)
12635            endif
12636            if (ymin.gt.yminact) then
12637              ymin=yminact
12638              ytemp=vectube(2)
12639             endif
12640            if (zmin.gt.zminact) then
12641              zmin=zminact
12642              ztemp=vectube(3)
12643             endif
12644          enddo
12645       vectube(1)=xtemp
12646       vectube(2)=ytemp
12647       vectube(3)=ztemp
12648
12649       vectube(1)=vectube(1)-tubecenter(1)
12650       vectube(2)=vectube(2)-tubecenter(2)
12651       vectube(3)=vectube(3)-tubecenter(3)
12652
12653 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12654 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12655 C as the tube is infinity we do not calculate the Z-vector use of Z
12656 C as chosen axis
12657 C      vectube(3)=0.0d0
12658 C now calculte the distance
12659        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12660 C now normalize vector
12661       vectube(1)=vectube(1)/tub_r
12662       vectube(2)=vectube(2)/tub_r
12663       vectube(3)=vectube(3)/tub_r
12664 C calculte rdiffrence between r and r0
12665       rdiff=tub_r-tubeR0
12666 C and its 6 power
12667       rdiff6=rdiff**6.0d0
12668 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12669        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12670 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12671 C       print *,rdiff,rdiff6,pep_aa_tube
12672 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12673 C now we calculate gradient
12674        fac=(-12.0d0*pep_aa_tube/rdiff6-
12675      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12676 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12677 C     &rdiff,fac
12678          if (acavtubpep.eq.0.0d0) then
12679 C go to 667
12680          enecavtube(i)=0.0
12681          faccav=0.0
12682          else
12683          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
12684          enecavtube(i)=
12685      &   (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep)
12686      &   /denominator
12687          enecavtube(i)=0.0
12688          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff))
12689      &   *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)
12690      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
12691      &   /denominator**2.0d0
12692 C         faccav=0.0
12693 C         fac=fac+faccav
12694 C 667     continue
12695          endif
12696 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
12697 C     &   enecavtube(i),faccav
12698 C         print *,"licz=",
12699 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12700 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
12701
12702 C now direction of gg_tube vector
12703         do j=1,3
12704         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12705         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12706         enddo
12707         enddo
12708
12709        do i=itube_start,itube_end
12710         enecavtube(i)=0.0d0
12711 C Lets not jump over memory as we use many times iti
12712          iti=itype(i)
12713 C lets ommit dummy atoms for now
12714          if ((iti.eq.ntyp1)
12715 C in UNRES uncomment the line below as GLY has no side-chain...
12716 C      .or.(iti.eq.10)
12717      &   ) cycle
12718       xmin=boxxsize
12719       ymin=boxysize
12720       zmin=boxzsize
12721         do j=-1,1
12722          vectube(1)=dmod((c(1,i+nres)),boxxsize)
12723          vectube(1)=vectube(1)+boxxsize*j
12724          vectube(2)=dmod((c(2,i+nres)),boxysize)
12725          vectube(2)=vectube(2)+boxysize*j
12726          vectube(3)=dmod((c(3,i+nres)),boxzsize)
12727          vectube(3)=vectube(3)+boxzsize*j
12728
12729
12730          xminact=dabs(vectube(1)-tubecenter(1))
12731          yminact=dabs(vectube(2)-tubecenter(2))
12732          zminact=dabs(vectube(3)-tubecenter(3))
12733
12734            if (xmin.gt.xminact) then
12735             xmin=xminact
12736             xtemp=vectube(1)
12737            endif
12738            if (ymin.gt.yminact) then
12739              ymin=yminact
12740              ytemp=vectube(2)
12741             endif
12742            if (zmin.gt.zminact) then
12743              zmin=zminact
12744              ztemp=vectube(3)
12745             endif
12746          enddo
12747       vectube(1)=xtemp
12748       vectube(2)=ytemp
12749       vectube(3)=ztemp
12750
12751 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12752 C     &     tubecenter(2)
12753       vectube(1)=vectube(1)-tubecenter(1)
12754       vectube(2)=vectube(2)-tubecenter(2)
12755       vectube(3)=vectube(3)-tubecenter(3)
12756 C now calculte the distance
12757        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12758 C now normalize vector
12759       vectube(1)=vectube(1)/tub_r
12760       vectube(2)=vectube(2)/tub_r
12761       vectube(3)=vectube(3)/tub_r
12762
12763 C calculte rdiffrence between r and r0
12764       rdiff=tub_r-tubeR0
12765 C and its 6 power
12766       rdiff6=rdiff**6.0d0
12767 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12768        sc_aa_tube=sc_aa_tube_par(iti)
12769        sc_bb_tube=sc_bb_tube_par(iti)
12770        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12771 C       enetube(i+nres)=0.0d0
12772 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12773 C now we calculate gradient
12774        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12775      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12776 C       fac=0.0
12777 C now direction of gg_tube vector
12778 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12779          if (acavtub(iti).eq.0.0d0) then
12780 C go to 667
12781          enecavtube(i+nres)=0.0d0
12782          faccav=0.0d0
12783          else
12784          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
12785          enecavtube(i+nres)=
12786      &   (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti))
12787      &   /denominator
12788 C         enecavtube(i)=0.0
12789          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff))
12790      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)
12791      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
12792      &   /denominator**2.0d0
12793 C         faccav=0.0
12794          fac=fac+faccav
12795 C 667     continue
12796          endif
12797 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
12798 C     &   enecavtube(i),faccav
12799 C         print *,"licz=",
12800 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12801 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
12802          do j=1,3
12803           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12804           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12805          enddo
12806         enddo
12807 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12808 C        do i=itube_start,itube_end
12809 C        enecav(i)=0.0
12810 C        iti=itype(i)
12811 C        if (acavtub(iti).eq.0.0) cycle
12812
12813
12814
12815         do i=itube_start,itube_end
12816           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
12817      & +enecavtube(i+nres)
12818         enddo
12819 C        print *,"ETUBE", etube
12820         return
12821         end
12822 C TO DO 1) add to total energy
12823 C       2) add to gradient summation
12824 C       3) add reading parameters (AND of course oppening of PARAM file)
12825 C       4) add reading the center of tube
12826 C       5) add COMMONs
12827 C       6) add to zerograd
12828