source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       integer IERR
  14       integer status(MPI_STATUS_SIZE)
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26       include 'COMMON.MD'
  27       include 'COMMON.CONTROL'
  28       include 'COMMON.TIME1'
  29       include 'COMMON.SPLITELE'
  30       include 'COMMON.SHIELD'
  31       double precision fac_shieldbuf(maxres),
  32      & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
  33      & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
  34      & grad_shieldbuf(3,-1:maxres)
  35        integer ishield_listbuf(maxres),
  36      &shield_listbuf(maxcontsshi,maxres)
  37 #ifdef MPI
  38 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  39 c     & " nfgtasks",nfgtasks
  40       if (nfgtasks.gt.1) then
  41         time00=MPI_Wtime()
  42 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  43         if (fg_rank.eq.0) then
  44           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  45 c          print *,"Processor",myrank," BROADCAST iorder"
  46 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  47 C FG slaves as WEIGHTS array.
  48           weights_(1)=wsc
  49           weights_(2)=wscp
  50           weights_(3)=welec
  51           weights_(4)=wcorr
  52           weights_(5)=wcorr5
  53           weights_(6)=wcorr6
  54           weights_(7)=wel_loc
  55           weights_(8)=wturn3
  56           weights_(9)=wturn4
  57           weights_(10)=wturn6
  58           weights_(11)=wang
  59           weights_(12)=wscloc
  60           weights_(13)=wtor
  61           weights_(14)=wtor_d
  62           weights_(15)=wstrain
  63           weights_(16)=wvdwpp
  64           weights_(17)=wbond
  65           weights_(18)=scal14
  66           weights_(21)=wsccor
  67           weights_(22)=wtube
  68
  69 C FG Master broadcasts the WEIGHTS_ array
  70           call MPI_Bcast(weights_(1),n_ene,
  71      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  72         else
  73 C FG slaves receive the WEIGHTS array
  74           call MPI_Bcast(weights(1),n_ene,
  75      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  76           wsc=weights(1)
  77           wscp=weights(2)
  78           welec=weights(3)
  79           wcorr=weights(4)
  80           wcorr5=weights(5)
  81           wcorr6=weights(6)
  82           wel_loc=weights(7)
  83           wturn3=weights(8)
  84           wturn4=weights(9)
  85           wturn6=weights(10)
  86           wang=weights(11)
  87           wscloc=weights(12)
  88           wtor=weights(13)
  89           wtor_d=weights(14)
  90           wstrain=weights(15)
  91           wvdwpp=weights(16)
  92           wbond=weights(17)
  93           scal14=weights(18)
  94           wsccor=weights(21)
  95           wtube=weights(22)
  96         endif
  97         time_Bcast=time_Bcast+MPI_Wtime()-time00
  98         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  99 c        call chainbuild_cart
 100       endif
 101 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 102 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 103 #else
 104 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 105 c        call int_from_cart1(.false.)
 106 c      endif
 107 #endif
 108 #ifdef TIMING
 109       time00=MPI_Wtime()
 110 #endif
 111 C
 112 C Compute the side-chain and electrostatic interaction energy
 113 C
 114 C      print *,ipot
 115       goto (101,102,103,104,105,106) ipot
 116 C Lennard-Jones potential.
 117   101 call elj(evdw)
 118 cd    print '(a)','Exit ELJ'
 119       goto 107
 120 C Lennard-Jones-Kihara potential (shifted).
 121   102 call eljk(evdw)
 122       goto 107
 123 C Berne-Pechukas potential (dilated LJ, angular dependence).
 124   103 call ebp(evdw)
 125       goto 107
 126 C Gay-Berne potential (shifted LJ, angular dependence).
 127   104 call egb(evdw)
 128 C      print *,"bylem w egb"
 129       goto 107
 130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 131   105 call egbv(evdw)
 132       goto 107
 133 C Soft-sphere potential
 134   106 call e_softsphere(evdw)
 135 C
 136 C Calculate electrostatic (H-bonding) energy of the main chain.
 137 C
 138   107 continue
 139 cmc
 140 cmc Sep-06: egb takes care of dynamic ss bonds too
 141 cmc
 142 c      if (dyn_ss) call dyn_set_nss
 143
 144 c      print *,"Processor",myrank," computed USCSC"
 145 #ifdef TIMING
 146       time01=MPI_Wtime()
 147 #endif
 148       call vec_and_deriv
 149 #ifdef TIMING
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #endif
 152 C Introduction of shielding effect first for each peptide group
 153 C the shielding factor is set this factor is describing how each
 154 C peptide group is shielded by side-chains
 155 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 156 C      write (iout,*) "shield_mode",shield_mode
 157       if (shield_mode.eq.1) then
 158        call set_shield_fac
 159       else if  (shield_mode.eq.2) then
 160        call set_shield_fac2
 161       if (nfgtasks.gt.1) then
 162 C#define DEBUG
 163 #ifdef DEBUG
 164        write(iout,*) "befor reduce fac_shield reduce"
 165        do i=1,nres
 166         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 167         write(2,*) "list", shield_list(1,i),ishield_list(i),
 168      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 169        enddo
 170 #endif
 171        call MPI_Allgatherv(fac_shield(ivec_start),
 172      &  ivec_count(fg_rank1),
 173      &  MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0),
 174      &  ivec_displ(0),
 175      &  MPI_DOUBLE_PRECISION,FG_COMM,IERR)
 176        call MPI_Allgatherv(shield_list(1,ivec_start),
 177      &  ivec_count(fg_rank1),
 178      &  MPI_I50,shield_listbuf(1,1),ivec_count(0),
 179      &  ivec_displ(0),
 180      &  MPI_I50,FG_COMM,IERR)
 181        call MPI_Allgatherv(ishield_list(ivec_start),
 182      &  ivec_count(fg_rank1),
 183      &  MPI_INTEGER,ishield_listbuf(1),ivec_count(0),
 184      &  ivec_displ(0),
 185      &  MPI_INTEGER,FG_COMM,IERR)
 186        call MPI_Allgatherv(grad_shield(1,ivec_start),
 187      &  ivec_count(fg_rank1),
 188      &  MPI_UYZ,grad_shieldbuf(1,1),ivec_count(0),
 189      &  ivec_displ(0),
 190      &  MPI_UYZ,FG_COMM,IERR)
 191        call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
 192      &  ivec_count(fg_rank1),
 193      &  MPI_SHI,grad_shield_sidebuf(1,1,1),ivec_count(0),
 194      &  ivec_displ(0),
 195      &  MPI_SHI,FG_COMM,IERR)
 196        call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
 197      &  ivec_count(fg_rank1),
 198      &  MPI_SHI,grad_shield_locbuf(1,1,1),ivec_count(0),
 199      &  ivec_displ(0),
 200      &  MPI_SHI,FG_COMM,IERR)
 201        do i=1,nres
 202         fac_shield(i)=fac_shieldbuf(i)
 203         ishield_list(i)=ishield_listbuf(i)
 204         do j=1,3
 205         grad_shield(j,i)=grad_shieldbuf(j,i)
 206         enddo !j
 207         do j=1,ishield_list(i)
 208           shield_list(j,i)=shield_listbuf(j,i)
 209          do k=1,3
 210          grad_shield_loc(k,j,i)=grad_shield_locbuf(k,j,i)
 211          grad_shield_side(k,j,i)=grad_shield_sidebuf(k,j,i)
 212          enddo !k
 213        enddo !j
 214       enddo !i
 215 #ifdef DEBUG
 216        write(iout,*) "after reduce fac_shield reduce"
 217        do i=1,nres
 218         write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
 219         write(2,*) "list", shield_list(1,i),ishield_list(i),
 220      &  grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 221        enddo
 222 #endif
 223 C#undef DEBUG
 224       endif
 225 #ifdef DEBUG
 226       do i=1,nres
 227       write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
 228         do j=1,ishield_list(i)
 229          write(iout,*) "grad", grad_shield_side(1,j,i),
 230      &   grad_shield_loc(1,j,i)
 231         enddo
 232       enddo
 233 #endif
 234       endif
 235 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 236       if (ipot.lt.6) then
 237 #ifdef SPLITELE
 238          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 239      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 240      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 241      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 242 #else
 243          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 244      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 245      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 246      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 247 #endif
 248             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 249          else
 250             ees=0.0d0
 251             evdw1=0.0d0
 252             eel_loc=0.0d0
 253             eello_turn3=0.0d0
 254             eello_turn4=0.0d0
 255          endif
 256       else
 257         write (iout,*) "Soft-spheer ELEC potential"
 258 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 259 c     &   eello_turn4)
 260       endif
 261 c      print *,"Processor",myrank," computed UELEC"
 262 C
 263 C Calculate excluded-volume interaction energy between peptide groups
 264 C and side chains.
 265 C
 266       if (ipot.lt.6) then
 267        if(wscp.gt.0d0) then
 268         call escp(evdw2,evdw2_14)
 269        else
 270         evdw2=0
 271         evdw2_14=0
 272        endif
 273       else
 274 c        write (iout,*) "Soft-sphere SCP potential"
 275         call escp_soft_sphere(evdw2,evdw2_14)
 276       endif
 277 c
 278 c Calculate the bond-stretching energy
 279 c
 280       call ebond(estr)
 281 C
 282 C Calculate the disulfide-bridge and other energy and the contributions
 283 C from other distance constraints.
 284 cd    print *,'Calling EHPB'
 285       call edis(ehpb)
 286 cd    print *,'EHPB exitted succesfully.'
 287 C
 288 C Calculate the virtual-bond-angle energy.
 289 C
 290       if (wang.gt.0d0) then
 291        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 292         call ebend(ebe,ethetacnstr)
 293         endif
 294 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 295 C energy function
 296        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 297          call ebend_kcc(ebe,ethetacnstr)
 298         endif
 299       else
 300         ebe=0
 301         ethetacnstr=0
 302       endif
 303 c      print *,"Processor",myrank," computed UB"
 304 C
 305 C Calculate the SC local energy.
 306 C
 307 C      print *,"TU DOCHODZE?"
 308       call esc(escloc)
 309 c      print *,"Processor",myrank," computed USC"
 310 C
 311 C Calculate the virtual-bond torsional energy.
 312 C
 313 cd    print *,'nterm=',nterm
 314 C      print *,"tor",tor_mode
 315       if (wtor.gt.0) then
 316        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 317        call etor(etors,edihcnstr)
 318        endif
 319 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 320 C energy function
 321        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 322        call etor_kcc(etors,edihcnstr)
 323        endif
 324       else
 325        etors=0
 326        edihcnstr=0
 327       endif
 328 c      print *,"Processor",myrank," computed Utor"
 329 C
 330 C 6/23/01 Calculate double-torsional energy
 331 C
 332       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 333        call etor_d(etors_d)
 334       else
 335        etors_d=0
 336       endif
 337 c      print *,"Processor",myrank," computed Utord"
 338 C
 339 C 21/5/07 Calculate local sicdechain correlation energy
 340 C
 341       if (wsccor.gt.0.0d0) then
 342         call eback_sc_corr(esccor)
 343       else
 344         esccor=0.0d0
 345       endif
 346 C      print *,"PRZED MULIt"
 347 c      print *,"Processor",myrank," computed Usccorr"
 348 C
 349 C 12/1/95 Multi-body terms
 350 C
 351       n_corr=0
 352       n_corr1=0
 353       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 354      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 355          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 356 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 357 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 358       else
 359          ecorr=0.0d0
 360          ecorr5=0.0d0
 361          ecorr6=0.0d0
 362          eturn6=0.0d0
 363       endif
 364       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 365          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 366 cd         write (iout,*) "multibody_hb ecorr",ecorr
 367       endif
 368 c      print *,"Processor",myrank," computed Ucorr"
 369 C
 370 C If performing constraint dynamics, call the constraint energy
 371 C  after the equilibration time
 372       if(usampl.and.totT.gt.eq_time) then
 373          call EconstrQ
 374          call Econstr_back
 375       else
 376          Uconst=0.0d0
 377          Uconst_back=0.0d0
 378       endif
 379 C 01/27/2015 added by adasko
 380 C the energy component below is energy transfer into lipid environment
 381 C based on partition function
 382 C      print *,"przed lipidami"
 383       if (wliptran.gt.0) then
 384         call Eliptransfer(eliptran)
 385       else
 386        eliptran=0.0d0
 387       endif
 388 C      print *,"za lipidami"
 389       if (AFMlog.gt.0) then
 390         call AFMforce(Eafmforce)
 391       else if (selfguide.gt.0) then
 392         call AFMvel(Eafmforce)
 393       endif
 394       if (TUBElog.eq.1) then
 395 C      print *,"just before call"
 396         call calctube(Etube)
 397        elseif (TUBElog.eq.2) then
 398         call calctube2(Etube)
 399        else
 400        Etube=0.0d0
 401        endif
 402
 403 #ifdef TIMING
 404       time_enecalc=time_enecalc+MPI_Wtime()-time00
 405 #endif
 406 c      print *,"Processor",myrank," computed Uconstr"
 407 #ifdef TIMING
 408       time00=MPI_Wtime()
 409 #endif
 410 c
 411 C Sum the energies
 412 C
 413       energia(1)=evdw
 414 #ifdef SCP14
 415       energia(2)=evdw2-evdw2_14
 416       energia(18)=evdw2_14
 417 #else
 418       energia(2)=evdw2
 419       energia(18)=0.0d0
 420 #endif
 421 #ifdef SPLITELE
 422       energia(3)=ees
 423       energia(16)=evdw1
 424 #else
 425       energia(3)=ees+evdw1
 426       energia(16)=0.0d0
 427 #endif
 428       energia(4)=ecorr
 429       energia(5)=ecorr5
 430       energia(6)=ecorr6
 431       energia(7)=eel_loc
 432       energia(8)=eello_turn3
 433       energia(9)=eello_turn4
 434       energia(10)=eturn6
 435       energia(11)=ebe
 436       energia(12)=escloc
 437       energia(13)=etors
 438       energia(14)=etors_d
 439       energia(15)=ehpb
 440       energia(19)=edihcnstr
 441       energia(17)=estr
 442       energia(20)=Uconst+Uconst_back
 443       energia(21)=esccor
 444       energia(22)=eliptran
 445       energia(23)=Eafmforce
 446       energia(24)=ethetacnstr
 447       energia(25)=Etube
 448 c    Here are the energies showed per procesor if the are more processors
 449 c    per molecule then we sum it up in sum_energy subroutine
 450 c      print *," Processor",myrank," calls SUM_ENERGY"
 451       call sum_energy(energia,.true.)
 452       if (dyn_ss) call dyn_set_nss
 453 c      print *," Processor",myrank," left SUM_ENERGY"
 454 #ifdef TIMING
 455       time_sumene=time_sumene+MPI_Wtime()-time00
 456 #endif
 457       return
 458       end
 459 c-------------------------------------------------------------------------------
 460       subroutine sum_energy(energia,reduce)
 461       implicit real*8 (a-h,o-z)
 462       include 'DIMENSIONS'
 463 #ifndef ISNAN
 464       external proc_proc
 465 #ifdef WINPGI
 466 cMS$ATTRIBUTES C ::  proc_proc
 467 #endif
 468 #endif
 469 #ifdef MPI
 470       include "mpif.h"
 471 #endif
 472       include 'COMMON.SETUP'
 473       include 'COMMON.IOUNITS'
 474       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 475       include 'COMMON.FFIELD'
 476       include 'COMMON.DERIV'
 477       include 'COMMON.INTERACT'
 478       include 'COMMON.SBRIDGE'
 479       include 'COMMON.CHAIN'
 480       include 'COMMON.VAR'
 481       include 'COMMON.CONTROL'
 482       include 'COMMON.TIME1'
 483       logical reduce
 484 #ifdef MPI
 485       if (nfgtasks.gt.1 .and. reduce) then
 486 #ifdef DEBUG
 487         write (iout,*) "energies before REDUCE"
 488         call enerprint(energia)
 489         call flush(iout)
 490 #endif
 491         do i=0,n_ene
 492           enebuff(i)=energia(i)
 493         enddo
 494         time00=MPI_Wtime()
 495         call MPI_Barrier(FG_COMM,IERR)
 496         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 497         time00=MPI_Wtime()
 498         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 499      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 500 #ifdef DEBUG
 501         write (iout,*) "energies after REDUCE"
 502         call enerprint(energia)
 503         call flush(iout)
 504 #endif
 505         time_Reduce=time_Reduce+MPI_Wtime()-time00
 506       endif
 507       if (fg_rank.eq.0) then
 508 #endif
 509       evdw=energia(1)
 510 #ifdef SCP14
 511       evdw2=energia(2)+energia(18)
 512       evdw2_14=energia(18)
 513 #else
 514       evdw2=energia(2)
 515 #endif
 516 #ifdef SPLITELE
 517       ees=energia(3)
 518       evdw1=energia(16)
 519 #else
 520       ees=energia(3)
 521       evdw1=0.0d0
 522 #endif
 523       ecorr=energia(4)
 524       ecorr5=energia(5)
 525       ecorr6=energia(6)
 526       eel_loc=energia(7)
 527       eello_turn3=energia(8)
 528       eello_turn4=energia(9)
 529       eturn6=energia(10)
 530       ebe=energia(11)
 531       escloc=energia(12)
 532       etors=energia(13)
 533       etors_d=energia(14)
 534       ehpb=energia(15)
 535       edihcnstr=energia(19)
 536       estr=energia(17)
 537       Uconst=energia(20)
 538       esccor=energia(21)
 539       eliptran=energia(22)
 540       Eafmforce=energia(23)
 541       ethetacnstr=energia(24)
 542       Etube=energia(25)
 543 #ifdef SPLITELE
 544       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 545      & +wang*ebe+wtor*etors+wscloc*escloc
 546      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 547      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 548      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 549      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 550      & +ethetacnstr+wtube*Etube
 551 #else
 552       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 553      & +wang*ebe+wtor*etors+wscloc*escloc
 554      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 555      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 556      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 557      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 558      & +Eafmforce
 559      & +ethetacnstr+wtube*Etube
 560 #endif
 561       energia(0)=etot
 562 c detecting NaNQ
 563 #ifdef ISNAN
 564 #ifdef AIX
 565       if (isnan(etot).ne.0) energia(0)=1.0d+99
 566 #else
 567       if (isnan(etot)) energia(0)=1.0d+99
 568 #endif
 569 #else
 570       i=0
 571 #ifdef WINPGI
 572       idumm=proc_proc(etot,i)
 573 #else
 574       call proc_proc(etot,i)
 575 #endif
 576       if(i.eq.1)energia(0)=1.0d+99
 577 #endif
 578 #ifdef MPI
 579       endif
 580 #endif
 581       return
 582       end
 583 c-------------------------------------------------------------------------------
 584       subroutine sum_gradient
 585       implicit real*8 (a-h,o-z)
 586       include 'DIMENSIONS'
 587 #ifndef ISNAN
 588       external proc_proc
 589 #ifdef WINPGI
 590 cMS$ATTRIBUTES C ::  proc_proc
 591 #endif
 592 #endif
 593 #ifdef MPI
 594       include 'mpif.h'
 595 #endif
 596       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 597      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 598      & ,gloc_scbuf(3,-1:maxres)
 599       include 'COMMON.SETUP'
 600       include 'COMMON.IOUNITS'
 601       include 'COMMON.FFIELD'
 602       include 'COMMON.DERIV'
 603       include 'COMMON.INTERACT'
 604       include 'COMMON.SBRIDGE'
 605       include 'COMMON.CHAIN'
 606       include 'COMMON.VAR'
 607       include 'COMMON.CONTROL'
 608       include 'COMMON.TIME1'
 609       include 'COMMON.MAXGRAD'
 610       include 'COMMON.SCCOR'
 611 #ifdef TIMING
 612       time01=MPI_Wtime()
 613 #endif
 614 #ifdef DEBUG
 615       write (iout,*) "sum_gradient gvdwc, gvdwx"
 616       do i=1,nres
 617         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 618      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 619       enddo
 620       call flush(iout)
 621 #endif
 622 #ifdef MPI
 623 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 624         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 625      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 626 #endif
 627 C
 628 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 629 C            in virtual-bond-vector coordinates
 630 C
 631 #ifdef DEBUG
 632 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 633 c      do i=1,nres-1
 634 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 635 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 636 c      enddo
 637 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 638 c      do i=1,nres-1
 639 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 640 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 641 c      enddo
 642       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 643       do i=1,nres
 644         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 645      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 646      &   g_corr5_loc(i)
 647       enddo
 648       call flush(iout)
 649 #endif
 650 #ifdef SPLITELE
 651       do i=0,nct
 652         do j=1,3
 653           gradbufc(j,i)=wsc*gvdwc(j,i)+
 654      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 655      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 656      &                wel_loc*gel_loc_long(j,i)+
 657      &                wcorr*gradcorr_long(j,i)+
 658      &                wcorr5*gradcorr5_long(j,i)+
 659      &                wcorr6*gradcorr6_long(j,i)+
 660      &                wturn6*gcorr6_turn_long(j,i)+
 661      &                wstrain*ghpbc(j,i)
 662      &                +wliptran*gliptranc(j,i)
 663      &                +gradafm(j,i)
 664      &                 +welec*gshieldc(j,i)
 665      &                 +wcorr*gshieldc_ec(j,i)
 666      &                 +wturn3*gshieldc_t3(j,i)
 667      &                 +wturn4*gshieldc_t4(j,i)
 668      &                 +wel_loc*gshieldc_ll(j,i)
 669      &                +wtube*gg_tube(j,i)
 670
 671
 672
 673         enddo
 674       enddo
 675 #else
 676       do i=0,nct
 677         do j=1,3
 678           gradbufc(j,i)=wsc*gvdwc(j,i)+
 679      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 680      &                welec*gelc_long(j,i)+
 681      &                wbond*gradb(j,i)+
 682      &                wel_loc*gel_loc_long(j,i)+
 683      &                wcorr*gradcorr_long(j,i)+
 684      &                wcorr5*gradcorr5_long(j,i)+
 685      &                wcorr6*gradcorr6_long(j,i)+
 686      &                wturn6*gcorr6_turn_long(j,i)+
 687      &                wstrain*ghpbc(j,i)
 688      &                +wliptran*gliptranc(j,i)
 689      &                +gradafm(j,i)
 690      &                 +welec*gshieldc(j,i)
 691      &                 +wcorr*gshieldc_ec(j,i)
 692      &                 +wturn4*gshieldc_t4(j,i)
 693      &                 +wel_loc*gshieldc_ll(j,i)
 694      &                +wtube*gg_tube(j,i)
 695
 696
 697
 698         enddo
 699       enddo
 700 #endif
 701 #ifdef MPI
 702       if (nfgtasks.gt.1) then
 703       time00=MPI_Wtime()
 704 #ifdef DEBUG
 705       write (iout,*) "gradbufc before allreduce"
 706       do i=1,nres
 707         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 708       enddo
 709       call flush(iout)
 710 #endif
 711       do i=0,nres
 712         do j=1,3
 713           gradbufc_sum(j,i)=gradbufc(j,i)
 714         enddo
 715       enddo
 716 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 717 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 718 c      time_reduce=time_reduce+MPI_Wtime()-time00
 719 #ifdef DEBUG
 720 c      write (iout,*) "gradbufc_sum after allreduce"
 721 c      do i=1,nres
 722 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 723 c      enddo
 724 c      call flush(iout)
 725 #endif
 726 #ifdef TIMING
 727 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 728 #endif
 729       do i=nnt,nres
 730         do k=1,3
 731           gradbufc(k,i)=0.0d0
 732         enddo
 733       enddo
 734 #ifdef DEBUG
 735       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 736       write (iout,*) (i," jgrad_start",jgrad_start(i),
 737      &                  " jgrad_end  ",jgrad_end(i),
 738      &                  i=igrad_start,igrad_end)
 739 #endif
 740 c
 741 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 742 c do not parallelize this part.
 743 c
 744 c      do i=igrad_start,igrad_end
 745 c        do j=jgrad_start(i),jgrad_end(i)
 746 c          do k=1,3
 747 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 748 c          enddo
 749 c        enddo
 750 c      enddo
 751       do j=1,3
 752         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 753       enddo
 754       do i=nres-2,-1,-1
 755         do j=1,3
 756           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 757         enddo
 758       enddo
 759 #ifdef DEBUG
 760       write (iout,*) "gradbufc after summing"
 761       do i=1,nres
 762         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 763       enddo
 764       call flush(iout)
 765 #endif
 766       else
 767 #endif
 768 #ifdef DEBUG
 769       write (iout,*) "gradbufc"
 770       do i=1,nres
 771         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 772       enddo
 773       call flush(iout)
 774 #endif
 775       do i=-1,nres
 776         do j=1,3
 777           gradbufc_sum(j,i)=gradbufc(j,i)
 778           gradbufc(j,i)=0.0d0
 779         enddo
 780       enddo
 781       do j=1,3
 782         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 783       enddo
 784       do i=nres-2,-1,-1
 785         do j=1,3
 786           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 787         enddo
 788       enddo
 789 c      do i=nnt,nres-1
 790 c        do k=1,3
 791 c          gradbufc(k,i)=0.0d0
 792 c        enddo
 793 c        do j=i+1,nres
 794 c          do k=1,3
 795 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 796 c          enddo
 797 c        enddo
 798 c      enddo
 799 #ifdef DEBUG
 800       write (iout,*) "gradbufc after summing"
 801       do i=1,nres
 802         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 803       enddo
 804       call flush(iout)
 805 #endif
 806 #ifdef MPI
 807       endif
 808 #endif
 809       do k=1,3
 810         gradbufc(k,nres)=0.0d0
 811       enddo
 812       do i=-1,nct
 813         do j=1,3
 814 #ifdef SPLITELE
 815 C          print *,gradbufc(1,13)
 816 C          print *,welec*gelc(1,13)
 817 C          print *,wel_loc*gel_loc(1,13)
 818 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 819 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 820 C          print *,wel_loc*gel_loc_long(1,13)
 821 C          print *,gradafm(1,13),"AFM"
 822           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 823      &                wel_loc*gel_loc(j,i)+
 824      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 825      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 826      &                wel_loc*gel_loc_long(j,i)+
 827      &                wcorr*gradcorr_long(j,i)+
 828      &                wcorr5*gradcorr5_long(j,i)+
 829      &                wcorr6*gradcorr6_long(j,i)+
 830      &                wturn6*gcorr6_turn_long(j,i))+
 831      &                wbond*gradb(j,i)+
 832      &                wcorr*gradcorr(j,i)+
 833      &                wturn3*gcorr3_turn(j,i)+
 834      &                wturn4*gcorr4_turn(j,i)+
 835      &                wcorr5*gradcorr5(j,i)+
 836      &                wcorr6*gradcorr6(j,i)+
 837      &                wturn6*gcorr6_turn(j,i)+
 838      &                wsccor*gsccorc(j,i)
 839      &               +wscloc*gscloc(j,i)
 840      &               +wliptran*gliptranc(j,i)
 841      &                +gradafm(j,i)
 842      &                 +welec*gshieldc(j,i)
 843      &                 +welec*gshieldc_loc(j,i)
 844      &                 +wcorr*gshieldc_ec(j,i)
 845      &                 +wcorr*gshieldc_loc_ec(j,i)
 846      &                 +wturn3*gshieldc_t3(j,i)
 847      &                 +wturn3*gshieldc_loc_t3(j,i)
 848      &                 +wturn4*gshieldc_t4(j,i)
 849      &                 +wturn4*gshieldc_loc_t4(j,i)
 850      &                 +wel_loc*gshieldc_ll(j,i)
 851      &                 +wel_loc*gshieldc_loc_ll(j,i)
 852      &                +wtube*gg_tube(j,i)
 853
 854 #else
 855           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 856      &                wel_loc*gel_loc(j,i)+
 857      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 858      &                welec*gelc_long(j,i)+
 859      &                wel_loc*gel_loc_long(j,i)+
 860      &                wcorr*gcorr_long(j,i)+
 861      &                wcorr5*gradcorr5_long(j,i)+
 862      &                wcorr6*gradcorr6_long(j,i)+
 863      &                wturn6*gcorr6_turn_long(j,i))+
 864      &                wbond*gradb(j,i)+
 865      &                wcorr*gradcorr(j,i)+
 866      &                wturn3*gcorr3_turn(j,i)+
 867      &                wturn4*gcorr4_turn(j,i)+
 868      &                wcorr5*gradcorr5(j,i)+
 869      &                wcorr6*gradcorr6(j,i)+
 870      &                wturn6*gcorr6_turn(j,i)+
 871      &                wsccor*gsccorc(j,i)
 872      &               +wscloc*gscloc(j,i)
 873      &               +wliptran*gliptranc(j,i)
 874      &                +gradafm(j,i)
 875      &                 +welec*gshieldc(j,i)
 876      &                 +welec*gshieldc_loc(j,i)
 877      &                 +wcorr*gshieldc_ec(j,i)
 878      &                 +wcorr*gshieldc_loc_ec(j,i)
 879      &                 +wturn3*gshieldc_t3(j,i)
 880      &                 +wturn3*gshieldc_loc_t3(j,i)
 881      &                 +wturn4*gshieldc_t4(j,i)
 882      &                 +wturn4*gshieldc_loc_t4(j,i)
 883      &                 +wel_loc*gshieldc_ll(j,i)
 884      &                 +wel_loc*gshieldc_loc_ll(j,i)
 885      &                +wtube*gg_tube(j,i)
 886
 887
 888 #endif
 889           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 890      &                  wbond*gradbx(j,i)+
 891      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 892      &                  wsccor*gsccorx(j,i)
 893      &                 +wscloc*gsclocx(j,i)
 894      &                 +wliptran*gliptranx(j,i)
 895      &                 +welec*gshieldx(j,i)
 896      &                 +wcorr*gshieldx_ec(j,i)
 897      &                 +wturn3*gshieldx_t3(j,i)
 898      &                 +wturn4*gshieldx_t4(j,i)
 899      &                 +wel_loc*gshieldx_ll(j,i)
 900      &                 +wtube*gg_tube_sc(j,i)
 901
 902
 903
 904         enddo
 905       enddo
 906 #ifdef DEBUG
 907       write (iout,*) "gloc before adding corr"
 908       do i=1,4*nres
 909         write (iout,*) i,gloc(i,icg)
 910       enddo
 911 #endif
 912       do i=1,nres-3
 913         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 914      &   +wcorr5*g_corr5_loc(i)
 915      &   +wcorr6*g_corr6_loc(i)
 916      &   +wturn4*gel_loc_turn4(i)
 917      &   +wturn3*gel_loc_turn3(i)
 918      &   +wturn6*gel_loc_turn6(i)
 919      &   +wel_loc*gel_loc_loc(i)
 920       enddo
 921 #ifdef DEBUG
 922       write (iout,*) "gloc after adding corr"
 923       do i=1,4*nres
 924         write (iout,*) i,gloc(i,icg)
 925       enddo
 926 #endif
 927 #ifdef MPI
 928       if (nfgtasks.gt.1) then
 929         do j=1,3
 930           do i=1,nres
 931             gradbufc(j,i)=gradc(j,i,icg)
 932             gradbufx(j,i)=gradx(j,i,icg)
 933           enddo
 934         enddo
 935         do i=1,4*nres
 936           glocbuf(i)=gloc(i,icg)
 937         enddo
 938 c#define DEBUG
 939 #ifdef DEBUG
 940       write (iout,*) "gloc_sc before reduce"
 941       do i=1,nres
 942        do j=1,1
 943         write (iout,*) i,j,gloc_sc(j,i,icg)
 944        enddo
 945       enddo
 946 #endif
 947 c#undef DEBUG
 948         do i=1,nres
 949          do j=1,3
 950           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 951          enddo
 952         enddo
 953         time00=MPI_Wtime()
 954         call MPI_Barrier(FG_COMM,IERR)
 955         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 956         time00=MPI_Wtime()
 957         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 958      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 959         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 960      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 961         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 962      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 963         time_reduce=time_reduce+MPI_Wtime()-time00
 964         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 965      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 966         time_reduce=time_reduce+MPI_Wtime()-time00
 967 c#define DEBUG
 968 #ifdef DEBUG
 969       write (iout,*) "gloc_sc after reduce"
 970       do i=1,nres
 971        do j=1,1
 972         write (iout,*) i,j,gloc_sc(j,i,icg)
 973        enddo
 974       enddo
 975 #endif
 976 c#undef DEBUG
 977 #ifdef DEBUG
 978       write (iout,*) "gloc after reduce"
 979       do i=1,4*nres
 980         write (iout,*) i,gloc(i,icg)
 981       enddo
 982 #endif
 983       endif
 984 #endif
 985       if (gnorm_check) then
 986 c
 987 c Compute the maximum elements of the gradient
 988 c
 989       gvdwc_max=0.0d0
 990       gvdwc_scp_max=0.0d0
 991       gelc_max=0.0d0
 992       gvdwpp_max=0.0d0
 993       gradb_max=0.0d0
 994       ghpbc_max=0.0d0
 995       gradcorr_max=0.0d0
 996       gel_loc_max=0.0d0
 997       gcorr3_turn_max=0.0d0
 998       gcorr4_turn_max=0.0d0
 999       gradcorr5_max=0.0d0
1000       gradcorr6_max=0.0d0
1001       gcorr6_turn_max=0.0d0
1002       gsccorc_max=0.0d0
1003       gscloc_max=0.0d0
1004       gvdwx_max=0.0d0
1005       gradx_scp_max=0.0d0
1006       ghpbx_max=0.0d0
1007       gradxorr_max=0.0d0
1008       gsccorx_max=0.0d0
1009       gsclocx_max=0.0d0
1010       do i=1,nct
1011         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1012         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1013         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1014         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1015      &   gvdwc_scp_max=gvdwc_scp_norm
1016         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1017         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1018         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1019         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1020         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1021         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1022         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1023         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1024         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1025         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1026         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1027         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1028         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1029      &    gcorr3_turn(1,i)))
1030         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1031      &    gcorr3_turn_max=gcorr3_turn_norm
1032         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1033      &    gcorr4_turn(1,i)))
1034         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1035      &    gcorr4_turn_max=gcorr4_turn_norm
1036         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1037         if (gradcorr5_norm.gt.gradcorr5_max)
1038      &    gradcorr5_max=gradcorr5_norm
1039         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1040         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1041         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1042      &    gcorr6_turn(1,i)))
1043         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1044      &    gcorr6_turn_max=gcorr6_turn_norm
1045         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1046         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1047         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1048         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1049         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1050         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1051         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1052         if (gradx_scp_norm.gt.gradx_scp_max)
1053      &    gradx_scp_max=gradx_scp_norm
1054         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1055         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1056         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1057         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1058         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1059         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1060         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1061         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1062       enddo
1063       if (gradout) then
1064 #ifdef AIX
1065         open(istat,file=statname,position="append")
1066 #else
1067         open(istat,file=statname,access="append")
1068 #endif
1069         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1070      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1071      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1072      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1073      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1074      &     gsccorx_max,gsclocx_max
1075         close(istat)
1076         if (gvdwc_max.gt.1.0d4) then
1077           write (iout,*) "gvdwc gvdwx gradb gradbx"
1078           do i=nnt,nct
1079             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1080      &        gradb(j,i),gradbx(j,i),j=1,3)
1081           enddo
1082           call pdbout(0.0d0,'cipiszcze',iout)
1083           call flush(iout)
1084         endif
1085       endif
1086       endif
1087 #ifdef DEBUG
1088       write (iout,*) "gradc gradx gloc"
1089       do i=1,nres
1090         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1091      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1092       enddo
1093 #endif
1094 #ifdef TIMING
1095       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1096 #endif
1097       return
1098       end
1099 c-------------------------------------------------------------------------------
1100       subroutine rescale_weights(t_bath)
1101       implicit real*8 (a-h,o-z)
1102       include 'DIMENSIONS'
1103       include 'COMMON.IOUNITS'
1104       include 'COMMON.FFIELD'
1105       include 'COMMON.SBRIDGE'
1106       include 'COMMON.CONTROL'
1107       double precision kfac /2.4d0/
1108       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1109 c      facT=temp0/t_bath
1110 c      facT=2*temp0/(t_bath+temp0)
1111       if (rescale_mode.eq.0) then
1112         facT=1.0d0
1113         facT2=1.0d0
1114         facT3=1.0d0
1115         facT4=1.0d0
1116         facT5=1.0d0
1117       else if (rescale_mode.eq.1) then
1118         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1119         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1120         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1121         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1122         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1123       else if (rescale_mode.eq.2) then
1124         x=t_bath/temp0
1125         x2=x*x
1126         x3=x2*x
1127         x4=x3*x
1128         x5=x4*x
1129         facT=licznik/dlog(dexp(x)+dexp(-x))
1130         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1131         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1132         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1133         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1134       else
1135         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1136         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1137 #ifdef MPI
1138        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1139 #endif
1140        stop 555
1141       endif
1142       if (shield_mode.gt.0) then
1143        wscp=weights(2)*fact
1144        wsc=weights(1)*fact
1145        wvdwpp=weights(16)*fact
1146       endif
1147       welec=weights(3)*fact
1148       wcorr=weights(4)*fact3
1149       wcorr5=weights(5)*fact4
1150       wcorr6=weights(6)*fact5
1151       wel_loc=weights(7)*fact2
1152       wturn3=weights(8)*fact2
1153       wturn4=weights(9)*fact3
1154       wturn6=weights(10)*fact5
1155       wtor=weights(13)*fact
1156       wtor_d=weights(14)*fact2
1157       wsccor=weights(21)*fact
1158
1159       return
1160       end
1161 C------------------------------------------------------------------------
1162       subroutine enerprint(energia)
1163       implicit real*8 (a-h,o-z)
1164       include 'DIMENSIONS'
1165       include 'COMMON.IOUNITS'
1166       include 'COMMON.FFIELD'
1167       include 'COMMON.SBRIDGE'
1168       include 'COMMON.MD'
1169       double precision energia(0:n_ene)
1170       etot=energia(0)
1171       evdw=energia(1)
1172       evdw2=energia(2)
1173 #ifdef SCP14
1174       evdw2=energia(2)+energia(18)
1175 #else
1176       evdw2=energia(2)
1177 #endif
1178       ees=energia(3)
1179 #ifdef SPLITELE
1180       evdw1=energia(16)
1181 #endif
1182       ecorr=energia(4)
1183       ecorr5=energia(5)
1184       ecorr6=energia(6)
1185       eel_loc=energia(7)
1186       eello_turn3=energia(8)
1187       eello_turn4=energia(9)
1188       eello_turn6=energia(10)
1189       ebe=energia(11)
1190       escloc=energia(12)
1191       etors=energia(13)
1192       etors_d=energia(14)
1193       ehpb=energia(15)
1194       edihcnstr=energia(19)
1195       estr=energia(17)
1196       Uconst=energia(20)
1197       esccor=energia(21)
1198       eliptran=energia(22)
1199       Eafmforce=energia(23)
1200       ethetacnstr=energia(24)
1201       etube=energia(25)
1202 #ifdef SPLITELE
1203       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1204      &  estr,wbond,ebe,wang,
1205      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1206      &  ecorr,wcorr,
1207      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1208      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1209      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1210      &  etube,wtube,
1211      &  etot
1212    10 format (/'Virtual-chain energies:'//
1213      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1214      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1215      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1216      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1217      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1218      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1219      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1220      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1221      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1222      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1223      & ' (SS bridges & dist. cnstr.)'/
1224      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1225      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1226      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1227      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1228      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1229      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1230      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1231      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1232      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1233      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1234      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1235      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1236      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1237      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1238      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1239      & 'ETOT=  ',1pE16.6,' (total)')
1240
1241 #else
1242       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1243      &  estr,wbond,ebe,wang,
1244      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1245      &  ecorr,wcorr,
1246      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1247      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1248      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1249      &  etube,wtube,
1250      &  etot
1251    10 format (/'Virtual-chain energies:'//
1252      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1253      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1254      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1255      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1256      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1257      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1258      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1259      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1260      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1261      & ' (SS bridges & dist. cnstr.)'/
1262      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1263      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1264      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1265      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1266      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1267      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1268      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1269      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1270      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1271      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1272      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1273      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1274      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1275      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1276      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1277      & 'ETOT=  ',1pE16.6,' (total)')
1278 #endif
1279       return
1280       end
1281 C-----------------------------------------------------------------------
1282       subroutine elj(evdw)
1283 C
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the LJ potential of interaction.
1286 C
1287       implicit real*8 (a-h,o-z)
1288       include 'DIMENSIONS'
1289       parameter (accur=1.0d-10)
1290       include 'COMMON.GEO'
1291       include 'COMMON.VAR'
1292       include 'COMMON.LOCAL'
1293       include 'COMMON.CHAIN'
1294       include 'COMMON.DERIV'
1295       include 'COMMON.INTERACT'
1296       include 'COMMON.TORSION'
1297       include 'COMMON.SBRIDGE'
1298       include 'COMMON.NAMES'
1299       include 'COMMON.IOUNITS'
1300       include 'COMMON.CONTACTS'
1301       dimension gg(3)
1302 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1303       evdw=0.0D0
1304       do i=iatsc_s,iatsc_e
1305         itypi=iabs(itype(i))
1306         if (itypi.eq.ntyp1) cycle
1307         itypi1=iabs(itype(i+1))
1308         xi=c(1,nres+i)
1309         yi=c(2,nres+i)
1310         zi=c(3,nres+i)
1311 C Change 12/1/95
1312         num_conti=0
1313 C
1314 C Calculate SC interaction energy.
1315 C
1316         do iint=1,nint_gr(i)
1317 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1318 cd   &                  'iend=',iend(i,iint)
1319           do j=istart(i,iint),iend(i,iint)
1320             itypj=iabs(itype(j))
1321             if (itypj.eq.ntyp1) cycle
1322             xj=c(1,nres+j)-xi
1323             yj=c(2,nres+j)-yi
1324             zj=c(3,nres+j)-zi
1325 C Change 12/1/95 to calculate four-body interactions
1326             rij=xj*xj+yj*yj+zj*zj
1327             rrij=1.0D0/rij
1328 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1329             eps0ij=eps(itypi,itypj)
1330             fac=rrij**expon2
1331 C have you changed here?
1332             e1=fac*fac*aa
1333             e2=fac*bb
1334             evdwij=e1+e2
1335 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1336 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1337 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1338 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1339 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1340 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1341             evdw=evdw+evdwij
1342 C
1343 C Calculate the components of the gradient in DC and X
1344 C
1345             fac=-rrij*(e1+evdwij)
1346             gg(1)=xj*fac
1347             gg(2)=yj*fac
1348             gg(3)=zj*fac
1349             do k=1,3
1350               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1351               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1352               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1353               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1354             enddo
1355 cgrad            do k=i,j-1
1356 cgrad              do l=1,3
1357 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1358 cgrad              enddo
1359 cgrad            enddo
1360 C
1361 C 12/1/95, revised on 5/20/97
1362 C
1363 C Calculate the contact function. The ith column of the array JCONT will
1364 C contain the numbers of atoms that make contacts with the atom I (of numbers
1365 C greater than I). The arrays FACONT and GACONT will contain the values of
1366 C the contact function and its derivative.
1367 C
1368 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1369 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1370 C Uncomment next line, if the correlation interactions are contact function only
1371             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1372               rij=dsqrt(rij)
1373               sigij=sigma(itypi,itypj)
1374               r0ij=rs0(itypi,itypj)
1375 C
1376 C Check whether the SC's are not too far to make a contact.
1377 C
1378               rcut=1.5d0*r0ij
1379               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1380 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1381 C
1382               if (fcont.gt.0.0D0) then
1383 C If the SC-SC distance if close to sigma, apply spline.
1384 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1385 cAdam &             fcont1,fprimcont1)
1386 cAdam           fcont1=1.0d0-fcont1
1387 cAdam           if (fcont1.gt.0.0d0) then
1388 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1389 cAdam             fcont=fcont*fcont1
1390 cAdam           endif
1391 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1392 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1393 cga             do k=1,3
1394 cga               gg(k)=gg(k)*eps0ij
1395 cga             enddo
1396 cga             eps0ij=-evdwij*eps0ij
1397 C Uncomment for AL's type of SC correlation interactions.
1398 cadam           eps0ij=-evdwij
1399                 num_conti=num_conti+1
1400                 jcont(num_conti,i)=j
1401                 facont(num_conti,i)=fcont*eps0ij
1402                 fprimcont=eps0ij*fprimcont/rij
1403                 fcont=expon*fcont
1404 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1405 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1406 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1407 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1408                 gacont(1,num_conti,i)=-fprimcont*xj
1409                 gacont(2,num_conti,i)=-fprimcont*yj
1410                 gacont(3,num_conti,i)=-fprimcont*zj
1411 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1412 cd              write (iout,'(2i3,3f10.5)')
1413 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1414               endif
1415             endif
1416           enddo      ! j
1417         enddo        ! iint
1418 C Change 12/1/95
1419         num_cont(i)=num_conti
1420       enddo          ! i
1421       do i=1,nct
1422         do j=1,3
1423           gvdwc(j,i)=expon*gvdwc(j,i)
1424           gvdwx(j,i)=expon*gvdwx(j,i)
1425         enddo
1426       enddo
1427 C******************************************************************************
1428 C
1429 C                              N O T E !!!
1430 C
1431 C To save time, the factor of EXPON has been extracted from ALL components
1432 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1433 C use!
1434 C
1435 C******************************************************************************
1436       return
1437       end
1438 C-----------------------------------------------------------------------------
1439       subroutine eljk(evdw)
1440 C
1441 C This subroutine calculates the interaction energy of nonbonded side chains
1442 C assuming the LJK potential of interaction.
1443 C
1444       implicit real*8 (a-h,o-z)
1445       include 'DIMENSIONS'
1446       include 'COMMON.GEO'
1447       include 'COMMON.VAR'
1448       include 'COMMON.LOCAL'
1449       include 'COMMON.CHAIN'
1450       include 'COMMON.DERIV'
1451       include 'COMMON.INTERACT'
1452       include 'COMMON.IOUNITS'
1453       include 'COMMON.NAMES'
1454       dimension gg(3)
1455       logical scheck
1456 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1457       evdw=0.0D0
1458       do i=iatsc_s,iatsc_e
1459         itypi=iabs(itype(i))
1460         if (itypi.eq.ntyp1) cycle
1461         itypi1=iabs(itype(i+1))
1462         xi=c(1,nres+i)
1463         yi=c(2,nres+i)
1464         zi=c(3,nres+i)
1465 C
1466 C Calculate SC interaction energy.
1467 C
1468         do iint=1,nint_gr(i)
1469           do j=istart(i,iint),iend(i,iint)
1470             itypj=iabs(itype(j))
1471             if (itypj.eq.ntyp1) cycle
1472             xj=c(1,nres+j)-xi
1473             yj=c(2,nres+j)-yi
1474             zj=c(3,nres+j)-zi
1475             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1476             fac_augm=rrij**expon
1477             e_augm=augm(itypi,itypj)*fac_augm
1478             r_inv_ij=dsqrt(rrij)
1479             rij=1.0D0/r_inv_ij
1480             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1481             fac=r_shift_inv**expon
1482 C have you changed here?
1483             e1=fac*fac*aa
1484             e2=fac*bb
1485             evdwij=e_augm+e1+e2
1486 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1487 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1488 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1489 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1490 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1491 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1492 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1493             evdw=evdw+evdwij
1494 C
1495 C Calculate the components of the gradient in DC and X
1496 C
1497             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1498             gg(1)=xj*fac
1499             gg(2)=yj*fac
1500             gg(3)=zj*fac
1501             do k=1,3
1502               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1503               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1504               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1505               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1506             enddo
1507 cgrad            do k=i,j-1
1508 cgrad              do l=1,3
1509 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1510 cgrad              enddo
1511 cgrad            enddo
1512           enddo      ! j
1513         enddo        ! iint
1514       enddo          ! i
1515       do i=1,nct
1516         do j=1,3
1517           gvdwc(j,i)=expon*gvdwc(j,i)
1518           gvdwx(j,i)=expon*gvdwx(j,i)
1519         enddo
1520       enddo
1521       return
1522       end
1523 C-----------------------------------------------------------------------------
1524       subroutine ebp(evdw)
1525 C
1526 C This subroutine calculates the interaction energy of nonbonded side chains
1527 C assuming the Berne-Pechukas potential of interaction.
1528 C
1529       implicit real*8 (a-h,o-z)
1530       include 'DIMENSIONS'
1531       include 'COMMON.GEO'
1532       include 'COMMON.VAR'
1533       include 'COMMON.LOCAL'
1534       include 'COMMON.CHAIN'
1535       include 'COMMON.DERIV'
1536       include 'COMMON.NAMES'
1537       include 'COMMON.INTERACT'
1538       include 'COMMON.IOUNITS'
1539       include 'COMMON.CALC'
1540       common /srutu/ icall
1541 c     double precision rrsave(maxdim)
1542       logical lprn
1543       evdw=0.0D0
1544 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1545       evdw=0.0D0
1546 c     if (icall.eq.0) then
1547 c       lprn=.true.
1548 c     else
1549         lprn=.false.
1550 c     endif
1551       ind=0
1552       do i=iatsc_s,iatsc_e
1553         itypi=iabs(itype(i))
1554         if (itypi.eq.ntyp1) cycle
1555         itypi1=iabs(itype(i+1))
1556         xi=c(1,nres+i)
1557         yi=c(2,nres+i)
1558         zi=c(3,nres+i)
1559         dxi=dc_norm(1,nres+i)
1560         dyi=dc_norm(2,nres+i)
1561         dzi=dc_norm(3,nres+i)
1562 c        dsci_inv=dsc_inv(itypi)
1563         dsci_inv=vbld_inv(i+nres)
1564 C
1565 C Calculate SC interaction energy.
1566 C
1567         do iint=1,nint_gr(i)
1568           do j=istart(i,iint),iend(i,iint)
1569             ind=ind+1
1570             itypj=iabs(itype(j))
1571             if (itypj.eq.ntyp1) cycle
1572 c            dscj_inv=dsc_inv(itypj)
1573             dscj_inv=vbld_inv(j+nres)
1574             chi1=chi(itypi,itypj)
1575             chi2=chi(itypj,itypi)
1576             chi12=chi1*chi2
1577             chip1=chip(itypi)
1578             chip2=chip(itypj)
1579             chip12=chip1*chip2
1580             alf1=alp(itypi)
1581             alf2=alp(itypj)
1582             alf12=0.5D0*(alf1+alf2)
1583 C For diagnostics only!!!
1584 c           chi1=0.0D0
1585 c           chi2=0.0D0
1586 c           chi12=0.0D0
1587 c           chip1=0.0D0
1588 c           chip2=0.0D0
1589 c           chip12=0.0D0
1590 c           alf1=0.0D0
1591 c           alf2=0.0D0
1592 c           alf12=0.0D0
1593             xj=c(1,nres+j)-xi
1594             yj=c(2,nres+j)-yi
1595             zj=c(3,nres+j)-zi
1596             dxj=dc_norm(1,nres+j)
1597             dyj=dc_norm(2,nres+j)
1598             dzj=dc_norm(3,nres+j)
1599             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1600 cd          if (icall.eq.0) then
1601 cd            rrsave(ind)=rrij
1602 cd          else
1603 cd            rrij=rrsave(ind)
1604 cd          endif
1605             rij=dsqrt(rrij)
1606 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1607             call sc_angular
1608 C Calculate whole angle-dependent part of epsilon and contributions
1609 C to its derivatives
1610 C have you changed here?
1611             fac=(rrij*sigsq)**expon2
1612             e1=fac*fac*aa
1613             e2=fac*bb
1614             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1615             eps2der=evdwij*eps3rt
1616             eps3der=evdwij*eps2rt
1617             evdwij=evdwij*eps2rt*eps3rt
1618             evdw=evdw+evdwij
1619             if (lprn) then
1620             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1621             epsi=bb**2/aa
1622 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1623 cd     &        restyp(itypi),i,restyp(itypj),j,
1624 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1625 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1626 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1627 cd     &        evdwij
1628             endif
1629 C Calculate gradient components.
1630             e1=e1*eps1*eps2rt**2*eps3rt**2
1631             fac=-expon*(e1+evdwij)
1632             sigder=fac/sigsq
1633             fac=rrij*fac
1634 C Calculate radial part of the gradient
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638 C Calculate the angular part of the gradient and sum add the contributions
1639 C to the appropriate components of the Cartesian gradient.
1640             call sc_grad
1641           enddo      ! j
1642         enddo        ! iint
1643       enddo          ! i
1644 c     stop
1645       return
1646       end
1647 C-----------------------------------------------------------------------------
1648       subroutine egb(evdw)
1649 C
1650 C This subroutine calculates the interaction energy of nonbonded side chains
1651 C assuming the Gay-Berne potential of interaction.
1652 C
1653       implicit real*8 (a-h,o-z)
1654       include 'DIMENSIONS'
1655       include 'COMMON.GEO'
1656       include 'COMMON.VAR'
1657       include 'COMMON.LOCAL'
1658       include 'COMMON.CHAIN'
1659       include 'COMMON.DERIV'
1660       include 'COMMON.NAMES'
1661       include 'COMMON.INTERACT'
1662       include 'COMMON.IOUNITS'
1663       include 'COMMON.CALC'
1664       include 'COMMON.CONTROL'
1665       include 'COMMON.SPLITELE'
1666       include 'COMMON.SBRIDGE'
1667       logical lprn
1668       integer xshift,yshift,zshift
1669
1670       evdw=0.0D0
1671 ccccc      energy_dec=.false.
1672 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1673       evdw=0.0D0
1674       lprn=.false.
1675 c     if (icall.eq.0) lprn=.false.
1676       ind=0
1677 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1678 C we have the original box)
1679 C      do xshift=-1,1
1680 C      do yshift=-1,1
1681 C      do zshift=-1,1
1682       do i=iatsc_s,iatsc_e
1683         itypi=iabs(itype(i))
1684         if (itypi.eq.ntyp1) cycle
1685         itypi1=iabs(itype(i+1))
1686         xi=c(1,nres+i)
1687         yi=c(2,nres+i)
1688         zi=c(3,nres+i)
1689 C Return atom into box, boxxsize is size of box in x dimension
1690 c  134   continue
1691 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1692 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1693 C Condition for being inside the proper box
1694 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1695 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1696 c        go to 134
1697 c        endif
1698 c  135   continue
1699 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1700 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1701 C Condition for being inside the proper box
1702 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1703 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1704 c        go to 135
1705 c        endif
1706 c  136   continue
1707 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1708 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1709 C Condition for being inside the proper box
1710 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1711 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1712 c        go to 136
1713 c        endif
1714           xi=mod(xi,boxxsize)
1715           if (xi.lt.0) xi=xi+boxxsize
1716           yi=mod(yi,boxysize)
1717           if (yi.lt.0) yi=yi+boxysize
1718           zi=mod(zi,boxzsize)
1719           if (zi.lt.0) zi=zi+boxzsize
1720 C define scaling factor for lipids
1721
1722 C        if (positi.le.0) positi=positi+boxzsize
1723 C        print *,i
1724 C first for peptide groups
1725 c for each residue check if it is in lipid or lipid water border area
1726        if ((zi.gt.bordlipbot)
1727      &.and.(zi.lt.bordliptop)) then
1728 C the energy transfer exist
1729         if (zi.lt.buflipbot) then
1730 C what fraction I am in
1731          fracinbuf=1.0d0-
1732      &        ((zi-bordlipbot)/lipbufthick)
1733 C lipbufthick is thickenes of lipid buffore
1734          sslipi=sscalelip(fracinbuf)
1735          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1736         elseif (zi.gt.bufliptop) then
1737          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1738          sslipi=sscalelip(fracinbuf)
1739          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1740         else
1741          sslipi=1.0d0
1742          ssgradlipi=0.0
1743         endif
1744        else
1745          sslipi=0.0d0
1746          ssgradlipi=0.0
1747        endif
1748
1749 C          xi=xi+xshift*boxxsize
1750 C          yi=yi+yshift*boxysize
1751 C          zi=zi+zshift*boxzsize
1752
1753         dxi=dc_norm(1,nres+i)
1754         dyi=dc_norm(2,nres+i)
1755         dzi=dc_norm(3,nres+i)
1756 c        dsci_inv=dsc_inv(itypi)
1757         dsci_inv=vbld_inv(i+nres)
1758 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1759 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1760 C
1761 C Calculate SC interaction energy.
1762 C
1763         do iint=1,nint_gr(i)
1764           do j=istart(i,iint),iend(i,iint)
1765             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1766
1767 c              write(iout,*) "PRZED ZWYKLE", evdwij
1768               call dyn_ssbond_ene(i,j,evdwij)
1769 c              write(iout,*) "PO ZWYKLE", evdwij
1770
1771               evdw=evdw+evdwij
1772               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1773      &                        'evdw',i,j,evdwij,' ss'
1774 C triple bond artifac removal
1775              do k=j+1,iend(i,iint)
1776 C search over all next residues
1777               if (dyn_ss_mask(k)) then
1778 C check if they are cysteins
1779 C              write(iout,*) 'k=',k
1780
1781 c              write(iout,*) "PRZED TRI", evdwij
1782                evdwij_przed_tri=evdwij
1783               call triple_ssbond_ene(i,j,k,evdwij)
1784 c               if(evdwij_przed_tri.ne.evdwij) then
1785 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1786 c               endif
1787
1788 c              write(iout,*) "PO TRI", evdwij
1789 C call the energy function that removes the artifical triple disulfide
1790 C bond the soubroutine is located in ssMD.F
1791               evdw=evdw+evdwij
1792               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1793      &                        'evdw',i,j,evdwij,'tss'
1794               endif!dyn_ss_mask(k)
1795              enddo! k
1796             ELSE
1797             ind=ind+1
1798             itypj=iabs(itype(j))
1799             if (itypj.eq.ntyp1) cycle
1800 c            dscj_inv=dsc_inv(itypj)
1801             dscj_inv=vbld_inv(j+nres)
1802 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1803 c     &       1.0d0/vbld(j+nres)
1804 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1805             sig0ij=sigma(itypi,itypj)
1806             chi1=chi(itypi,itypj)
1807             chi2=chi(itypj,itypi)
1808             chi12=chi1*chi2
1809             chip1=chip(itypi)
1810             chip2=chip(itypj)
1811             chip12=chip1*chip2
1812             alf1=alp(itypi)
1813             alf2=alp(itypj)
1814             alf12=0.5D0*(alf1+alf2)
1815 C For diagnostics only!!!
1816 c           chi1=0.0D0
1817 c           chi2=0.0D0
1818 c           chi12=0.0D0
1819 c           chip1=0.0D0
1820 c           chip2=0.0D0
1821 c           chip12=0.0D0
1822 c           alf1=0.0D0
1823 c           alf2=0.0D0
1824 c           alf12=0.0D0
1825             xj=c(1,nres+j)
1826             yj=c(2,nres+j)
1827             zj=c(3,nres+j)
1828 C Return atom J into box the original box
1829 c  137   continue
1830 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1831 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1832 C Condition for being inside the proper box
1833 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1834 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1835 c        go to 137
1836 c        endif
1837 c  138   continue
1838 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1839 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1840 C Condition for being inside the proper box
1841 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1842 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1843 c        go to 138
1844 c        endif
1845 c  139   continue
1846 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1847 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1848 C Condition for being inside the proper box
1849 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1850 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1851 c        go to 139
1852 c        endif
1853           xj=mod(xj,boxxsize)
1854           if (xj.lt.0) xj=xj+boxxsize
1855           yj=mod(yj,boxysize)
1856           if (yj.lt.0) yj=yj+boxysize
1857           zj=mod(zj,boxzsize)
1858           if (zj.lt.0) zj=zj+boxzsize
1859        if ((zj.gt.bordlipbot)
1860      &.and.(zj.lt.bordliptop)) then
1861 C the energy transfer exist
1862         if (zj.lt.buflipbot) then
1863 C what fraction I am in
1864          fracinbuf=1.0d0-
1865      &        ((zj-bordlipbot)/lipbufthick)
1866 C lipbufthick is thickenes of lipid buffore
1867          sslipj=sscalelip(fracinbuf)
1868          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1869         elseif (zj.gt.bufliptop) then
1870          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1871          sslipj=sscalelip(fracinbuf)
1872          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1873         else
1874          sslipj=1.0d0
1875          ssgradlipj=0.0
1876         endif
1877        else
1878          sslipj=0.0d0
1879          ssgradlipj=0.0
1880        endif
1881       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1882      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1883       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1884      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1885 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1886 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1887 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1888 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1889 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1890       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1891       xj_safe=xj
1892       yj_safe=yj
1893       zj_safe=zj
1894       subchap=0
1895       do xshift=-1,1
1896       do yshift=-1,1
1897       do zshift=-1,1
1898           xj=xj_safe+xshift*boxxsize
1899           yj=yj_safe+yshift*boxysize
1900           zj=zj_safe+zshift*boxzsize
1901           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1902           if(dist_temp.lt.dist_init) then
1903             dist_init=dist_temp
1904             xj_temp=xj
1905             yj_temp=yj
1906             zj_temp=zj
1907             subchap=1
1908           endif
1909        enddo
1910        enddo
1911        enddo
1912        if (subchap.eq.1) then
1913           xj=xj_temp-xi
1914           yj=yj_temp-yi
1915           zj=zj_temp-zi
1916        else
1917           xj=xj_safe-xi
1918           yj=yj_safe-yi
1919           zj=zj_safe-zi
1920        endif
1921             dxj=dc_norm(1,nres+j)
1922             dyj=dc_norm(2,nres+j)
1923             dzj=dc_norm(3,nres+j)
1924 C            xj=xj-xi
1925 C            yj=yj-yi
1926 C            zj=zj-zi
1927 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1928 c            write (iout,*) "j",j," dc_norm",
1929 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1930             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1931             rij=dsqrt(rrij)
1932             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1933             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1934
1935 c            write (iout,'(a7,4f8.3)')
1936 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1937             if (sss.gt.0.0d0) then
1938 C Calculate angle-dependent terms of energy and contributions to their
1939 C derivatives.
1940             call sc_angular
1941             sigsq=1.0D0/sigsq
1942             sig=sig0ij*dsqrt(sigsq)
1943             rij_shift=1.0D0/rij-sig+sig0ij
1944 c for diagnostics; uncomment
1945 c            rij_shift=1.2*sig0ij
1946 C I hate to put IF's in the loops, but here don't have another choice!!!!
1947             if (rij_shift.le.0.0D0) then
1948               evdw=1.0D20
1949 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1950 cd     &        restyp(itypi),i,restyp(itypj),j,
1951 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1952               return
1953             endif
1954             sigder=-sig*sigsq
1955 c---------------------------------------------------------------
1956             rij_shift=1.0D0/rij_shift
1957             fac=rij_shift**expon
1958 C here to start with
1959 C            if (c(i,3).gt.
1960             faclip=fac
1961             e1=fac*fac*aa
1962             e2=fac*bb
1963             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1964             eps2der=evdwij*eps3rt
1965             eps3der=evdwij*eps2rt
1966 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1967 C     &((sslipi+sslipj)/2.0d0+
1968 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1969 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1970 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1971             evdwij=evdwij*eps2rt*eps3rt
1972             evdw=evdw+evdwij*sss
1973             if (lprn) then
1974             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1975             epsi=bb**2/aa
1976             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1977      &        restyp(itypi),i,restyp(itypj),j,
1978      &        epsi,sigm,chi1,chi2,chip1,chip2,
1979      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1980      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1981      &        evdwij
1982             endif
1983
1984             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1985      &                        'evdw',i,j,evdwij
1986
1987 C Calculate gradient components.
1988             e1=e1*eps1*eps2rt**2*eps3rt**2
1989             fac=-expon*(e1+evdwij)*rij_shift
1990             sigder=fac*sigder
1991             fac=rij*fac
1992 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1993 c     &      evdwij,fac,sigma(itypi,itypj),expon
1994             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1995 c            fac=0.0d0
1996 C Calculate the radial part of the gradient
1997             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1998      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1999      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2000      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2001             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2002             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2003 C            gg_lipi(3)=0.0d0
2004 C            gg_lipj(3)=0.0d0
2005             gg(1)=xj*fac
2006             gg(2)=yj*fac
2007             gg(3)=zj*fac
2008 C Calculate angular part of the gradient.
2009             call sc_grad
2010             endif
2011             ENDIF    ! dyn_ss
2012           enddo      ! j
2013         enddo        ! iint
2014       enddo          ! i
2015 C      enddo          ! zshift
2016 C      enddo          ! yshift
2017 C      enddo          ! xshift
2018 c      write (iout,*) "Number of loop steps in EGB:",ind
2019 cccc      energy_dec=.false.
2020       return
2021       end
2022 C-----------------------------------------------------------------------------
2023       subroutine egbv(evdw)
2024 C
2025 C This subroutine calculates the interaction energy of nonbonded side chains
2026 C assuming the Gay-Berne-Vorobjev potential of interaction.
2027 C
2028       implicit real*8 (a-h,o-z)
2029       include 'DIMENSIONS'
2030       include 'COMMON.GEO'
2031       include 'COMMON.VAR'
2032       include 'COMMON.LOCAL'
2033       include 'COMMON.CHAIN'
2034       include 'COMMON.DERIV'
2035       include 'COMMON.NAMES'
2036       include 'COMMON.INTERACT'
2037       include 'COMMON.IOUNITS'
2038       include 'COMMON.CALC'
2039       common /srutu/ icall
2040       logical lprn
2041       evdw=0.0D0
2042 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2043       evdw=0.0D0
2044       lprn=.false.
2045 c     if (icall.eq.0) lprn=.true.
2046       ind=0
2047       do i=iatsc_s,iatsc_e
2048         itypi=iabs(itype(i))
2049         if (itypi.eq.ntyp1) cycle
2050         itypi1=iabs(itype(i+1))
2051         xi=c(1,nres+i)
2052         yi=c(2,nres+i)
2053         zi=c(3,nres+i)
2054           xi=mod(xi,boxxsize)
2055           if (xi.lt.0) xi=xi+boxxsize
2056           yi=mod(yi,boxysize)
2057           if (yi.lt.0) yi=yi+boxysize
2058           zi=mod(zi,boxzsize)
2059           if (zi.lt.0) zi=zi+boxzsize
2060 C define scaling factor for lipids
2061
2062 C        if (positi.le.0) positi=positi+boxzsize
2063 C        print *,i
2064 C first for peptide groups
2065 c for each residue check if it is in lipid or lipid water border area
2066        if ((zi.gt.bordlipbot)
2067      &.and.(zi.lt.bordliptop)) then
2068 C the energy transfer exist
2069         if (zi.lt.buflipbot) then
2070 C what fraction I am in
2071          fracinbuf=1.0d0-
2072      &        ((zi-bordlipbot)/lipbufthick)
2073 C lipbufthick is thickenes of lipid buffore
2074          sslipi=sscalelip(fracinbuf)
2075          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2076         elseif (zi.gt.bufliptop) then
2077          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2078          sslipi=sscalelip(fracinbuf)
2079          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2080         else
2081          sslipi=1.0d0
2082          ssgradlipi=0.0
2083         endif
2084        else
2085          sslipi=0.0d0
2086          ssgradlipi=0.0
2087        endif
2088
2089         dxi=dc_norm(1,nres+i)
2090         dyi=dc_norm(2,nres+i)
2091         dzi=dc_norm(3,nres+i)
2092 c        dsci_inv=dsc_inv(itypi)
2093         dsci_inv=vbld_inv(i+nres)
2094 C
2095 C Calculate SC interaction energy.
2096 C
2097         do iint=1,nint_gr(i)
2098           do j=istart(i,iint),iend(i,iint)
2099             ind=ind+1
2100             itypj=iabs(itype(j))
2101             if (itypj.eq.ntyp1) cycle
2102 c            dscj_inv=dsc_inv(itypj)
2103             dscj_inv=vbld_inv(j+nres)
2104             sig0ij=sigma(itypi,itypj)
2105             r0ij=r0(itypi,itypj)
2106             chi1=chi(itypi,itypj)
2107             chi2=chi(itypj,itypi)
2108             chi12=chi1*chi2
2109             chip1=chip(itypi)
2110             chip2=chip(itypj)
2111             chip12=chip1*chip2
2112             alf1=alp(itypi)
2113             alf2=alp(itypj)
2114             alf12=0.5D0*(alf1+alf2)
2115 C For diagnostics only!!!
2116 c           chi1=0.0D0
2117 c           chi2=0.0D0
2118 c           chi12=0.0D0
2119 c           chip1=0.0D0
2120 c           chip2=0.0D0
2121 c           chip12=0.0D0
2122 c           alf1=0.0D0
2123 c           alf2=0.0D0
2124 c           alf12=0.0D0
2125 C            xj=c(1,nres+j)-xi
2126 C            yj=c(2,nres+j)-yi
2127 C            zj=c(3,nres+j)-zi
2128           xj=mod(xj,boxxsize)
2129           if (xj.lt.0) xj=xj+boxxsize
2130           yj=mod(yj,boxysize)
2131           if (yj.lt.0) yj=yj+boxysize
2132           zj=mod(zj,boxzsize)
2133           if (zj.lt.0) zj=zj+boxzsize
2134        if ((zj.gt.bordlipbot)
2135      &.and.(zj.lt.bordliptop)) then
2136 C the energy transfer exist
2137         if (zj.lt.buflipbot) then
2138 C what fraction I am in
2139          fracinbuf=1.0d0-
2140      &        ((zj-bordlipbot)/lipbufthick)
2141 C lipbufthick is thickenes of lipid buffore
2142          sslipj=sscalelip(fracinbuf)
2143          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2144         elseif (zj.gt.bufliptop) then
2145          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2146          sslipj=sscalelip(fracinbuf)
2147          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2148         else
2149          sslipj=1.0d0
2150          ssgradlipj=0.0
2151         endif
2152        else
2153          sslipj=0.0d0
2154          ssgradlipj=0.0
2155        endif
2156       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2157      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2158       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2159      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2160 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2161 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2162 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2163       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2164       xj_safe=xj
2165       yj_safe=yj
2166       zj_safe=zj
2167       subchap=0
2168       do xshift=-1,1
2169       do yshift=-1,1
2170       do zshift=-1,1
2171           xj=xj_safe+xshift*boxxsize
2172           yj=yj_safe+yshift*boxysize
2173           zj=zj_safe+zshift*boxzsize
2174           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2175           if(dist_temp.lt.dist_init) then
2176             dist_init=dist_temp
2177             xj_temp=xj
2178             yj_temp=yj
2179             zj_temp=zj
2180             subchap=1
2181           endif
2182        enddo
2183        enddo
2184        enddo
2185        if (subchap.eq.1) then
2186           xj=xj_temp-xi
2187           yj=yj_temp-yi
2188           zj=zj_temp-zi
2189        else
2190           xj=xj_safe-xi
2191           yj=yj_safe-yi
2192           zj=zj_safe-zi
2193        endif
2194             dxj=dc_norm(1,nres+j)
2195             dyj=dc_norm(2,nres+j)
2196             dzj=dc_norm(3,nres+j)
2197             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2198             rij=dsqrt(rrij)
2199 C Calculate angle-dependent terms of energy and contributions to their
2200 C derivatives.
2201             call sc_angular
2202             sigsq=1.0D0/sigsq
2203             sig=sig0ij*dsqrt(sigsq)
2204             rij_shift=1.0D0/rij-sig+r0ij
2205 C I hate to put IF's in the loops, but here don't have another choice!!!!
2206             if (rij_shift.le.0.0D0) then
2207               evdw=1.0D20
2208               return
2209             endif
2210             sigder=-sig*sigsq
2211 c---------------------------------------------------------------
2212             rij_shift=1.0D0/rij_shift
2213             fac=rij_shift**expon
2214             e1=fac*fac*aa
2215             e2=fac*bb
2216             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2217             eps2der=evdwij*eps3rt
2218             eps3der=evdwij*eps2rt
2219             fac_augm=rrij**expon
2220             e_augm=augm(itypi,itypj)*fac_augm
2221             evdwij=evdwij*eps2rt*eps3rt
2222             evdw=evdw+evdwij+e_augm
2223             if (lprn) then
2224             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2225             epsi=bb**2/aa
2226             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2227      &        restyp(itypi),i,restyp(itypj),j,
2228      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2229      &        chi1,chi2,chip1,chip2,
2230      &        eps1,eps2rt**2,eps3rt**2,
2231      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2232      &        evdwij+e_augm
2233             endif
2234 C Calculate gradient components.
2235             e1=e1*eps1*eps2rt**2*eps3rt**2
2236             fac=-expon*(e1+evdwij)*rij_shift
2237             sigder=fac*sigder
2238             fac=rij*fac-2*expon*rrij*e_augm
2239             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2240 C Calculate the radial part of the gradient
2241             gg(1)=xj*fac
2242             gg(2)=yj*fac
2243             gg(3)=zj*fac
2244 C Calculate angular part of the gradient.
2245             call sc_grad
2246           enddo      ! j
2247         enddo        ! iint
2248       enddo          ! i
2249       end
2250 C-----------------------------------------------------------------------------
2251       subroutine sc_angular
2252 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2253 C om12. Called by ebp, egb, and egbv.
2254       implicit none
2255       include 'COMMON.CALC'
2256       include 'COMMON.IOUNITS'
2257       erij(1)=xj*rij
2258       erij(2)=yj*rij
2259       erij(3)=zj*rij
2260       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2261       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2262       om12=dxi*dxj+dyi*dyj+dzi*dzj
2263       chiom12=chi12*om12
2264 C Calculate eps1(om12) and its derivative in om12
2265       faceps1=1.0D0-om12*chiom12
2266       faceps1_inv=1.0D0/faceps1
2267       eps1=dsqrt(faceps1_inv)
2268 C Following variable is eps1*deps1/dom12
2269       eps1_om12=faceps1_inv*chiom12
2270 c diagnostics only
2271 c      faceps1_inv=om12
2272 c      eps1=om12
2273 c      eps1_om12=1.0d0
2274 c      write (iout,*) "om12",om12," eps1",eps1
2275 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2276 C and om12.
2277       om1om2=om1*om2
2278       chiom1=chi1*om1
2279       chiom2=chi2*om2
2280       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2281       sigsq=1.0D0-facsig*faceps1_inv
2282       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2283       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2284       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2285 c diagnostics only
2286 c      sigsq=1.0d0
2287 c      sigsq_om1=0.0d0
2288 c      sigsq_om2=0.0d0
2289 c      sigsq_om12=0.0d0
2290 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2291 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2292 c     &    " eps1",eps1
2293 C Calculate eps2 and its derivatives in om1, om2, and om12.
2294       chipom1=chip1*om1
2295       chipom2=chip2*om2
2296       chipom12=chip12*om12
2297       facp=1.0D0-om12*chipom12
2298       facp_inv=1.0D0/facp
2299       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2300 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2301 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2302 C Following variable is the square root of eps2
2303       eps2rt=1.0D0-facp1*facp_inv
2304 C Following three variables are the derivatives of the square root of eps
2305 C in om1, om2, and om12.
2306       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2307       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2308       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2309 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2310       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2311 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2312 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2313 c     &  " eps2rt_om12",eps2rt_om12
2314 C Calculate whole angle-dependent part of epsilon and contributions
2315 C to its derivatives
2316       return
2317       end
2318 C----------------------------------------------------------------------------
2319       subroutine sc_grad
2320       implicit real*8 (a-h,o-z)
2321       include 'DIMENSIONS'
2322       include 'COMMON.CHAIN'
2323       include 'COMMON.DERIV'
2324       include 'COMMON.CALC'
2325       include 'COMMON.IOUNITS'
2326       double precision dcosom1(3),dcosom2(3)
2327 cc      print *,'sss=',sss
2328       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2329       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2330       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2331      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2332 c diagnostics only
2333 c      eom1=0.0d0
2334 c      eom2=0.0d0
2335 c      eom12=evdwij*eps1_om12
2336 c end diagnostics
2337 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2338 c     &  " sigder",sigder
2339 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2340 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2341       do k=1,3
2342         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2343         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2344       enddo
2345       do k=1,3
2346         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2347       enddo
2348 c      write (iout,*) "gg",(gg(k),k=1,3)
2349       do k=1,3
2350         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2351      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2352      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2353         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2354      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2355      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2356 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2357 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2358 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2359 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2360       enddo
2361 C
2362 C Calculate the components of the gradient in DC and X
2363 C
2364 cgrad      do k=i,j-1
2365 cgrad        do l=1,3
2366 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2367 cgrad        enddo
2368 cgrad      enddo
2369       do l=1,3
2370         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2371         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2372       enddo
2373       return
2374       end
2375 C-----------------------------------------------------------------------
2376       subroutine e_softsphere(evdw)
2377 C
2378 C This subroutine calculates the interaction energy of nonbonded side chains
2379 C assuming the LJ potential of interaction.
2380 C
2381       implicit real*8 (a-h,o-z)
2382       include 'DIMENSIONS'
2383       parameter (accur=1.0d-10)
2384       include 'COMMON.GEO'
2385       include 'COMMON.VAR'
2386       include 'COMMON.LOCAL'
2387       include 'COMMON.CHAIN'
2388       include 'COMMON.DERIV'
2389       include 'COMMON.INTERACT'
2390       include 'COMMON.TORSION'
2391       include 'COMMON.SBRIDGE'
2392       include 'COMMON.NAMES'
2393       include 'COMMON.IOUNITS'
2394       include 'COMMON.CONTACTS'
2395       dimension gg(3)
2396 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2397       evdw=0.0D0
2398       do i=iatsc_s,iatsc_e
2399         itypi=iabs(itype(i))
2400         if (itypi.eq.ntyp1) cycle
2401         itypi1=iabs(itype(i+1))
2402         xi=c(1,nres+i)
2403         yi=c(2,nres+i)
2404         zi=c(3,nres+i)
2405 C
2406 C Calculate SC interaction energy.
2407 C
2408         do iint=1,nint_gr(i)
2409 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2410 cd   &                  'iend=',iend(i,iint)
2411           do j=istart(i,iint),iend(i,iint)
2412             itypj=iabs(itype(j))
2413             if (itypj.eq.ntyp1) cycle
2414             xj=c(1,nres+j)-xi
2415             yj=c(2,nres+j)-yi
2416             zj=c(3,nres+j)-zi
2417             rij=xj*xj+yj*yj+zj*zj
2418 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2419             r0ij=r0(itypi,itypj)
2420             r0ijsq=r0ij*r0ij
2421 c            print *,i,j,r0ij,dsqrt(rij)
2422             if (rij.lt.r0ijsq) then
2423               evdwij=0.25d0*(rij-r0ijsq)**2
2424               fac=rij-r0ijsq
2425             else
2426               evdwij=0.0d0
2427               fac=0.0d0
2428             endif
2429             evdw=evdw+evdwij
2430 C
2431 C Calculate the components of the gradient in DC and X
2432 C
2433             gg(1)=xj*fac
2434             gg(2)=yj*fac
2435             gg(3)=zj*fac
2436             do k=1,3
2437               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2438               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2439               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2440               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2441             enddo
2442 cgrad            do k=i,j-1
2443 cgrad              do l=1,3
2444 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2445 cgrad              enddo
2446 cgrad            enddo
2447           enddo ! j
2448         enddo ! iint
2449       enddo ! i
2450       return
2451       end
2452 C--------------------------------------------------------------------------
2453       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2454      &              eello_turn4)
2455 C
2456 C Soft-sphere potential of p-p interaction
2457 C
2458       implicit real*8 (a-h,o-z)
2459       include 'DIMENSIONS'
2460       include 'COMMON.CONTROL'
2461       include 'COMMON.IOUNITS'
2462       include 'COMMON.GEO'
2463       include 'COMMON.VAR'
2464       include 'COMMON.LOCAL'
2465       include 'COMMON.CHAIN'
2466       include 'COMMON.DERIV'
2467       include 'COMMON.INTERACT'
2468       include 'COMMON.CONTACTS'
2469       include 'COMMON.TORSION'
2470       include 'COMMON.VECTORS'
2471       include 'COMMON.FFIELD'
2472       dimension ggg(3)
2473 C      write(iout,*) 'In EELEC_soft_sphere'
2474       ees=0.0D0
2475       evdw1=0.0D0
2476       eel_loc=0.0d0
2477       eello_turn3=0.0d0
2478       eello_turn4=0.0d0
2479       ind=0
2480       do i=iatel_s,iatel_e
2481         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2482         dxi=dc(1,i)
2483         dyi=dc(2,i)
2484         dzi=dc(3,i)
2485         xmedi=c(1,i)+0.5d0*dxi
2486         ymedi=c(2,i)+0.5d0*dyi
2487         zmedi=c(3,i)+0.5d0*dzi
2488           xmedi=mod(xmedi,boxxsize)
2489           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2490           ymedi=mod(ymedi,boxysize)
2491           if (ymedi.lt.0) ymedi=ymedi+boxysize
2492           zmedi=mod(zmedi,boxzsize)
2493           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2494         num_conti=0
2495 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2496         do j=ielstart(i),ielend(i)
2497           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2498           ind=ind+1
2499           iteli=itel(i)
2500           itelj=itel(j)
2501           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2502           r0ij=rpp(iteli,itelj)
2503           r0ijsq=r0ij*r0ij
2504           dxj=dc(1,j)
2505           dyj=dc(2,j)
2506           dzj=dc(3,j)
2507           xj=c(1,j)+0.5D0*dxj
2508           yj=c(2,j)+0.5D0*dyj
2509           zj=c(3,j)+0.5D0*dzj
2510           xj=mod(xj,boxxsize)
2511           if (xj.lt.0) xj=xj+boxxsize
2512           yj=mod(yj,boxysize)
2513           if (yj.lt.0) yj=yj+boxysize
2514           zj=mod(zj,boxzsize)
2515           if (zj.lt.0) zj=zj+boxzsize
2516       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2517       xj_safe=xj
2518       yj_safe=yj
2519       zj_safe=zj
2520       isubchap=0
2521       do xshift=-1,1
2522       do yshift=-1,1
2523       do zshift=-1,1
2524           xj=xj_safe+xshift*boxxsize
2525           yj=yj_safe+yshift*boxysize
2526           zj=zj_safe+zshift*boxzsize
2527           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2528           if(dist_temp.lt.dist_init) then
2529             dist_init=dist_temp
2530             xj_temp=xj
2531             yj_temp=yj
2532             zj_temp=zj
2533             isubchap=1
2534           endif
2535        enddo
2536        enddo
2537        enddo
2538        if (isubchap.eq.1) then
2539           xj=xj_temp-xmedi
2540           yj=yj_temp-ymedi
2541           zj=zj_temp-zmedi
2542        else
2543           xj=xj_safe-xmedi
2544           yj=yj_safe-ymedi
2545           zj=zj_safe-zmedi
2546        endif
2547           rij=xj*xj+yj*yj+zj*zj
2548             sss=sscale(sqrt(rij))
2549             sssgrad=sscagrad(sqrt(rij))
2550           if (rij.lt.r0ijsq) then
2551             evdw1ij=0.25d0*(rij-r0ijsq)**2
2552             fac=rij-r0ijsq
2553           else
2554             evdw1ij=0.0d0
2555             fac=0.0d0
2556           endif
2557           evdw1=evdw1+evdw1ij*sss
2558 C
2559 C Calculate contributions to the Cartesian gradient.
2560 C
2561           ggg(1)=fac*xj*sssgrad
2562           ggg(2)=fac*yj*sssgrad
2563           ggg(3)=fac*zj*sssgrad
2564           do k=1,3
2565             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2566             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2567           enddo
2568 *
2569 * Loop over residues i+1 thru j-1.
2570 *
2571 cgrad          do k=i+1,j-1
2572 cgrad            do l=1,3
2573 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2574 cgrad            enddo
2575 cgrad          enddo
2576         enddo ! j
2577       enddo   ! i
2578 cgrad      do i=nnt,nct-1
2579 cgrad        do k=1,3
2580 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2581 cgrad        enddo
2582 cgrad        do j=i+1,nct-1
2583 cgrad          do k=1,3
2584 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2585 cgrad          enddo
2586 cgrad        enddo
2587 cgrad      enddo
2588       return
2589       end
2590 c------------------------------------------------------------------------------
2591       subroutine vec_and_deriv
2592       implicit real*8 (a-h,o-z)
2593       include 'DIMENSIONS'
2594 #ifdef MPI
2595       include 'mpif.h'
2596 #endif
2597       include 'COMMON.IOUNITS'
2598       include 'COMMON.GEO'
2599       include 'COMMON.VAR'
2600       include 'COMMON.LOCAL'
2601       include 'COMMON.CHAIN'
2602       include 'COMMON.VECTORS'
2603       include 'COMMON.SETUP'
2604       include 'COMMON.TIME1'
2605       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2606 C Compute the local reference systems. For reference system (i), the
2607 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2608 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2609 #ifdef PARVEC
2610       do i=ivec_start,ivec_end
2611 #else
2612       do i=1,nres-1
2613 #endif
2614           if (i.eq.nres-1) then
2615 C Case of the last full residue
2616 C Compute the Z-axis
2617             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2618             costh=dcos(pi-theta(nres))
2619             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2620             do k=1,3
2621               uz(k,i)=fac*uz(k,i)
2622             enddo
2623 C Compute the derivatives of uz
2624             uzder(1,1,1)= 0.0d0
2625             uzder(2,1,1)=-dc_norm(3,i-1)
2626             uzder(3,1,1)= dc_norm(2,i-1)
2627             uzder(1,2,1)= dc_norm(3,i-1)
2628             uzder(2,2,1)= 0.0d0
2629             uzder(3,2,1)=-dc_norm(1,i-1)
2630             uzder(1,3,1)=-dc_norm(2,i-1)
2631             uzder(2,3,1)= dc_norm(1,i-1)
2632             uzder(3,3,1)= 0.0d0
2633             uzder(1,1,2)= 0.0d0
2634             uzder(2,1,2)= dc_norm(3,i)
2635             uzder(3,1,2)=-dc_norm(2,i)
2636             uzder(1,2,2)=-dc_norm(3,i)
2637             uzder(2,2,2)= 0.0d0
2638             uzder(3,2,2)= dc_norm(1,i)
2639             uzder(1,3,2)= dc_norm(2,i)
2640             uzder(2,3,2)=-dc_norm(1,i)
2641             uzder(3,3,2)= 0.0d0
2642 C Compute the Y-axis
2643             facy=fac
2644             do k=1,3
2645               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2646             enddo
2647 C Compute the derivatives of uy
2648             do j=1,3
2649               do k=1,3
2650                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2651      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2652                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2653               enddo
2654               uyder(j,j,1)=uyder(j,j,1)-costh
2655               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2656             enddo
2657             do j=1,2
2658               do k=1,3
2659                 do l=1,3
2660                   uygrad(l,k,j,i)=uyder(l,k,j)
2661                   uzgrad(l,k,j,i)=uzder(l,k,j)
2662                 enddo
2663               enddo
2664             enddo
2665             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2666             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2667             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2668             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2669           else
2670 C Other residues
2671 C Compute the Z-axis
2672             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2673             costh=dcos(pi-theta(i+2))
2674             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2675             do k=1,3
2676               uz(k,i)=fac*uz(k,i)
2677             enddo
2678 C Compute the derivatives of uz
2679             uzder(1,1,1)= 0.0d0
2680             uzder(2,1,1)=-dc_norm(3,i+1)
2681             uzder(3,1,1)= dc_norm(2,i+1)
2682             uzder(1,2,1)= dc_norm(3,i+1)
2683             uzder(2,2,1)= 0.0d0
2684             uzder(3,2,1)=-dc_norm(1,i+1)
2685             uzder(1,3,1)=-dc_norm(2,i+1)
2686             uzder(2,3,1)= dc_norm(1,i+1)
2687             uzder(3,3,1)= 0.0d0
2688             uzder(1,1,2)= 0.0d0
2689             uzder(2,1,2)= dc_norm(3,i)
2690             uzder(3,1,2)=-dc_norm(2,i)
2691             uzder(1,2,2)=-dc_norm(3,i)
2692             uzder(2,2,2)= 0.0d0
2693             uzder(3,2,2)= dc_norm(1,i)
2694             uzder(1,3,2)= dc_norm(2,i)
2695             uzder(2,3,2)=-dc_norm(1,i)
2696             uzder(3,3,2)= 0.0d0
2697 C Compute the Y-axis
2698             facy=fac
2699             do k=1,3
2700               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2701             enddo
2702 C Compute the derivatives of uy
2703             do j=1,3
2704               do k=1,3
2705                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2706      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2707                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2708               enddo
2709               uyder(j,j,1)=uyder(j,j,1)-costh
2710               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2711             enddo
2712             do j=1,2
2713               do k=1,3
2714                 do l=1,3
2715                   uygrad(l,k,j,i)=uyder(l,k,j)
2716                   uzgrad(l,k,j,i)=uzder(l,k,j)
2717                 enddo
2718               enddo
2719             enddo
2720             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2721             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2722             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2723             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2724           endif
2725       enddo
2726       do i=1,nres-1
2727         vbld_inv_temp(1)=vbld_inv(i+1)
2728         if (i.lt.nres-1) then
2729           vbld_inv_temp(2)=vbld_inv(i+2)
2730           else
2731           vbld_inv_temp(2)=vbld_inv(i)
2732           endif
2733         do j=1,2
2734           do k=1,3
2735             do l=1,3
2736               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2737               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2738             enddo
2739           enddo
2740         enddo
2741       enddo
2742 #if defined(PARVEC) && defined(MPI)
2743       if (nfgtasks1.gt.1) then
2744         time00=MPI_Wtime()
2745 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2746 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2747 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2748         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2750      &   FG_COMM1,IERR)
2751         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2755      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2756      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2757         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2758      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2759      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2760         time_gather=time_gather+MPI_Wtime()-time00
2761       endif
2762 c      if (fg_rank.eq.0) then
2763 c        write (iout,*) "Arrays UY and UZ"
2764 c        do i=1,nres-1
2765 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2766 c     &     (uz(k,i),k=1,3)
2767 c        enddo
2768 c      endif
2769 #endif
2770       return
2771       end
2772 C-----------------------------------------------------------------------------
2773       subroutine check_vecgrad
2774       implicit real*8 (a-h,o-z)
2775       include 'DIMENSIONS'
2776       include 'COMMON.IOUNITS'
2777       include 'COMMON.GEO'
2778       include 'COMMON.VAR'
2779       include 'COMMON.LOCAL'
2780       include 'COMMON.CHAIN'
2781       include 'COMMON.VECTORS'
2782       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2783       dimension uyt(3,maxres),uzt(3,maxres)
2784       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2785       double precision delta /1.0d-7/
2786       call vec_and_deriv
2787 cd      do i=1,nres
2788 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2789 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2790 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2791 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2792 cd     &     (dc_norm(if90,i),if90=1,3)
2793 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2794 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2795 cd          write(iout,'(a)')
2796 cd      enddo
2797       do i=1,nres
2798         do j=1,2
2799           do k=1,3
2800             do l=1,3
2801               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2802               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2803             enddo
2804           enddo
2805         enddo
2806       enddo
2807       call vec_and_deriv
2808       do i=1,nres
2809         do j=1,3
2810           uyt(j,i)=uy(j,i)
2811           uzt(j,i)=uz(j,i)
2812         enddo
2813       enddo
2814       do i=1,nres
2815 cd        write (iout,*) 'i=',i
2816         do k=1,3
2817           erij(k)=dc_norm(k,i)
2818         enddo
2819         do j=1,3
2820           do k=1,3
2821             dc_norm(k,i)=erij(k)
2822           enddo
2823           dc_norm(j,i)=dc_norm(j,i)+delta
2824 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2825 c          do k=1,3
2826 c            dc_norm(k,i)=dc_norm(k,i)/fac
2827 c          enddo
2828 c          write (iout,*) (dc_norm(k,i),k=1,3)
2829 c          write (iout,*) (erij(k),k=1,3)
2830           call vec_and_deriv
2831           do k=1,3
2832             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2833             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2834             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2835             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2836           enddo
2837 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2838 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2839 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2840         enddo
2841         do k=1,3
2842           dc_norm(k,i)=erij(k)
2843         enddo
2844 cd        do k=1,3
2845 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2846 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2847 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2848 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2849 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2850 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2851 cd          write (iout,'(a)')
2852 cd        enddo
2853       enddo
2854       return
2855       end
2856 C--------------------------------------------------------------------------
2857       subroutine set_matrices
2858       implicit real*8 (a-h,o-z)
2859       include 'DIMENSIONS'
2860 #ifdef MPI
2861       include "mpif.h"
2862       include "COMMON.SETUP"
2863       integer IERR
2864       integer status(MPI_STATUS_SIZE)
2865 #endif
2866       include 'COMMON.IOUNITS'
2867       include 'COMMON.GEO'
2868       include 'COMMON.VAR'
2869       include 'COMMON.LOCAL'
2870       include 'COMMON.CHAIN'
2871       include 'COMMON.DERIV'
2872       include 'COMMON.INTERACT'
2873       include 'COMMON.CONTACTS'
2874       include 'COMMON.TORSION'
2875       include 'COMMON.VECTORS'
2876       include 'COMMON.FFIELD'
2877       double precision auxvec(2),auxmat(2,2)
2878 C
2879 C Compute the virtual-bond-torsional-angle dependent quantities needed
2880 C to calculate the el-loc multibody terms of various order.
2881 C
2882 c      write(iout,*) 'nphi=',nphi,nres
2883 #ifdef PARMAT
2884       do i=ivec_start+2,ivec_end+2
2885 #else
2886       do i=3,nres+1
2887 #endif
2888 #ifdef NEWCORR
2889         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2890           iti = itype2loc(itype(i-2))
2891         else
2892           iti=nloctyp
2893         endif
2894 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2895         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2896           iti1 = itype2loc(itype(i-1))
2897         else
2898           iti1=nloctyp
2899         endif
2900 c        write(iout,*),i
2901         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2902      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2903      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2904         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2905      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2906      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2907 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2908 c     &*(cos(theta(i)/2.0)
2909         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2910      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2911      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2912 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2913 c     &*(cos(theta(i)/2.0)
2914         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2915      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2916      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2917 c        if (ggb1(1,i).eq.0.0d0) then
2918 c        write(iout,*) 'i=',i,ggb1(1,i),
2919 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2920 c     &bnew1(2,1,iti)*cos(theta(i)),
2921 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2922 c        endif
2923         b1(2,i-2)=bnew1(1,2,iti)
2924         gtb1(2,i-2)=0.0
2925         b2(2,i-2)=bnew2(1,2,iti)
2926         gtb2(2,i-2)=0.0
2927         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2928         EE(1,2,i-2)=eeold(1,2,iti)
2929         EE(2,1,i-2)=eeold(2,1,iti)
2930         EE(2,2,i-2)=eeold(2,2,iti)
2931         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2932         gtEE(1,2,i-2)=0.0d0
2933         gtEE(2,2,i-2)=0.0d0
2934         gtEE(2,1,i-2)=0.0d0
2935 c        EE(2,2,iti)=0.0d0
2936 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2937 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2938 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2939 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2940        b1tilde(1,i-2)=b1(1,i-2)
2941        b1tilde(2,i-2)=-b1(2,i-2)
2942        b2tilde(1,i-2)=b2(1,i-2)
2943        b2tilde(2,i-2)=-b2(2,i-2)
2944 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2945 c       write(iout,*)  'b1=',b1(1,i-2)
2946 c       write (iout,*) 'theta=', theta(i-1)
2947        enddo
2948 #else
2949         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2950           iti = itype2loc(itype(i-2))
2951         else
2952           iti=nloctyp
2953         endif
2954 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2955         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2956           iti1 = itype2loc(itype(i-1))
2957         else
2958           iti1=nloctyp
2959         endif
2960         b1(1,i-2)=b(3,iti)
2961         b1(2,i-2)=b(5,iti)
2962         b2(1,i-2)=b(2,iti)
2963         b2(2,i-2)=b(4,iti)
2964        b1tilde(1,i-2)=b1(1,i-2)
2965        b1tilde(2,i-2)=-b1(2,i-2)
2966        b2tilde(1,i-2)=b2(1,i-2)
2967        b2tilde(2,i-2)=-b2(2,i-2)
2968         EE(1,2,i-2)=eeold(1,2,iti)
2969         EE(2,1,i-2)=eeold(2,1,iti)
2970         EE(2,2,i-2)=eeold(2,2,iti)
2971         EE(1,1,i-2)=eeold(1,1,iti)
2972       enddo
2973 #endif
2974 #ifdef PARMAT
2975       do i=ivec_start+2,ivec_end+2
2976 #else
2977       do i=3,nres+1
2978 #endif
2979         if (i .lt. nres+1) then
2980           sin1=dsin(phi(i))
2981           cos1=dcos(phi(i))
2982           sintab(i-2)=sin1
2983           costab(i-2)=cos1
2984           obrot(1,i-2)=cos1
2985           obrot(2,i-2)=sin1
2986           sin2=dsin(2*phi(i))
2987           cos2=dcos(2*phi(i))
2988           sintab2(i-2)=sin2
2989           costab2(i-2)=cos2
2990           obrot2(1,i-2)=cos2
2991           obrot2(2,i-2)=sin2
2992           Ug(1,1,i-2)=-cos1
2993           Ug(1,2,i-2)=-sin1
2994           Ug(2,1,i-2)=-sin1
2995           Ug(2,2,i-2)= cos1
2996           Ug2(1,1,i-2)=-cos2
2997           Ug2(1,2,i-2)=-sin2
2998           Ug2(2,1,i-2)=-sin2
2999           Ug2(2,2,i-2)= cos2
3000         else
3001           costab(i-2)=1.0d0
3002           sintab(i-2)=0.0d0
3003           obrot(1,i-2)=1.0d0
3004           obrot(2,i-2)=0.0d0
3005           obrot2(1,i-2)=0.0d0
3006           obrot2(2,i-2)=0.0d0
3007           Ug(1,1,i-2)=1.0d0
3008           Ug(1,2,i-2)=0.0d0
3009           Ug(2,1,i-2)=0.0d0
3010           Ug(2,2,i-2)=1.0d0
3011           Ug2(1,1,i-2)=0.0d0
3012           Ug2(1,2,i-2)=0.0d0
3013           Ug2(2,1,i-2)=0.0d0
3014           Ug2(2,2,i-2)=0.0d0
3015         endif
3016         if (i .gt. 3 .and. i .lt. nres+1) then
3017           obrot_der(1,i-2)=-sin1
3018           obrot_der(2,i-2)= cos1
3019           Ugder(1,1,i-2)= sin1
3020           Ugder(1,2,i-2)=-cos1
3021           Ugder(2,1,i-2)=-cos1
3022           Ugder(2,2,i-2)=-sin1
3023           dwacos2=cos2+cos2
3024           dwasin2=sin2+sin2
3025           obrot2_der(1,i-2)=-dwasin2
3026           obrot2_der(2,i-2)= dwacos2
3027           Ug2der(1,1,i-2)= dwasin2
3028           Ug2der(1,2,i-2)=-dwacos2
3029           Ug2der(2,1,i-2)=-dwacos2
3030           Ug2der(2,2,i-2)=-dwasin2
3031         else
3032           obrot_der(1,i-2)=0.0d0
3033           obrot_der(2,i-2)=0.0d0
3034           Ugder(1,1,i-2)=0.0d0
3035           Ugder(1,2,i-2)=0.0d0
3036           Ugder(2,1,i-2)=0.0d0
3037           Ugder(2,2,i-2)=0.0d0
3038           obrot2_der(1,i-2)=0.0d0
3039           obrot2_der(2,i-2)=0.0d0
3040           Ug2der(1,1,i-2)=0.0d0
3041           Ug2der(1,2,i-2)=0.0d0
3042           Ug2der(2,1,i-2)=0.0d0
3043           Ug2der(2,2,i-2)=0.0d0
3044         endif
3045 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3046         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3047           iti = itype2loc(itype(i-2))
3048         else
3049           iti=nloctyp
3050         endif
3051 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3052         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3053           iti1 = itype2loc(itype(i-1))
3054         else
3055           iti1=nloctyp
3056         endif
3057 cd        write (iout,*) '*******i',i,' iti1',iti
3058 cd        write (iout,*) 'b1',b1(:,iti)
3059 cd        write (iout,*) 'b2',b2(:,iti)
3060 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3061 c        if (i .gt. iatel_s+2) then
3062         if (i .gt. nnt+2) then
3063           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3064 #ifdef NEWCORR
3065           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3066 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3067 #endif
3068 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3069 c     &    EE(1,2,iti),EE(2,2,i)
3070           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3071           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3072 c          write(iout,*) "Macierz EUG",
3073 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3074 c     &    eug(2,2,i-2)
3075           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3076      &    then
3077           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3078           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3079           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3080           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3081           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3082           endif
3083         else
3084           do k=1,2
3085             Ub2(k,i-2)=0.0d0
3086             Ctobr(k,i-2)=0.0d0
3087             Dtobr2(k,i-2)=0.0d0
3088             do l=1,2
3089               EUg(l,k,i-2)=0.0d0
3090               CUg(l,k,i-2)=0.0d0
3091               DUg(l,k,i-2)=0.0d0
3092               DtUg2(l,k,i-2)=0.0d0
3093             enddo
3094           enddo
3095         endif
3096         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3097         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3098         do k=1,2
3099           muder(k,i-2)=Ub2der(k,i-2)
3100         enddo
3101 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3102         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3103           if (itype(i-1).le.ntyp) then
3104             iti1 = itype2loc(itype(i-1))
3105           else
3106             iti1=nloctyp
3107           endif
3108         else
3109           iti1=nloctyp
3110         endif
3111         do k=1,2
3112           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3113         enddo
3114 #ifdef MUOUT
3115         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3116      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3117      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3118      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3119      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3120      &      ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3121 #endif
3122 cd        write (iout,*) 'mu1',mu1(:,i-2)
3123 cd        write (iout,*) 'mu2',mu2(:,i-2)
3124         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3125      &  then
3126         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3127         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3128         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3129         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3130         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3131 C Vectors and matrices dependent on a single virtual-bond dihedral.
3132         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3133         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3134         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3135         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3136         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3137         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3138         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3139         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3140         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3141         endif
3142       enddo
3143 C Matrices dependent on two consecutive virtual-bond dihedrals.
3144 C The order of matrices is from left to right.
3145       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3146      &then
3147 c      do i=max0(ivec_start,2),ivec_end
3148       do i=2,nres-1
3149         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3150         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3151         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3152         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3153         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3154         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3155         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3156         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3157       enddo
3158       endif
3159 #if defined(MPI) && defined(PARMAT)
3160 #ifdef DEBUG
3161 c      if (fg_rank.eq.0) then
3162         write (iout,*) "Arrays UG and UGDER before GATHER"
3163         do i=1,nres-1
3164           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3165      &     ((ug(l,k,i),l=1,2),k=1,2),
3166      &     ((ugder(l,k,i),l=1,2),k=1,2)
3167         enddo
3168         write (iout,*) "Arrays UG2 and UG2DER"
3169         do i=1,nres-1
3170           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3171      &     ((ug2(l,k,i),l=1,2),k=1,2),
3172      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3173         enddo
3174         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3175         do i=1,nres-1
3176           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3177      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3178      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3179         enddo
3180         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3181         do i=1,nres-1
3182           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3183      &     costab(i),sintab(i),costab2(i),sintab2(i)
3184         enddo
3185         write (iout,*) "Array MUDER"
3186         do i=1,nres-1
3187           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3188         enddo
3189 c      endif
3190 #endif
3191       if (nfgtasks.gt.1) then
3192         time00=MPI_Wtime()
3193 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3194 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3195 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3196 #ifdef MATGATHER
3197         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3198      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3199      &   FG_COMM1,IERR)
3200         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3201      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3202      &   FG_COMM1,IERR)
3203         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3204      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3205      &   FG_COMM1,IERR)
3206         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3207      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3208      &   FG_COMM1,IERR)
3209         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3210      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3211      &   FG_COMM1,IERR)
3212         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3213      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3214      &   FG_COMM1,IERR)
3215         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3216      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3217      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3218         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3219      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3220      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3221         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3222      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3223      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3224         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3225      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3226      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3227         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3228      &  then
3229         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3230      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3231      &   FG_COMM1,IERR)
3232         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3233      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3234      &   FG_COMM1,IERR)
3235         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3236      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3237      &   FG_COMM1,IERR)
3238        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3239      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3240      &   FG_COMM1,IERR)
3241         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3242      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3243      &   FG_COMM1,IERR)
3244         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3245      &   ivec_count(fg_rank1),
3246      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3247      &   FG_COMM1,IERR)
3248         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3249      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3250      &   FG_COMM1,IERR)
3251         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3253      &   FG_COMM1,IERR)
3254         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3259      &   FG_COMM1,IERR)
3260         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3261      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3262      &   FG_COMM1,IERR)
3263         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3264      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3267      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3268      &   FG_COMM1,IERR)
3269         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3270      &   ivec_count(fg_rank1),
3271      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3272      &   FG_COMM1,IERR)
3273         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3274      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3275      &   FG_COMM1,IERR)
3276        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3277      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278      &   FG_COMM1,IERR)
3279         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3280      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281      &   FG_COMM1,IERR)
3282        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3283      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3286      &   ivec_count(fg_rank1),
3287      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3290      &   ivec_count(fg_rank1),
3291      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3292      &   FG_COMM1,IERR)
3293         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3294      &   ivec_count(fg_rank1),
3295      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3296      &   MPI_MAT2,FG_COMM1,IERR)
3297         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3298      &   ivec_count(fg_rank1),
3299      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3300      &   MPI_MAT2,FG_COMM1,IERR)
3301         endif
3302 #else
3303 c Passes matrix info through the ring
3304       isend=fg_rank1
3305       irecv=fg_rank1-1
3306       if (irecv.lt.0) irecv=nfgtasks1-1
3307       iprev=irecv
3308       inext=fg_rank1+1
3309       if (inext.ge.nfgtasks1) inext=0
3310       do i=1,nfgtasks1-1
3311 c        write (iout,*) "isend",isend," irecv",irecv
3312 c        call flush(iout)
3313         lensend=lentyp(isend)
3314         lenrecv=lentyp(irecv)
3315 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3316 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3317 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3318 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3319 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3320 c        write (iout,*) "Gather ROTAT1"
3321 c        call flush(iout)
3322 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3323 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3324 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3325 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3326 c        write (iout,*) "Gather ROTAT2"
3327 c        call flush(iout)
3328         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3329      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3330      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3331      &   iprev,4400+irecv,FG_COMM,status,IERR)
3332 c        write (iout,*) "Gather ROTAT_OLD"
3333 c        call flush(iout)
3334         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3335      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3336      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3337      &   iprev,5500+irecv,FG_COMM,status,IERR)
3338 c        write (iout,*) "Gather PRECOMP11"
3339 c        call flush(iout)
3340         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3341      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3342      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3343      &   iprev,6600+irecv,FG_COMM,status,IERR)
3344 c        write (iout,*) "Gather PRECOMP12"
3345 c        call flush(iout)
3346         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3347      &  then
3348         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3349      &   MPI_ROTAT2(lensend),inext,7700+isend,
3350      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3351      &   iprev,7700+irecv,FG_COMM,status,IERR)
3352 c        write (iout,*) "Gather PRECOMP21"
3353 c        call flush(iout)
3354         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3355      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3356      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3357      &   iprev,8800+irecv,FG_COMM,status,IERR)
3358 c        write (iout,*) "Gather PRECOMP22"
3359 c        call flush(iout)
3360         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3361      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3362      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3363      &   MPI_PRECOMP23(lenrecv),
3364      &   iprev,9900+irecv,FG_COMM,status,IERR)
3365 c        write (iout,*) "Gather PRECOMP23"
3366 c        call flush(iout)
3367         endif
3368         isend=irecv
3369         irecv=irecv-1
3370         if (irecv.lt.0) irecv=nfgtasks1-1
3371       enddo
3372 #endif
3373         time_gather=time_gather+MPI_Wtime()-time00
3374       endif
3375 #ifdef DEBUG
3376 c      if (fg_rank.eq.0) then
3377         write (iout,*) "Arrays UG and UGDER"
3378         do i=1,nres-1
3379           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3380      &     ((ug(l,k,i),l=1,2),k=1,2),
3381      &     ((ugder(l,k,i),l=1,2),k=1,2)
3382         enddo
3383         write (iout,*) "Arrays UG2 and UG2DER"
3384         do i=1,nres-1
3385           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3386      &     ((ug2(l,k,i),l=1,2),k=1,2),
3387      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3388         enddo
3389         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3390         do i=1,nres-1
3391           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3392      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3393      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3394         enddo
3395         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3396         do i=1,nres-1
3397           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3398      &     costab(i),sintab(i),costab2(i),sintab2(i)
3399         enddo
3400         write (iout,*) "Array MUDER"
3401         do i=1,nres-1
3402           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3403         enddo
3404 c      endif
3405 #endif
3406 #endif
3407 cd      do i=1,nres
3408 cd        iti = itype2loc(itype(i))
3409 cd        write (iout,*) i
3410 cd        do j=1,2
3411 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3412 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3413 cd        enddo
3414 cd      enddo
3415       return
3416       end
3417 C--------------------------------------------------------------------------
3418       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3419 C
3420 C This subroutine calculates the average interaction energy and its gradient
3421 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3422 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3423 C The potential depends both on the distance of peptide-group centers and on
3424 C the orientation of the CA-CA virtual bonds.
3425 C
3426       implicit real*8 (a-h,o-z)
3427 #ifdef MPI
3428       include 'mpif.h'
3429 #endif
3430       include 'DIMENSIONS'
3431       include 'COMMON.CONTROL'
3432       include 'COMMON.SETUP'
3433       include 'COMMON.IOUNITS'
3434       include 'COMMON.GEO'
3435       include 'COMMON.VAR'
3436       include 'COMMON.LOCAL'
3437       include 'COMMON.CHAIN'
3438       include 'COMMON.DERIV'
3439       include 'COMMON.INTERACT'
3440       include 'COMMON.CONTACTS'
3441       include 'COMMON.TORSION'
3442       include 'COMMON.VECTORS'
3443       include 'COMMON.FFIELD'
3444       include 'COMMON.TIME1'
3445       include 'COMMON.SPLITELE'
3446       include 'COMMON.SHIELD'
3447       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3448      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3449       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3450      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3451       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3452      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3453      &    num_conti,j1,j2
3454 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3455 #ifdef MOMENT
3456       double precision scal_el /1.0d0/
3457 #else
3458       double precision scal_el /0.5d0/
3459 #endif
3460 C 12/13/98
3461 C 13-go grudnia roku pamietnego...
3462       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3463      &                   0.0d0,1.0d0,0.0d0,
3464      &                   0.0d0,0.0d0,1.0d0/
3465 cd      write(iout,*) 'In EELEC'
3466 cd      do i=1,nloctyp
3467 cd        write(iout,*) 'Type',i
3468 cd        write(iout,*) 'B1',B1(:,i)
3469 cd        write(iout,*) 'B2',B2(:,i)
3470 cd        write(iout,*) 'CC',CC(:,:,i)
3471 cd        write(iout,*) 'DD',DD(:,:,i)
3472 cd        write(iout,*) 'EE',EE(:,:,i)
3473 cd      enddo
3474 cd      call check_vecgrad
3475 cd      stop
3476       if (icheckgrad.eq.1) then
3477         do i=1,nres-1
3478           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3479           do k=1,3
3480             dc_norm(k,i)=dc(k,i)*fac
3481           enddo
3482 c          write (iout,*) 'i',i,' fac',fac
3483         enddo
3484       endif
3485       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3486      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3487      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3488 c        call vec_and_deriv
3489 #ifdef TIMING
3490         time01=MPI_Wtime()
3491 #endif
3492         call set_matrices
3493 #ifdef TIMING
3494         time_mat=time_mat+MPI_Wtime()-time01
3495 #endif
3496       endif
3497 cd      do i=1,nres-1
3498 cd        write (iout,*) 'i=',i
3499 cd        do k=1,3
3500 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3501 cd        enddo
3502 cd        do k=1,3
3503 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3504 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3505 cd        enddo
3506 cd      enddo
3507       t_eelecij=0.0d0
3508       ees=0.0D0
3509       evdw1=0.0D0
3510       eel_loc=0.0d0
3511       eello_turn3=0.0d0
3512       eello_turn4=0.0d0
3513       ind=0
3514       do i=1,nres
3515         num_cont_hb(i)=0
3516       enddo
3517 cd      print '(a)','Enter EELEC'
3518 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3519       do i=1,nres
3520         gel_loc_loc(i)=0.0d0
3521         gcorr_loc(i)=0.0d0
3522       enddo
3523 c
3524 c
3525 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3526 C
3527 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3528 C
3529 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3530       do i=iturn3_start,iturn3_end
3531 c        if (i.le.1) cycle
3532 C        write(iout,*) "tu jest i",i
3533         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3534 C changes suggested by Ana to avoid out of bounds
3535 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3536 c     & .or.((i+4).gt.nres)
3537 c     & .or.((i-1).le.0)
3538 C end of changes by Ana
3539      &  .or. itype(i+2).eq.ntyp1
3540      &  .or. itype(i+3).eq.ntyp1) cycle
3541 C Adam: Instructions below will switch off existing interactions
3542 c        if(i.gt.1)then
3543 c          if(itype(i-1).eq.ntyp1)cycle
3544 c        end if
3545 c        if(i.LT.nres-3)then
3546 c          if (itype(i+4).eq.ntyp1) cycle
3547 c        end if
3548         dxi=dc(1,i)
3549         dyi=dc(2,i)
3550         dzi=dc(3,i)
3551         dx_normi=dc_norm(1,i)
3552         dy_normi=dc_norm(2,i)
3553         dz_normi=dc_norm(3,i)
3554         xmedi=c(1,i)+0.5d0*dxi
3555         ymedi=c(2,i)+0.5d0*dyi
3556         zmedi=c(3,i)+0.5d0*dzi
3557           xmedi=mod(xmedi,boxxsize)
3558           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3559           ymedi=mod(ymedi,boxysize)
3560           if (ymedi.lt.0) ymedi=ymedi+boxysize
3561           zmedi=mod(zmedi,boxzsize)
3562           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3563           zmedi2=mod(zmedi,boxzsize)
3564           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3565        if ((zmedi2.gt.bordlipbot)
3566      &.and.(zmedi2.lt.bordliptop)) then
3567 C the energy transfer exist
3568         if (zmedi2.lt.buflipbot) then
3569 C what fraction I am in
3570          fracinbuf=1.0d0-
3571      &        ((zmedi2-bordlipbot)/lipbufthick)
3572 C lipbufthick is thickenes of lipid buffore
3573          sslipi=sscalelip(fracinbuf)
3574          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3575         elseif (zmedi2.gt.bufliptop) then
3576          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3577          sslipi=sscalelip(fracinbuf)
3578          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3579         else
3580          sslipi=1.0d0
3581          ssgradlipi=0.0d0
3582         endif
3583        else
3584          sslipi=0.0d0
3585          ssgradlipi=0.0d0
3586        endif
3587         num_conti=0
3588         call eelecij(i,i+2,ees,evdw1,eel_loc)
3589         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3590         num_cont_hb(i)=num_conti
3591       enddo
3592       do i=iturn4_start,iturn4_end
3593         if (i.lt.1) cycle
3594         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3595 C changes suggested by Ana to avoid out of bounds
3596 c     & .or.((i+5).gt.nres)
3597 c     & .or.((i-1).le.0)
3598 C end of changes suggested by Ana
3599      &    .or. itype(i+3).eq.ntyp1
3600      &    .or. itype(i+4).eq.ntyp1
3601 c     &    .or. itype(i+5).eq.ntyp1
3602 c     &    .or. itype(i).eq.ntyp1
3603 c     &    .or. itype(i-1).eq.ntyp1
3604      &                             ) cycle
3605         dxi=dc(1,i)
3606         dyi=dc(2,i)
3607         dzi=dc(3,i)
3608         dx_normi=dc_norm(1,i)
3609         dy_normi=dc_norm(2,i)
3610         dz_normi=dc_norm(3,i)
3611         xmedi=c(1,i)+0.5d0*dxi
3612         ymedi=c(2,i)+0.5d0*dyi
3613         zmedi=c(3,i)+0.5d0*dzi
3614 C Return atom into box, boxxsize is size of box in x dimension
3615 c  194   continue
3616 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3617 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3618 C Condition for being inside the proper box
3619 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3620 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3621 c        go to 194
3622 c        endif
3623 c  195   continue
3624 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3625 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3626 C Condition for being inside the proper box
3627 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3628 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3629 c        go to 195
3630 c        endif
3631 c  196   continue
3632 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3633 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3634 C Condition for being inside the proper box
3635 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3636 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3637 c        go to 196
3638 c        endif
3639           xmedi=mod(xmedi,boxxsize)
3640           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3641           ymedi=mod(ymedi,boxysize)
3642           if (ymedi.lt.0) ymedi=ymedi+boxysize
3643           zmedi=mod(zmedi,boxzsize)
3644           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3645           zmedi2=mod(zmedi,boxzsize)
3646           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3647        if ((zmedi2.gt.bordlipbot)
3648      &.and.(zmedi2.lt.bordliptop)) then
3649 C the energy transfer exist
3650         if (zmedi2.lt.buflipbot) then
3651 C what fraction I am in
3652          fracinbuf=1.0d0-
3653      &        ((zmedi2-bordlipbot)/lipbufthick)
3654 C lipbufthick is thickenes of lipid buffore
3655          sslipi=sscalelip(fracinbuf)
3656          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3657         elseif (zmedi2.gt.bufliptop) then
3658          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3659          sslipi=sscalelip(fracinbuf)
3660          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3661         else
3662          sslipi=1.0d0
3663          ssgradlipi=0.0
3664         endif
3665        else
3666          sslipi=0.0d0
3667          ssgradlipi=0.0
3668        endif
3669         num_conti=num_cont_hb(i)
3670 c        write(iout,*) "JESTEM W PETLI"
3671         call eelecij(i,i+3,ees,evdw1,eel_loc)
3672         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3673      &   call eturn4(i,eello_turn4)
3674         num_cont_hb(i)=num_conti
3675       enddo   ! i
3676 C Loop over all neighbouring boxes
3677 C      do xshift=-1,1
3678 C      do yshift=-1,1
3679 C      do zshift=-1,1
3680 c
3681 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3682 c
3683 CTU KURWA
3684       do i=iatel_s,iatel_e
3685 C        do i=75,75
3686 c        if (i.le.1) cycle
3687         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3688 C changes suggested by Ana to avoid out of bounds
3689 c     & .or.((i+2).gt.nres)
3690 c     & .or.((i-1).le.0)
3691 C end of changes by Ana
3692 c     &  .or. itype(i+2).eq.ntyp1
3693 c     &  .or. itype(i-1).eq.ntyp1
3694      &                ) cycle
3695         dxi=dc(1,i)
3696         dyi=dc(2,i)
3697         dzi=dc(3,i)
3698         dx_normi=dc_norm(1,i)
3699         dy_normi=dc_norm(2,i)
3700         dz_normi=dc_norm(3,i)
3701         xmedi=c(1,i)+0.5d0*dxi
3702         ymedi=c(2,i)+0.5d0*dyi
3703         zmedi=c(3,i)+0.5d0*dzi
3704           xmedi=mod(xmedi,boxxsize)
3705           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3706           ymedi=mod(ymedi,boxysize)
3707           if (ymedi.lt.0) ymedi=ymedi+boxysize
3708           zmedi=mod(zmedi,boxzsize)
3709           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3710        if ((zmedi.gt.bordlipbot)
3711      &.and.(zmedi.lt.bordliptop)) then
3712 C the energy transfer exist
3713         if (zmedi.lt.buflipbot) then
3714 C what fraction I am in
3715          fracinbuf=1.0d0-
3716      &        ((zmedi-bordlipbot)/lipbufthick)
3717 C lipbufthick is thickenes of lipid buffore
3718          sslipi=sscalelip(fracinbuf)
3719          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3720         elseif (zmedi.gt.bufliptop) then
3721          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3722          sslipi=sscalelip(fracinbuf)
3723          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3724         else
3725          sslipi=1.0d0
3726          ssgradlipi=0.0
3727         endif
3728        else
3729          sslipi=0.0d0
3730          ssgradlipi=0.0
3731        endif
3732 C         print *,sslipi,"TU?!"
3733 C          xmedi=xmedi+xshift*boxxsize
3734 C          ymedi=ymedi+yshift*boxysize
3735 C          zmedi=zmedi+zshift*boxzsize
3736
3737 C Return tom into box, boxxsize is size of box in x dimension
3738 c  164   continue
3739 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3740 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3741 C Condition for being inside the proper box
3742 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3743 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3744 c        go to 164
3745 c        endif
3746 c  165   continue
3747 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3748 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3749 C Condition for being inside the proper box
3750 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3751 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3752 c        go to 165
3753 c        endif
3754 c  166   continue
3755 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3756 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3757 cC Condition for being inside the proper box
3758 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3759 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3760 c        go to 166
3761 c        endif
3762
3763 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3764         num_conti=num_cont_hb(i)
3765 C I TU KURWA
3766         do j=ielstart(i),ielend(i)
3767 C          do j=16,17
3768 C          write (iout,*) i,j
3769 C         if (j.le.1) cycle
3770           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3771 C changes suggested by Ana to avoid out of bounds
3772 c     & .or.((j+2).gt.nres)
3773 c     & .or.((j-1).le.0)
3774 C end of changes by Ana
3775 c     & .or.itype(j+2).eq.ntyp1
3776 c     & .or.itype(j-1).eq.ntyp1
3777      &) cycle
3778           call eelecij(i,j,ees,evdw1,eel_loc)
3779         enddo ! j
3780         num_cont_hb(i)=num_conti
3781       enddo   ! i
3782 C     enddo   ! zshift
3783 C      enddo   ! yshift
3784 C      enddo   ! xshift
3785
3786 c      write (iout,*) "Number of loop steps in EELEC:",ind
3787 cd      do i=1,nres
3788 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3789 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3790 cd      enddo
3791 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3792 ccc      eel_loc=eel_loc+eello_turn3
3793 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3794       return
3795       end
3796 C-------------------------------------------------------------------------------
3797       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3798       implicit real*8 (a-h,o-z)
3799       include 'DIMENSIONS'
3800 #ifdef MPI
3801       include "mpif.h"
3802 #endif
3803       include 'COMMON.CONTROL'
3804       include 'COMMON.IOUNITS'
3805       include 'COMMON.GEO'
3806       include 'COMMON.VAR'
3807       include 'COMMON.LOCAL'
3808       include 'COMMON.CHAIN'
3809       include 'COMMON.DERIV'
3810       include 'COMMON.INTERACT'
3811       include 'COMMON.CONTACTS'
3812       include 'COMMON.TORSION'
3813       include 'COMMON.VECTORS'
3814       include 'COMMON.FFIELD'
3815       include 'COMMON.TIME1'
3816       include 'COMMON.SPLITELE'
3817       include 'COMMON.SHIELD'
3818       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3819      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3820       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3821      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3822      &    gmuij2(4),gmuji2(4)
3823       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3824      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3825      &    num_conti,j1,j2
3826 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3827 #ifdef MOMENT
3828       double precision scal_el /1.0d0/
3829 #else
3830       double precision scal_el /0.5d0/
3831 #endif
3832 C 12/13/98
3833 C 13-go grudnia roku pamietnego...
3834       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3835      &                   0.0d0,1.0d0,0.0d0,
3836      &                   0.0d0,0.0d0,1.0d0/
3837        integer xshift,yshift,zshift
3838 c          time00=MPI_Wtime()
3839 cd      write (iout,*) "eelecij",i,j
3840 c          ind=ind+1
3841           iteli=itel(i)
3842           itelj=itel(j)
3843           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3844           aaa=app(iteli,itelj)
3845           bbb=bpp(iteli,itelj)
3846           ael6i=ael6(iteli,itelj)
3847           ael3i=ael3(iteli,itelj)
3848           dxj=dc(1,j)
3849           dyj=dc(2,j)
3850           dzj=dc(3,j)
3851           dx_normj=dc_norm(1,j)
3852           dy_normj=dc_norm(2,j)
3853           dz_normj=dc_norm(3,j)
3854 C          xj=c(1,j)+0.5D0*dxj-xmedi
3855 C          yj=c(2,j)+0.5D0*dyj-ymedi
3856 C          zj=c(3,j)+0.5D0*dzj-zmedi
3857           xj=c(1,j)+0.5D0*dxj
3858           yj=c(2,j)+0.5D0*dyj
3859           zj=c(3,j)+0.5D0*dzj
3860           xj=mod(xj,boxxsize)
3861           if (xj.lt.0) xj=xj+boxxsize
3862           yj=mod(yj,boxysize)
3863           if (yj.lt.0) yj=yj+boxysize
3864           zj=mod(zj,boxzsize)
3865           if (zj.lt.0) zj=zj+boxzsize
3866           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3867        if ((zj.gt.bordlipbot)
3868      &.and.(zj.lt.bordliptop)) then
3869 C the energy transfer exist
3870         if (zj.lt.buflipbot) then
3871 C what fraction I am in
3872          fracinbuf=1.0d0-
3873      &        ((zj-bordlipbot)/lipbufthick)
3874 C lipbufthick is thickenes of lipid buffore
3875          sslipj=sscalelip(fracinbuf)
3876          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3877         elseif (zj.gt.bufliptop) then
3878          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3879          sslipj=sscalelip(fracinbuf)
3880          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3881         else
3882          sslipj=1.0d0
3883          ssgradlipj=0.0
3884         endif
3885        else
3886          sslipj=0.0d0
3887          ssgradlipj=0.0
3888        endif
3889       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3890       xj_safe=xj
3891       yj_safe=yj
3892       zj_safe=zj
3893       isubchap=0
3894       do xshift=-1,1
3895       do yshift=-1,1
3896       do zshift=-1,1
3897           xj=xj_safe+xshift*boxxsize
3898           yj=yj_safe+yshift*boxysize
3899           zj=zj_safe+zshift*boxzsize
3900           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3901           if(dist_temp.lt.dist_init) then
3902             dist_init=dist_temp
3903             xj_temp=xj
3904             yj_temp=yj
3905             zj_temp=zj
3906             isubchap=1
3907           endif
3908        enddo
3909        enddo
3910        enddo
3911        if (isubchap.eq.1) then
3912           xj=xj_temp-xmedi
3913           yj=yj_temp-ymedi
3914           zj=zj_temp-zmedi
3915        else
3916           xj=xj_safe-xmedi
3917           yj=yj_safe-ymedi
3918           zj=zj_safe-zmedi
3919        endif
3920 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3921 c  174   continue
3922 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3923 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3924 C Condition for being inside the proper box
3925 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3926 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3927 c        go to 174
3928 c        endif
3929 c  175   continue
3930 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3931 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3932 C Condition for being inside the proper box
3933 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3934 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3935 c        go to 175
3936 c        endif
3937 c  176   continue
3938 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3939 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3940 C Condition for being inside the proper box
3941 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3942 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3943 c        go to 176
3944 c        endif
3945 C        endif !endPBC condintion
3946 C        xj=xj-xmedi
3947 C        yj=yj-ymedi
3948 C        zj=zj-zmedi
3949           rij=xj*xj+yj*yj+zj*zj
3950
3951             sss=sscale(sqrt(rij))
3952             sssgrad=sscagrad(sqrt(rij))
3953 c            if (sss.gt.0.0d0) then
3954           rrmij=1.0D0/rij
3955           rij=dsqrt(rij)
3956           rmij=1.0D0/rij
3957           r3ij=rrmij*rmij
3958           r6ij=r3ij*r3ij
3959           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3960           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3961           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3962           fac=cosa-3.0D0*cosb*cosg
3963           ev1=aaa*r6ij*r6ij
3964 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3965           if (j.eq.i+2) ev1=scal_el*ev1
3966           ev2=bbb*r6ij
3967           fac3=ael6i*r6ij
3968           fac4=ael3i*r3ij
3969           evdwij=(ev1+ev2)
3970           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3971           el2=fac4*fac
3972 C MARYSIA
3973 C          eesij=(el1+el2)
3974 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3975           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3976           if (shield_mode.gt.0) then
3977 C          fac_shield(i)=0.4
3978 C          fac_shield(j)=0.6
3979           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3980           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3981           eesij=(el1+el2)
3982           ees=ees+eesij
3983 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3984 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3985           else
3986           fac_shield(i)=1.0
3987           fac_shield(j)=1.0
3988           eesij=(el1+el2)
3989           ees=ees+eesij
3990      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3991 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3992           endif
3993           evdw1=evdw1+evdwij*sss
3994      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3995 C          print *,sslipi,sslipj,lipscale**2,
3996 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3997 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3998 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3999 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4000 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4001
4002           if (energy_dec) then
4003               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4004      &'evdw1',i,j,evdwij
4005      &,iteli,itelj,aaa,evdw1
4006               write (iout,*) sss
4007               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4008      &fac_shield(i),fac_shield(j)
4009           endif
4010
4011 C
4012 C Calculate contributions to the Cartesian gradient.
4013 C
4014 #ifdef SPLITELE
4015           facvdw=-6*rrmij*(ev1+evdwij)*sss
4016      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4017           facel=-3*rrmij*(el1+eesij)
4018      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4019           fac1=fac
4020           erij(1)=xj*rmij
4021           erij(2)=yj*rmij
4022           erij(3)=zj*rmij
4023
4024 *
4025 * Radial derivatives. First process both termini of the fragment (i,j)
4026 *
4027           ggg(1)=facel*xj
4028           ggg(2)=facel*yj
4029           ggg(3)=facel*zj
4030           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4031      &  (shield_mode.gt.0)) then
4032 C          print *,i,j
4033           do ilist=1,ishield_list(i)
4034            iresshield=shield_list(ilist,i)
4035            do k=1,3
4036            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4037      &      *2.0
4038            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4039      &              rlocshield
4040      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4041             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4042 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4043 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4044 C             if (iresshield.gt.i) then
4045 C               do ishi=i+1,iresshield-1
4046 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4047 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4048 C
4049 C              enddo
4050 C             else
4051 C               do ishi=iresshield,i
4052 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4053 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4054 C
4055 C               enddo
4056 C              endif
4057            enddo
4058           enddo
4059           do ilist=1,ishield_list(j)
4060            iresshield=shield_list(ilist,j)
4061            do k=1,3
4062            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4063      &     *2.0
4064            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4065      &              rlocshield
4066      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4067            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4068
4069 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4070 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4071 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4072 C             if (iresshield.gt.j) then
4073 C               do ishi=j+1,iresshield-1
4074 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4075 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4076 C
4077 C               enddo
4078 C            else
4079 C               do ishi=iresshield,j
4080 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4081 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4082 C               enddo
4083 C              endif
4084            enddo
4085           enddo
4086
4087           do k=1,3
4088             gshieldc(k,i)=gshieldc(k,i)+
4089      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4090             gshieldc(k,j)=gshieldc(k,j)+
4091      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4092             gshieldc(k,i-1)=gshieldc(k,i-1)+
4093      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4094             gshieldc(k,j-1)=gshieldc(k,j-1)+
4095      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4096
4097            enddo
4098            endif
4099 c          do k=1,3
4100 c            ghalf=0.5D0*ggg(k)
4101 c            gelc(k,i)=gelc(k,i)+ghalf
4102 c            gelc(k,j)=gelc(k,j)+ghalf
4103 c          enddo
4104 c 9/28/08 AL Gradient compotents will be summed only at the end
4105 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4106           do k=1,3
4107             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4108 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4109             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4110 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4111 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4112 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4113 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4114 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4115           enddo
4116 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4117 C Lipidic part for lipscale
4118             gelc_long(3,j)=gelc_long(3,j)+
4119      &     ssgradlipj*eesij/2.0d0*lipscale**2
4120
4121             gelc_long(3,i)=gelc_long(3,i)+
4122      &     ssgradlipi*eesij/2.0d0*lipscale**2
4123
4124 *
4125 * Loop over residues i+1 thru j-1.
4126 *
4127 cgrad          do k=i+1,j-1
4128 cgrad            do l=1,3
4129 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4130 cgrad            enddo
4131 cgrad          enddo
4132           if (sss.gt.0.0) then
4133           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4134      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4135
4136           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4137      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4138
4139           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4140      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4141           else
4142           ggg(1)=0.0
4143           ggg(2)=0.0
4144           ggg(3)=0.0
4145           endif
4146 c          do k=1,3
4147 c            ghalf=0.5D0*ggg(k)
4148 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4149 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4150 c          enddo
4151 c 9/28/08 AL Gradient compotents will be summed only at the end
4152           do k=1,3
4153             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4154             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4155           enddo
4156 C Lipidic part for scaling weight
4157            gvdwpp(3,j)=gvdwpp(3,j)+
4158      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4159            gvdwpp(3,i)=gvdwpp(3,i)+
4160      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4161
4162 *
4163 * Loop over residues i+1 thru j-1.
4164 *
4165 cgrad          do k=i+1,j-1
4166 cgrad            do l=1,3
4167 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4168 cgrad            enddo
4169 cgrad          enddo
4170 #else
4171 C MARYSIA
4172           facvdw=(ev1+evdwij)*sss
4173      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4174           facel=(el1+eesij)
4175           fac1=fac
4176           fac=-3*rrmij*(facvdw+facvdw+facel)
4177           erij(1)=xj*rmij
4178           erij(2)=yj*rmij
4179           erij(3)=zj*rmij
4180 *
4181 * Radial derivatives. First process both termini of the fragment (i,j)
4182 *
4183           ggg(1)=fac*xj
4184 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4185           ggg(2)=fac*yj
4186 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4187           ggg(3)=fac*zj
4188 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4189 c          do k=1,3
4190 c            ghalf=0.5D0*ggg(k)
4191 c            gelc(k,i)=gelc(k,i)+ghalf
4192 c            gelc(k,j)=gelc(k,j)+ghalf
4193 c          enddo
4194 c 9/28/08 AL Gradient compotents will be summed only at the end
4195           do k=1,3
4196             gelc_long(k,j)=gelc(k,j)+ggg(k)
4197             gelc_long(k,i)=gelc(k,i)-ggg(k)
4198           enddo
4199 *
4200 * Loop over residues i+1 thru j-1.
4201 *
4202 cgrad          do k=i+1,j-1
4203 cgrad            do l=1,3
4204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4205 cgrad            enddo
4206 cgrad          enddo
4207 c 9/28/08 AL Gradient compotents will be summed only at the end
4208           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4209      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4210
4211           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4212      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4213
4214           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4215      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4216           do k=1,3
4217             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4218             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4219           enddo
4220            gvdwpp(3,j)=gvdwpp(3,j)+
4221      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4222            gvdwpp(3,i)=gvdwpp(3,i)+
4223      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4224
4225 #endif
4226 *
4227 * Angular part
4228 *
4229           ecosa=2.0D0*fac3*fac1+fac4
4230           fac4=-3.0D0*fac4
4231           fac3=-6.0D0*fac3
4232           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4233           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4234           do k=1,3
4235             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4236             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4237           enddo
4238 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4239 cd   &          (dcosg(k),k=1,3)
4240           do k=1,3
4241             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4242      &      fac_shield(i)**2*fac_shield(j)**2
4243      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4244           enddo
4245 c          do k=1,3
4246 c            ghalf=0.5D0*ggg(k)
4247 c            gelc(k,i)=gelc(k,i)+ghalf
4248 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4249 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4250 c            gelc(k,j)=gelc(k,j)+ghalf
4251 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4252 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4253 c          enddo
4254 cgrad          do k=i+1,j-1
4255 cgrad            do l=1,3
4256 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4257 cgrad            enddo
4258 cgrad          enddo
4259 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4260           do k=1,3
4261             gelc(k,i)=gelc(k,i)
4262      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4263      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4264      &           *fac_shield(i)**2*fac_shield(j)**2
4265      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4266             gelc(k,j)=gelc(k,j)
4267      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4268      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4269      &           *fac_shield(i)**2*fac_shield(j)**2
4270      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4271             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4272             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4273           enddo
4274 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4275
4276 C MARYSIA
4277 c          endif !sscale
4278           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4279      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4280      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4281 C
4282 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4283 C   energy of a peptide unit is assumed in the form of a second-order
4284 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4285 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4286 C   are computed for EVERY pair of non-contiguous peptide groups.
4287 C
4288
4289           if (j.lt.nres-1) then
4290             j1=j+1
4291             j2=j-1
4292           else
4293             j1=j-1
4294             j2=j-2
4295           endif
4296           kkk=0
4297           lll=0
4298           do k=1,2
4299             do l=1,2
4300               kkk=kkk+1
4301               muij(kkk)=mu(k,i)*mu(l,j)
4302 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4303 #ifdef NEWCORR
4304              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4305 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4306              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4307              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4308 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4309              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4310 #endif
4311             enddo
4312           enddo
4313 cd         write (iout,*) 'EELEC: i',i,' j',j
4314 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4315 cd          write(iout,*) 'muij',muij
4316           ury=scalar(uy(1,i),erij)
4317           urz=scalar(uz(1,i),erij)
4318           vry=scalar(uy(1,j),erij)
4319           vrz=scalar(uz(1,j),erij)
4320           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4321           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4322           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4323           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4324           fac=dsqrt(-ael6i)*r3ij
4325           a22=a22*fac
4326           a23=a23*fac
4327           a32=a32*fac
4328           a33=a33*fac
4329 cd          write (iout,'(4i5,4f10.5)')
4330 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4331 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4332 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4333 cd     &      uy(:,j),uz(:,j)
4334 cd          write (iout,'(4f10.5)')
4335 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4336 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4337 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4338 cd           write (iout,'(9f10.5/)')
4339 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4340 C Derivatives of the elements of A in virtual-bond vectors
4341           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4342           do k=1,3
4343             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4344             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4345             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4346             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4347             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4348             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4349             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4350             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4351             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4352             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4353             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4354             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4355           enddo
4356 C Compute radial contributions to the gradient
4357           facr=-3.0d0*rrmij
4358           a22der=a22*facr
4359           a23der=a23*facr
4360           a32der=a32*facr
4361           a33der=a33*facr
4362           agg(1,1)=a22der*xj
4363           agg(2,1)=a22der*yj
4364           agg(3,1)=a22der*zj
4365           agg(1,2)=a23der*xj
4366           agg(2,2)=a23der*yj
4367           agg(3,2)=a23der*zj
4368           agg(1,3)=a32der*xj
4369           agg(2,3)=a32der*yj
4370           agg(3,3)=a32der*zj
4371           agg(1,4)=a33der*xj
4372           agg(2,4)=a33der*yj
4373           agg(3,4)=a33der*zj
4374 C Add the contributions coming from er
4375           fac3=-3.0d0*fac
4376           do k=1,3
4377             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4378             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4379             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4380             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4381           enddo
4382           do k=1,3
4383 C Derivatives in DC(i)
4384 cgrad            ghalf1=0.5d0*agg(k,1)
4385 cgrad            ghalf2=0.5d0*agg(k,2)
4386 cgrad            ghalf3=0.5d0*agg(k,3)
4387 cgrad            ghalf4=0.5d0*agg(k,4)
4388             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4389      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4390             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4391      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4392             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4393      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4394             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4395      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4396 C Derivatives in DC(i+1)
4397             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4398      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4399             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4400      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4401             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4402      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4403             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4404      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4405 C Derivatives in DC(j)
4406             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4407      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4408             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4409      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4410             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4411      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4412             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4413      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4414 C Derivatives in DC(j+1) or DC(nres-1)
4415             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4416      &      -3.0d0*vryg(k,3)*ury)
4417             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4418      &      -3.0d0*vrzg(k,3)*ury)
4419             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4420      &      -3.0d0*vryg(k,3)*urz)
4421             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4422      &      -3.0d0*vrzg(k,3)*urz)
4423 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4424 cgrad              do l=1,4
4425 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4426 cgrad              enddo
4427 cgrad            endif
4428           enddo
4429           acipa(1,1)=a22
4430           acipa(1,2)=a23
4431           acipa(2,1)=a32
4432           acipa(2,2)=a33
4433           a22=-a22
4434           a23=-a23
4435           do l=1,2
4436             do k=1,3
4437               agg(k,l)=-agg(k,l)
4438               aggi(k,l)=-aggi(k,l)
4439               aggi1(k,l)=-aggi1(k,l)
4440               aggj(k,l)=-aggj(k,l)
4441               aggj1(k,l)=-aggj1(k,l)
4442             enddo
4443           enddo
4444           if (j.lt.nres-1) then
4445             a22=-a22
4446             a32=-a32
4447             do l=1,3,2
4448               do k=1,3
4449                 agg(k,l)=-agg(k,l)
4450                 aggi(k,l)=-aggi(k,l)
4451                 aggi1(k,l)=-aggi1(k,l)
4452                 aggj(k,l)=-aggj(k,l)
4453                 aggj1(k,l)=-aggj1(k,l)
4454               enddo
4455             enddo
4456           else
4457             a22=-a22
4458             a23=-a23
4459             a32=-a32
4460             a33=-a33
4461             do l=1,4
4462               do k=1,3
4463                 agg(k,l)=-agg(k,l)
4464                 aggi(k,l)=-aggi(k,l)
4465                 aggi1(k,l)=-aggi1(k,l)
4466                 aggj(k,l)=-aggj(k,l)
4467                 aggj1(k,l)=-aggj1(k,l)
4468               enddo
4469             enddo
4470           endif
4471           ENDIF ! WCORR
4472           IF (wel_loc.gt.0.0d0) THEN
4473 C Contribution to the local-electrostatic energy coming from the i-j pair
4474           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4475      &     +a33*muij(4)
4476           if (shield_mode.eq.0) then
4477            fac_shield(i)=1.0
4478            fac_shield(j)=1.0
4479 C          else
4480 C           fac_shield(i)=0.4
4481 C           fac_shield(j)=0.6
4482           endif
4483           eel_loc_ij=eel_loc_ij
4484      &    *fac_shield(i)*fac_shield(j)
4485      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4486
4487 C Now derivative over eel_loc
4488           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4489      &  (shield_mode.gt.0)) then
4490 C          print *,i,j
4491
4492           do ilist=1,ishield_list(i)
4493            iresshield=shield_list(ilist,i)
4494            do k=1,3
4495            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4496      &                                          /fac_shield(i)
4497 C     &      *2.0
4498            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4499      &              rlocshield
4500      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4501             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4502      &      +rlocshield
4503            enddo
4504           enddo
4505           do ilist=1,ishield_list(j)
4506            iresshield=shield_list(ilist,j)
4507            do k=1,3
4508            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4509      &                                       /fac_shield(j)
4510 C     &     *2.0
4511            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4512      &              rlocshield
4513      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4514            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4515      &             +rlocshield
4516
4517            enddo
4518           enddo
4519
4520           do k=1,3
4521             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4522      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4523             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4524      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4525             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4526      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4527             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4528      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4529            enddo
4530            endif
4531
4532
4533 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4534 c     &                     ' eel_loc_ij',eel_loc_ij
4535 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4536 C Calculate patrial derivative for theta angle
4537 #ifdef NEWCORR
4538          geel_loc_ij=(a22*gmuij1(1)
4539      &     +a23*gmuij1(2)
4540      &     +a32*gmuij1(3)
4541      &     +a33*gmuij1(4))
4542      &    *fac_shield(i)*fac_shield(j)
4543      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4544
4545 c         write(iout,*) "derivative over thatai"
4546 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4547 c     &   a33*gmuij1(4)
4548          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4549      &      geel_loc_ij*wel_loc
4550 c         write(iout,*) "derivative over thatai-1"
4551 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4552 c     &   a33*gmuij2(4)
4553          geel_loc_ij=
4554      &     a22*gmuij2(1)
4555      &     +a23*gmuij2(2)
4556      &     +a32*gmuij2(3)
4557      &     +a33*gmuij2(4)
4558          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4559      &      geel_loc_ij*wel_loc
4560      &    *fac_shield(i)*fac_shield(j)
4561      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4562
4563
4564 c  Derivative over j residue
4565          geel_loc_ji=a22*gmuji1(1)
4566      &     +a23*gmuji1(2)
4567      &     +a32*gmuji1(3)
4568      &     +a33*gmuji1(4)
4569 c         write(iout,*) "derivative over thataj"
4570 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4571 c     &   a33*gmuji1(4)
4572
4573         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4574      &      geel_loc_ji*wel_loc
4575      &    *fac_shield(i)*fac_shield(j)
4576      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4577
4578          geel_loc_ji=
4579      &     +a22*gmuji2(1)
4580      &     +a23*gmuji2(2)
4581      &     +a32*gmuji2(3)
4582      &     +a33*gmuji2(4)
4583 c         write(iout,*) "derivative over thataj-1"
4584 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4585 c     &   a33*gmuji2(4)
4586          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4587      &      geel_loc_ji*wel_loc
4588      &    *fac_shield(i)*fac_shield(j)
4589      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4590
4591 #endif
4592 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4593
4594           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4595      &            'eelloc',i,j,eel_loc_ij
4596 c           if (eel_loc_ij.ne.0)
4597 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4598 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4599
4600           eel_loc=eel_loc+eel_loc_ij
4601 C Partial derivatives in virtual-bond dihedral angles gamma
4602           if (i.gt.1)
4603      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4604      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4605      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4606      &    *fac_shield(i)*fac_shield(j)
4607      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4608
4609           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4610      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4611      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4612      &    *fac_shield(i)*fac_shield(j)
4613      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614
4615 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4616           do l=1,3
4617             ggg(l)=(agg(l,1)*muij(1)+
4618      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4619      &    *fac_shield(i)*fac_shield(j)
4620      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4621
4622             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4623             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4624 cgrad            ghalf=0.5d0*ggg(l)
4625 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4626 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4627           enddo
4628             gel_loc_long(3,j)=gel_loc_long(3,j)+
4629      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4630      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4631
4632             gel_loc_long(3,i)=gel_loc_long(3,i)+
4633      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4634      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4635
4636 cgrad          do k=i+1,j2
4637 cgrad            do l=1,3
4638 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4639 cgrad            enddo
4640 cgrad          enddo
4641 C Remaining derivatives of eello
4642           do l=1,3
4643             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4644      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4645      &    *fac_shield(i)*fac_shield(j)
4646      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4647
4648             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4649      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4650      &    *fac_shield(i)*fac_shield(j)
4651      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4652
4653             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4654      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4655      &    *fac_shield(i)*fac_shield(j)
4656      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4657
4658             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4659      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4660      &    *fac_shield(i)*fac_shield(j)
4661      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4662
4663           enddo
4664           ENDIF
4665 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4666 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4667           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4668      &       .and. num_conti.le.maxconts) then
4669 c            write (iout,*) i,j," entered corr"
4670 C
4671 C Calculate the contact function. The ith column of the array JCONT will
4672 C contain the numbers of atoms that make contacts with the atom I (of numbers
4673 C greater than I). The arrays FACONT and GACONT will contain the values of
4674 C the contact function and its derivative.
4675 c           r0ij=1.02D0*rpp(iteli,itelj)
4676 c           r0ij=1.11D0*rpp(iteli,itelj)
4677             r0ij=2.20D0*rpp(iteli,itelj)
4678 c           r0ij=1.55D0*rpp(iteli,itelj)
4679             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4680             if (fcont.gt.0.0D0) then
4681               num_conti=num_conti+1
4682               if (num_conti.gt.maxconts) then
4683                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4684      &                         ' will skip next contacts for this conf.'
4685               else
4686                 jcont_hb(num_conti,i)=j
4687 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4688 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4689                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4690      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4691 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4692 C  terms.
4693                 d_cont(num_conti,i)=rij
4694 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4695 C     --- Electrostatic-interaction matrix ---
4696                 a_chuj(1,1,num_conti,i)=a22
4697                 a_chuj(1,2,num_conti,i)=a23
4698                 a_chuj(2,1,num_conti,i)=a32
4699                 a_chuj(2,2,num_conti,i)=a33
4700 C     --- Gradient of rij
4701                 do kkk=1,3
4702                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4703                 enddo
4704                 kkll=0
4705                 do k=1,2
4706                   do l=1,2
4707                     kkll=kkll+1
4708                     do m=1,3
4709                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4710                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4711                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4712                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4713                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4714                     enddo
4715                   enddo
4716                 enddo
4717                 ENDIF
4718                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4719 C Calculate contact energies
4720                 cosa4=4.0D0*cosa
4721                 wij=cosa-3.0D0*cosb*cosg
4722                 cosbg1=cosb+cosg
4723                 cosbg2=cosb-cosg
4724 c               fac3=dsqrt(-ael6i)/r0ij**3
4725                 fac3=dsqrt(-ael6i)*r3ij
4726 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4727                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4728                 if (ees0tmp.gt.0) then
4729                   ees0pij=dsqrt(ees0tmp)
4730                 else
4731                   ees0pij=0
4732                 endif
4733 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4734                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4735                 if (ees0tmp.gt.0) then
4736                   ees0mij=dsqrt(ees0tmp)
4737                 else
4738                   ees0mij=0
4739                 endif
4740 c               ees0mij=0.0D0
4741                 if (shield_mode.eq.0) then
4742                 fac_shield(i)=1.0d0
4743                 fac_shield(j)=1.0d0
4744                 else
4745                 ees0plist(num_conti,i)=j
4746 C                fac_shield(i)=0.4d0
4747 C                fac_shield(j)=0.6d0
4748                 endif
4749                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4750      &          *fac_shield(i)*fac_shield(j)
4751                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4752      &          *fac_shield(i)*fac_shield(j)
4753 C Diagnostics. Comment out or remove after debugging!
4754 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4755 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4756 c               ees0m(num_conti,i)=0.0D0
4757 C End diagnostics.
4758 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4759 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4760 C Angular derivatives of the contact function
4761                 ees0pij1=fac3/ees0pij
4762                 ees0mij1=fac3/ees0mij
4763                 fac3p=-3.0D0*fac3*rrmij
4764                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4765                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4766 c               ees0mij1=0.0D0
4767                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4768                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4769                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4770                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4771                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4772                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4773                 ecosap=ecosa1+ecosa2
4774                 ecosbp=ecosb1+ecosb2
4775                 ecosgp=ecosg1+ecosg2
4776                 ecosam=ecosa1-ecosa2
4777                 ecosbm=ecosb1-ecosb2
4778                 ecosgm=ecosg1-ecosg2
4779 C Diagnostics
4780 c               ecosap=ecosa1
4781 c               ecosbp=ecosb1
4782 c               ecosgp=ecosg1
4783 c               ecosam=0.0D0
4784 c               ecosbm=0.0D0
4785 c               ecosgm=0.0D0
4786 C End diagnostics
4787                 facont_hb(num_conti,i)=fcont
4788                 fprimcont=fprimcont/rij
4789 cd              facont_hb(num_conti,i)=1.0D0
4790 C Following line is for diagnostics.
4791 cd              fprimcont=0.0D0
4792                 do k=1,3
4793                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4794                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4795                 enddo
4796                 do k=1,3
4797                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4798                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4799                 enddo
4800                 gggp(1)=gggp(1)+ees0pijp*xj
4801                 gggp(2)=gggp(2)+ees0pijp*yj
4802                 gggp(3)=gggp(3)+ees0pijp*zj
4803                 gggm(1)=gggm(1)+ees0mijp*xj
4804                 gggm(2)=gggm(2)+ees0mijp*yj
4805                 gggm(3)=gggm(3)+ees0mijp*zj
4806 C Derivatives due to the contact function
4807                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4808                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4809                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4810                 do k=1,3
4811 c
4812 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4813 c          following the change of gradient-summation algorithm.
4814 c
4815 cgrad                  ghalfp=0.5D0*gggp(k)
4816 cgrad                  ghalfm=0.5D0*gggm(k)
4817                   gacontp_hb1(k,num_conti,i)=!ghalfp
4818      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4819      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4820      &          *fac_shield(i)*fac_shield(j)
4821
4822                   gacontp_hb2(k,num_conti,i)=!ghalfp
4823      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4824      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4825      &          *fac_shield(i)*fac_shield(j)
4826
4827                   gacontp_hb3(k,num_conti,i)=gggp(k)
4828      &          *fac_shield(i)*fac_shield(j)
4829
4830                   gacontm_hb1(k,num_conti,i)=!ghalfm
4831      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4832      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4833      &          *fac_shield(i)*fac_shield(j)
4834
4835                   gacontm_hb2(k,num_conti,i)=!ghalfm
4836      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4837      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4838      &          *fac_shield(i)*fac_shield(j)
4839
4840                   gacontm_hb3(k,num_conti,i)=gggm(k)
4841      &          *fac_shield(i)*fac_shield(j)
4842
4843                 enddo
4844 C Diagnostics. Comment out or remove after debugging!
4845 cdiag           do k=1,3
4846 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4847 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4848 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4849 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4850 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4851 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4852 cdiag           enddo
4853               ENDIF ! wcorr
4854               endif  ! num_conti.le.maxconts
4855             endif  ! fcont.gt.0
4856           endif    ! j.gt.i+1
4857           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4858             do k=1,4
4859               do l=1,3
4860                 ghalf=0.5d0*agg(l,k)
4861                 aggi(l,k)=aggi(l,k)+ghalf
4862                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4863                 aggj(l,k)=aggj(l,k)+ghalf
4864               enddo
4865             enddo
4866             if (j.eq.nres-1 .and. i.lt.j-2) then
4867               do k=1,4
4868                 do l=1,3
4869                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4870                 enddo
4871               enddo
4872             endif
4873           endif
4874 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4875       return
4876       end
4877 C-----------------------------------------------------------------------------
4878       subroutine eturn3(i,eello_turn3)
4879 C Third- and fourth-order contributions from turns
4880       implicit real*8 (a-h,o-z)
4881       include 'DIMENSIONS'
4882       include 'COMMON.IOUNITS'
4883       include 'COMMON.GEO'
4884       include 'COMMON.VAR'
4885       include 'COMMON.LOCAL'
4886       include 'COMMON.CHAIN'
4887       include 'COMMON.DERIV'
4888       include 'COMMON.INTERACT'
4889       include 'COMMON.CONTACTS'
4890       include 'COMMON.TORSION'
4891       include 'COMMON.VECTORS'
4892       include 'COMMON.FFIELD'
4893       include 'COMMON.CONTROL'
4894       include 'COMMON.SHIELD'
4895       dimension ggg(3)
4896       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4897      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4898      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4899      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4900      &  auxgmat2(2,2),auxgmatt2(2,2)
4901       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4902      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4903       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4904      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4905      &    num_conti,j1,j2
4906       j=i+2
4907 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4908 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4909           zj=(c(3,j)+c(3,j+1))/2.0d0
4910 C          xj=mod(xj,boxxsize)
4911 C          if (xj.lt.0) xj=xj+boxxsize
4912 C          yj=mod(yj,boxysize)
4913 C          if (yj.lt.0) yj=yj+boxysize
4914           zj=mod(zj,boxzsize)
4915           if (zj.lt.0) zj=zj+boxzsize
4916           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4917        if ((zj.gt.bordlipbot)
4918      &.and.(zj.lt.bordliptop)) then
4919 C the energy transfer exist
4920         if (zj.lt.buflipbot) then
4921 C what fraction I am in
4922          fracinbuf=1.0d0-
4923      &        ((zj-bordlipbot)/lipbufthick)
4924 C lipbufthick is thickenes of lipid buffore
4925          sslipj=sscalelip(fracinbuf)
4926          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4927         elseif (zj.gt.bufliptop) then
4928          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4929          sslipj=sscalelip(fracinbuf)
4930          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4931         else
4932          sslipj=1.0d0
4933          ssgradlipj=0.0
4934         endif
4935        else
4936          sslipj=0.0d0
4937          ssgradlipj=0.0
4938        endif
4939 C      sslipj=0.0
4940 C      ssgradlipj=0.0d0
4941
4942 C      write (iout,*) "eturn3",i,j,j1,j2
4943       a_temp(1,1)=a22
4944       a_temp(1,2)=a23
4945       a_temp(2,1)=a32
4946       a_temp(2,2)=a33
4947 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4948 C
4949 C               Third-order contributions
4950 C
4951 C                 (i+2)o----(i+3)
4952 C                      | |
4953 C                      | |
4954 C                 (i+1)o----i
4955 C
4956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4957 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4958         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4959 c auxalary matices for theta gradient
4960 c auxalary matrix for i+1 and constant i+2
4961         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4962 c auxalary matrix for i+2 and constant i+1
4963         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4964         call transpose2(auxmat(1,1),auxmat1(1,1))
4965         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4966         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4967         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4968         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4969         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4970         if (shield_mode.eq.0) then
4971         fac_shield(i)=1.0d0
4972         fac_shield(j)=1.0d0
4973 C        else
4974 C        fac_shield(i)=0.4
4975 C        fac_shield(j)=0.6
4976         endif
4977 C         if (j.eq.78)
4978 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
4979         eello_turn3=eello_turn3+
4980 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4981      &0.5d0*(pizda(1,1)+pizda(2,2))
4982      &  *fac_shield(i)*fac_shield(j)
4983      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4984         eello_t3=
4985      &0.5d0*(pizda(1,1)+pizda(2,2))
4986      &  *fac_shield(i)*fac_shield(j)
4987 #ifdef NEWCORR
4988 C Derivatives in theta
4989         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4990      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4991      &   *fac_shield(i)*fac_shield(j)
4992      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4993
4994         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4995      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4996      &   *fac_shield(i)*fac_shield(j)
4997      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4998
4999 #endif
5000
5001 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5002 C Derivatives in shield mode
5003           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5004      &  (shield_mode.gt.0)) then
5005 C          print *,i,j
5006
5007           do ilist=1,ishield_list(i)
5008            iresshield=shield_list(ilist,i)
5009            do k=1,3
5010            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5011 C     &      *2.0
5012            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5013      &              rlocshield
5014      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5015             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5016      &      +rlocshield
5017            enddo
5018           enddo
5019           do ilist=1,ishield_list(j)
5020            iresshield=shield_list(ilist,j)
5021            do k=1,3
5022            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5023 C     &     *2.0
5024            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5025      &              rlocshield
5026      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5027            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5028      &             +rlocshield
5029
5030            enddo
5031           enddo
5032
5033           do k=1,3
5034             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5035      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5036             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5037      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5038             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5039      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5040             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5041      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5042            enddo
5043            endif
5044
5045 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5046 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5047 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5048 cd     &    ' eello_turn3_num',4*eello_turn3_num
5049 C Derivatives in gamma(i)
5050         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5051         call transpose2(auxmat2(1,1),auxmat3(1,1))
5052         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5053         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5054      &   *fac_shield(i)*fac_shield(j)
5055      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5056
5057 C Derivatives in gamma(i+1)
5058         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5059         call transpose2(auxmat2(1,1),auxmat3(1,1))
5060         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5061         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5062      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5063      &   *fac_shield(i)*fac_shield(j)
5064      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5065
5066 C Cartesian derivatives
5067         do l=1,3
5068 c            ghalf1=0.5d0*agg(l,1)
5069 c            ghalf2=0.5d0*agg(l,2)
5070 c            ghalf3=0.5d0*agg(l,3)
5071 c            ghalf4=0.5d0*agg(l,4)
5072           a_temp(1,1)=aggi(l,1)!+ghalf1
5073           a_temp(1,2)=aggi(l,2)!+ghalf2
5074           a_temp(2,1)=aggi(l,3)!+ghalf3
5075           a_temp(2,2)=aggi(l,4)!+ghalf4
5076           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5077           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5078      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5079      &   *fac_shield(i)*fac_shield(j)
5080      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5081
5082           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5083           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5084           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5085           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5086           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5087           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5088      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5089      &   *fac_shield(i)*fac_shield(j)
5090      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5091           a_temp(1,1)=aggj(l,1)!+ghalf1
5092           a_temp(1,2)=aggj(l,2)!+ghalf2
5093           a_temp(2,1)=aggj(l,3)!+ghalf3
5094           a_temp(2,2)=aggj(l,4)!+ghalf4
5095           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5096           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5097      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5098      &   *fac_shield(i)*fac_shield(j)
5099      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5100
5101           a_temp(1,1)=aggj1(l,1)
5102           a_temp(1,2)=aggj1(l,2)
5103           a_temp(2,1)=aggj1(l,3)
5104           a_temp(2,2)=aggj1(l,4)
5105           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5106           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5107      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5108      &   *fac_shield(i)*fac_shield(j)
5109      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5110         enddo
5111          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5112      &     ssgradlipi*eello_t3/4.0d0*lipscale
5113          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5114      &     ssgradlipj*eello_t3/4.0d0*lipscale
5115          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5116      &     ssgradlipi*eello_t3/4.0d0*lipscale
5117          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5118      &     ssgradlipj*eello_t3/4.0d0*lipscale
5119
5120 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5121       return
5122       end
5123 C-------------------------------------------------------------------------------
5124       subroutine eturn4(i,eello_turn4)
5125 C Third- and fourth-order contributions from turns
5126       implicit real*8 (a-h,o-z)
5127       include 'DIMENSIONS'
5128       include 'COMMON.IOUNITS'
5129       include 'COMMON.GEO'
5130       include 'COMMON.VAR'
5131       include 'COMMON.LOCAL'
5132       include 'COMMON.CHAIN'
5133       include 'COMMON.DERIV'
5134       include 'COMMON.INTERACT'
5135       include 'COMMON.CONTACTS'
5136       include 'COMMON.TORSION'
5137       include 'COMMON.VECTORS'
5138       include 'COMMON.FFIELD'
5139       include 'COMMON.CONTROL'
5140       include 'COMMON.SHIELD'
5141       dimension ggg(3)
5142       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5143      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5144      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5145      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5146      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5147      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5148      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5149       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5150      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5151       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5152      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5153      &    num_conti,j1,j2
5154       j=i+3
5155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5156 C
5157 C               Fourth-order contributions
5158 C
5159 C                 (i+3)o----(i+4)
5160 C                     /  |
5161 C               (i+2)o   |
5162 C                     \  |
5163 C                 (i+1)o----i
5164 C
5165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5166 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5167 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5168 c        write(iout,*)"WCHODZE W PROGRAM"
5169           zj=(c(3,j)+c(3,j+1))/2.0d0
5170 C          xj=mod(xj,boxxsize)
5171 C          if (xj.lt.0) xj=xj+boxxsize
5172 C          yj=mod(yj,boxysize)
5173 C          if (yj.lt.0) yj=yj+boxysize
5174           zj=mod(zj,boxzsize)
5175           if (zj.lt.0) zj=zj+boxzsize
5176 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5177        if ((zj.gt.bordlipbot)
5178      &.and.(zj.lt.bordliptop)) then
5179 C the energy transfer exist
5180         if (zj.lt.buflipbot) then
5181 C what fraction I am in
5182          fracinbuf=1.0d0-
5183      &        ((zj-bordlipbot)/lipbufthick)
5184 C lipbufthick is thickenes of lipid buffore
5185          sslipj=sscalelip(fracinbuf)
5186          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5187         elseif (zj.gt.bufliptop) then
5188          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5189          sslipj=sscalelip(fracinbuf)
5190          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5191         else
5192          sslipj=1.0d0
5193          ssgradlipj=0.0
5194         endif
5195        else
5196          sslipj=0.0d0
5197          ssgradlipj=0.0
5198        endif
5199
5200         a_temp(1,1)=a22
5201         a_temp(1,2)=a23
5202         a_temp(2,1)=a32
5203         a_temp(2,2)=a33
5204         iti1=itype2loc(itype(i+1))
5205         iti2=itype2loc(itype(i+2))
5206         iti3=itype2loc(itype(i+3))
5207 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5208         call transpose2(EUg(1,1,i+1),e1t(1,1))
5209         call transpose2(Eug(1,1,i+2),e2t(1,1))
5210         call transpose2(Eug(1,1,i+3),e3t(1,1))
5211 C Ematrix derivative in theta
5212         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5213         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5214         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5215         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5216 c       eta1 in derivative theta
5217         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5218         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5219 c       auxgvec is derivative of Ub2 so i+3 theta
5220         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5221 c       auxalary matrix of E i+1
5222         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5223 c        s1=0.0
5224 c        gs1=0.0
5225         s1=scalar2(b1(1,i+2),auxvec(1))
5226 c derivative of theta i+2 with constant i+3
5227         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5228 c derivative of theta i+2 with constant i+2
5229         gs32=scalar2(b1(1,i+2),auxgvec(1))
5230 c derivative of E matix in theta of i+1
5231         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5232
5233         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5234 c       ea31 in derivative theta
5235         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5236         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237 c auxilary matrix auxgvec of Ub2 with constant E matirx
5238         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5239 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5240         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5241
5242 c        s2=0.0
5243 c        gs2=0.0
5244         s2=scalar2(b1(1,i+1),auxvec(1))
5245 c derivative of theta i+1 with constant i+3
5246         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5247 c derivative of theta i+2 with constant i+1
5248         gs21=scalar2(b1(1,i+1),auxgvec(1))
5249 c derivative of theta i+3 with constant i+1
5250         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5251 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5252 c     &  gtb1(1,i+1)
5253         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5254 c two derivatives over diffetent matrices
5255 c gtae3e2 is derivative over i+3
5256         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5257 c ae3gte2 is derivative over i+2
5258         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5259         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260 c three possible derivative over theta E matices
5261 c i+1
5262         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5263 c i+2
5264         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5265 c i+3
5266         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5267         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5268
5269         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5270         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5271         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5272         if (shield_mode.eq.0) then
5273         fac_shield(i)=1.0
5274         fac_shield(j)=1.0
5275 C        else
5276 C        fac_shield(i)=0.6
5277 C        fac_shield(j)=0.4
5278         endif
5279         eello_turn4=eello_turn4-(s1+s2+s3)
5280      &  *fac_shield(i)*fac_shield(j)
5281      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5282
5283         eello_t4=-(s1+s2+s3)
5284      &  *fac_shield(i)*fac_shield(j)
5285 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5286         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5287      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5288 C Now derivative over shield:
5289           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5290      &  (shield_mode.gt.0)) then
5291 C          print *,i,j
5292
5293           do ilist=1,ishield_list(i)
5294            iresshield=shield_list(ilist,i)
5295            do k=1,3
5296            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5297 C     &      *2.0
5298            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5299      &              rlocshield
5300      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5301             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5302      &      +rlocshield
5303            enddo
5304           enddo
5305           do ilist=1,ishield_list(j)
5306            iresshield=shield_list(ilist,j)
5307            do k=1,3
5308            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5309 C     &     *2.0
5310            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5311      &              rlocshield
5312      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5313            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5314      &             +rlocshield
5315
5316            enddo
5317           enddo
5318
5319           do k=1,3
5320             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5321      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5322             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5323      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5324             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5325      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5326             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5327      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5328            enddo
5329            endif
5330
5331
5332
5333
5334
5335
5336 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 cd     &    ' eello_turn4_num',8*eello_turn4_num
5338 #ifdef NEWCORR
5339         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5340      &                  -(gs13+gsE13+gsEE1)*wturn4
5341      &  *fac_shield(i)*fac_shield(j)
5342      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5343
5344         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5345      &                    -(gs23+gs21+gsEE2)*wturn4
5346      &  *fac_shield(i)*fac_shield(j)
5347      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5348
5349         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5350      &                    -(gs32+gsE31+gsEE3)*wturn4
5351      &  *fac_shield(i)*fac_shield(j)
5352      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5353
5354 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5355 c     &   gs2
5356 #endif
5357         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5358      &      'eturn4',i,j,-(s1+s2+s3)
5359 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5360 c     &    ' eello_turn4_num',8*eello_turn4_num
5361 C Derivatives in gamma(i)
5362         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5363         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5364         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5365         s1=scalar2(b1(1,i+2),auxvec(1))
5366         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5367         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5368         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5369      &  *fac_shield(i)*fac_shield(j)
5370      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5371
5372 C Derivatives in gamma(i+1)
5373         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5374         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5375         s2=scalar2(b1(1,i+1),auxvec(1))
5376         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5377         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5378         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5379         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5380      &  *fac_shield(i)*fac_shield(j)
5381      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5382
5383 C Derivatives in gamma(i+2)
5384         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5385         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5386         s1=scalar2(b1(1,i+2),auxvec(1))
5387         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5388         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5389         s2=scalar2(b1(1,i+1),auxvec(1))
5390         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5391         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5392         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5393         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5394      &  *fac_shield(i)*fac_shield(j)
5395      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5396
5397 C Cartesian derivatives
5398 C Derivatives of this turn contributions in DC(i+2)
5399         if (j.lt.nres-1) then
5400           do l=1,3
5401             a_temp(1,1)=agg(l,1)
5402             a_temp(1,2)=agg(l,2)
5403             a_temp(2,1)=agg(l,3)
5404             a_temp(2,2)=agg(l,4)
5405             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5406             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5407             s1=scalar2(b1(1,i+2),auxvec(1))
5408             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5409             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5410             s2=scalar2(b1(1,i+1),auxvec(1))
5411             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5412             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5413             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5414             ggg(l)=-(s1+s2+s3)
5415             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5416      &  *fac_shield(i)*fac_shield(j)
5417      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5418
5419           enddo
5420         endif
5421 C Remaining derivatives of this turn contribution
5422         do l=1,3
5423           a_temp(1,1)=aggi(l,1)
5424           a_temp(1,2)=aggi(l,2)
5425           a_temp(2,1)=aggi(l,3)
5426           a_temp(2,2)=aggi(l,4)
5427           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5428           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5429           s1=scalar2(b1(1,i+2),auxvec(1))
5430           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5431           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5432           s2=scalar2(b1(1,i+1),auxvec(1))
5433           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5434           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5435           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5436           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5437      &  *fac_shield(i)*fac_shield(j)
5438      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5439
5440           a_temp(1,1)=aggi1(l,1)
5441           a_temp(1,2)=aggi1(l,2)
5442           a_temp(2,1)=aggi1(l,3)
5443           a_temp(2,2)=aggi1(l,4)
5444           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5445           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5446           s1=scalar2(b1(1,i+2),auxvec(1))
5447           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5448           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5449           s2=scalar2(b1(1,i+1),auxvec(1))
5450           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5451           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5452           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5453           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5454      &  *fac_shield(i)*fac_shield(j)
5455      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5456
5457           a_temp(1,1)=aggj(l,1)
5458           a_temp(1,2)=aggj(l,2)
5459           a_temp(2,1)=aggj(l,3)
5460           a_temp(2,2)=aggj(l,4)
5461           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5462           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5463           s1=scalar2(b1(1,i+2),auxvec(1))
5464           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5465           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5466           s2=scalar2(b1(1,i+1),auxvec(1))
5467           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5468           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5469           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5470           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5471      &  *fac_shield(i)*fac_shield(j)
5472      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5473
5474           a_temp(1,1)=aggj1(l,1)
5475           a_temp(1,2)=aggj1(l,2)
5476           a_temp(2,1)=aggj1(l,3)
5477           a_temp(2,2)=aggj1(l,4)
5478           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5479           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5480           s1=scalar2(b1(1,i+2),auxvec(1))
5481           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5482           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5483           s2=scalar2(b1(1,i+1),auxvec(1))
5484           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5485           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5486           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5487 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5488           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5489      &  *fac_shield(i)*fac_shield(j)
5490      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5491         enddo
5492          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5493      &     ssgradlipi*eello_t4/4.0d0*lipscale
5494          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5495      &     ssgradlipj*eello_t4/4.0d0*lipscale
5496          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5497      &     ssgradlipi*eello_t4/4.0d0*lipscale
5498          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5499      &     ssgradlipj*eello_t4/4.0d0*lipscale
5500       return
5501       end
5502 C-----------------------------------------------------------------------------
5503       subroutine vecpr(u,v,w)
5504       implicit real*8(a-h,o-z)
5505       dimension u(3),v(3),w(3)
5506       w(1)=u(2)*v(3)-u(3)*v(2)
5507       w(2)=-u(1)*v(3)+u(3)*v(1)
5508       w(3)=u(1)*v(2)-u(2)*v(1)
5509       return
5510       end
5511 C-----------------------------------------------------------------------------
5512       subroutine unormderiv(u,ugrad,unorm,ungrad)
5513 C This subroutine computes the derivatives of a normalized vector u, given
5514 C the derivatives computed without normalization conditions, ugrad. Returns
5515 C ungrad.
5516       implicit none
5517       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5518       double precision vec(3)
5519       double precision scalar
5520       integer i,j
5521 c      write (2,*) 'ugrad',ugrad
5522 c      write (2,*) 'u',u
5523       do i=1,3
5524         vec(i)=scalar(ugrad(1,i),u(1))
5525       enddo
5526 c      write (2,*) 'vec',vec
5527       do i=1,3
5528         do j=1,3
5529           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5530         enddo
5531       enddo
5532 c      write (2,*) 'ungrad',ungrad
5533       return
5534       end
5535 C-----------------------------------------------------------------------------
5536       subroutine escp_soft_sphere(evdw2,evdw2_14)
5537 C
5538 C This subroutine calculates the excluded-volume interaction energy between
5539 C peptide-group centers and side chains and its gradient in virtual-bond and
5540 C side-chain vectors.
5541 C
5542       implicit real*8 (a-h,o-z)
5543       include 'DIMENSIONS'
5544       include 'COMMON.GEO'
5545       include 'COMMON.VAR'
5546       include 'COMMON.LOCAL'
5547       include 'COMMON.CHAIN'
5548       include 'COMMON.DERIV'
5549       include 'COMMON.INTERACT'
5550       include 'COMMON.FFIELD'
5551       include 'COMMON.IOUNITS'
5552       include 'COMMON.CONTROL'
5553       dimension ggg(3)
5554       evdw2=0.0D0
5555       evdw2_14=0.0d0
5556       r0_scp=4.5d0
5557 cd    print '(a)','Enter ESCP'
5558 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5559 C      do xshift=-1,1
5560 C      do yshift=-1,1
5561 C      do zshift=-1,1
5562       do i=iatscp_s,iatscp_e
5563         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5564         iteli=itel(i)
5565         xi=0.5D0*(c(1,i)+c(1,i+1))
5566         yi=0.5D0*(c(2,i)+c(2,i+1))
5567         zi=0.5D0*(c(3,i)+c(3,i+1))
5568 C Return atom into box, boxxsize is size of box in x dimension
5569 c  134   continue
5570 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5571 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5572 C Condition for being inside the proper box
5573 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5574 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5575 c        go to 134
5576 c        endif
5577 c  135   continue
5578 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5579 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5580 C Condition for being inside the proper box
5581 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5582 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5583 c        go to 135
5584 c c       endif
5585 c  136   continue
5586 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5587 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5588 cC Condition for being inside the proper box
5589 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5590 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5591 c        go to 136
5592 c        endif
5593           xi=mod(xi,boxxsize)
5594           if (xi.lt.0) xi=xi+boxxsize
5595           yi=mod(yi,boxysize)
5596           if (yi.lt.0) yi=yi+boxysize
5597           zi=mod(zi,boxzsize)
5598           if (zi.lt.0) zi=zi+boxzsize
5599 C          xi=xi+xshift*boxxsize
5600 C          yi=yi+yshift*boxysize
5601 C          zi=zi+zshift*boxzsize
5602         do iint=1,nscp_gr(i)
5603
5604         do j=iscpstart(i,iint),iscpend(i,iint)
5605           if (itype(j).eq.ntyp1) cycle
5606           itypj=iabs(itype(j))
5607 C Uncomment following three lines for SC-p interactions
5608 c         xj=c(1,nres+j)-xi
5609 c         yj=c(2,nres+j)-yi
5610 c         zj=c(3,nres+j)-zi
5611 C Uncomment following three lines for Ca-p interactions
5612           xj=c(1,j)
5613           yj=c(2,j)
5614           zj=c(3,j)
5615 c  174   continue
5616 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5617 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5618 C Condition for being inside the proper box
5619 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5620 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5621 c        go to 174
5622 c        endif
5623 c  175   continue
5624 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5625 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5626 cC Condition for being inside the proper box
5627 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5628 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5629 c        go to 175
5630 c        endif
5631 c  176   continue
5632 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5633 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5634 C Condition for being inside the proper box
5635 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5636 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5637 c        go to 176
5638           xj=mod(xj,boxxsize)
5639           if (xj.lt.0) xj=xj+boxxsize
5640           yj=mod(yj,boxysize)
5641           if (yj.lt.0) yj=yj+boxysize
5642           zj=mod(zj,boxzsize)
5643           if (zj.lt.0) zj=zj+boxzsize
5644       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5645       xj_safe=xj
5646       yj_safe=yj
5647       zj_safe=zj
5648       subchap=0
5649       do xshift=-1,1
5650       do yshift=-1,1
5651       do zshift=-1,1
5652           xj=xj_safe+xshift*boxxsize
5653           yj=yj_safe+yshift*boxysize
5654           zj=zj_safe+zshift*boxzsize
5655           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5656           if(dist_temp.lt.dist_init) then
5657             dist_init=dist_temp
5658             xj_temp=xj
5659             yj_temp=yj
5660             zj_temp=zj
5661             subchap=1
5662           endif
5663        enddo
5664        enddo
5665        enddo
5666        if (subchap.eq.1) then
5667           xj=xj_temp-xi
5668           yj=yj_temp-yi
5669           zj=zj_temp-zi
5670        else
5671           xj=xj_safe-xi
5672           yj=yj_safe-yi
5673           zj=zj_safe-zi
5674        endif
5675 c c       endif
5676 C          xj=xj-xi
5677 C          yj=yj-yi
5678 C          zj=zj-zi
5679           rij=xj*xj+yj*yj+zj*zj
5680
5681           r0ij=r0_scp
5682           r0ijsq=r0ij*r0ij
5683           if (rij.lt.r0ijsq) then
5684             evdwij=0.25d0*(rij-r0ijsq)**2
5685             fac=rij-r0ijsq
5686           else
5687             evdwij=0.0d0
5688             fac=0.0d0
5689           endif
5690           evdw2=evdw2+evdwij
5691 C
5692 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5693 C
5694           ggg(1)=xj*fac
5695           ggg(2)=yj*fac
5696           ggg(3)=zj*fac
5697 cgrad          if (j.lt.i) then
5698 cd          write (iout,*) 'j<i'
5699 C Uncomment following three lines for SC-p interactions
5700 c           do k=1,3
5701 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5702 c           enddo
5703 cgrad          else
5704 cd          write (iout,*) 'j>i'
5705 cgrad            do k=1,3
5706 cgrad              ggg(k)=-ggg(k)
5707 C Uncomment following line for SC-p interactions
5708 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5709 cgrad            enddo
5710 cgrad          endif
5711 cgrad          do k=1,3
5712 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5713 cgrad          enddo
5714 cgrad          kstart=min0(i+1,j)
5715 cgrad          kend=max0(i-1,j-1)
5716 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5717 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5718 cgrad          do k=kstart,kend
5719 cgrad            do l=1,3
5720 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5721 cgrad            enddo
5722 cgrad          enddo
5723           do k=1,3
5724             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5725             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5726           enddo
5727         enddo
5728
5729         enddo ! iint
5730       enddo ! i
5731 C      enddo !zshift
5732 C      enddo !yshift
5733 C      enddo !xshift
5734       return
5735       end
5736 C-----------------------------------------------------------------------------
5737       subroutine escp(evdw2,evdw2_14)
5738 C
5739 C This subroutine calculates the excluded-volume interaction energy between
5740 C peptide-group centers and side chains and its gradient in virtual-bond and
5741 C side-chain vectors.
5742 C
5743       implicit real*8 (a-h,o-z)
5744       include 'DIMENSIONS'
5745       include 'COMMON.GEO'
5746       include 'COMMON.VAR'
5747       include 'COMMON.LOCAL'
5748       include 'COMMON.CHAIN'
5749       include 'COMMON.DERIV'
5750       include 'COMMON.INTERACT'
5751       include 'COMMON.FFIELD'
5752       include 'COMMON.IOUNITS'
5753       include 'COMMON.CONTROL'
5754       include 'COMMON.SPLITELE'
5755       dimension ggg(3)
5756       evdw2=0.0D0
5757       evdw2_14=0.0d0
5758 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5759 cd    print '(a)','Enter ESCP'
5760 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5761 C      do xshift=-1,1
5762 C      do yshift=-1,1
5763 C      do zshift=-1,1
5764       do i=iatscp_s,iatscp_e
5765         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5766         iteli=itel(i)
5767         xi=0.5D0*(c(1,i)+c(1,i+1))
5768         yi=0.5D0*(c(2,i)+c(2,i+1))
5769         zi=0.5D0*(c(3,i)+c(3,i+1))
5770           xi=mod(xi,boxxsize)
5771           if (xi.lt.0) xi=xi+boxxsize
5772           yi=mod(yi,boxysize)
5773           if (yi.lt.0) yi=yi+boxysize
5774           zi=mod(zi,boxzsize)
5775           if (zi.lt.0) zi=zi+boxzsize
5776 c          xi=xi+xshift*boxxsize
5777 c          yi=yi+yshift*boxysize
5778 c          zi=zi+zshift*boxzsize
5779 c        print *,xi,yi,zi,'polozenie i'
5780 C Return atom into box, boxxsize is size of box in x dimension
5781 c  134   continue
5782 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5783 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5784 C Condition for being inside the proper box
5785 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5786 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5787 c        go to 134
5788 c        endif
5789 c  135   continue
5790 c          print *,xi,boxxsize,"pierwszy"
5791
5792 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5793 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5794 C Condition for being inside the proper box
5795 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5796 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5797 c        go to 135
5798 c        endif
5799 c  136   continue
5800 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5801 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5802 C Condition for being inside the proper box
5803 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5804 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5805 c        go to 136
5806 c        endif
5807         do iint=1,nscp_gr(i)
5808
5809         do j=iscpstart(i,iint),iscpend(i,iint)
5810           itypj=iabs(itype(j))
5811           if (itypj.eq.ntyp1) cycle
5812 C Uncomment following three lines for SC-p interactions
5813 c         xj=c(1,nres+j)-xi
5814 c         yj=c(2,nres+j)-yi
5815 c         zj=c(3,nres+j)-zi
5816 C Uncomment following three lines for Ca-p interactions
5817           xj=c(1,j)
5818           yj=c(2,j)
5819           zj=c(3,j)
5820           xj=mod(xj,boxxsize)
5821           if (xj.lt.0) xj=xj+boxxsize
5822           yj=mod(yj,boxysize)
5823           if (yj.lt.0) yj=yj+boxysize
5824           zj=mod(zj,boxzsize)
5825           if (zj.lt.0) zj=zj+boxzsize
5826 c  174   continue
5827 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5828 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5829 C Condition for being inside the proper box
5830 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5831 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5832 c        go to 174
5833 c        endif
5834 c  175   continue
5835 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5836 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5837 cC Condition for being inside the proper box
5838 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5839 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5840 c        go to 175
5841 c        endif
5842 c  176   continue
5843 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5844 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5845 C Condition for being inside the proper box
5846 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5847 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5848 c        go to 176
5849 c        endif
5850 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5851       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5852       xj_safe=xj
5853       yj_safe=yj
5854       zj_safe=zj
5855       subchap=0
5856       do xshift=-1,1
5857       do yshift=-1,1
5858       do zshift=-1,1
5859           xj=xj_safe+xshift*boxxsize
5860           yj=yj_safe+yshift*boxysize
5861           zj=zj_safe+zshift*boxzsize
5862           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5863           if(dist_temp.lt.dist_init) then
5864             dist_init=dist_temp
5865             xj_temp=xj
5866             yj_temp=yj
5867             zj_temp=zj
5868             subchap=1
5869           endif
5870        enddo
5871        enddo
5872        enddo
5873        if (subchap.eq.1) then
5874           xj=xj_temp-xi
5875           yj=yj_temp-yi
5876           zj=zj_temp-zi
5877        else
5878           xj=xj_safe-xi
5879           yj=yj_safe-yi
5880           zj=zj_safe-zi
5881        endif
5882 c          print *,xj,yj,zj,'polozenie j'
5883           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5884 c          print *,rrij
5885           sss=sscale(1.0d0/(dsqrt(rrij)))
5886 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5887 c          if (sss.eq.0) print *,'czasem jest OK'
5888           if (sss.le.0.0d0) cycle
5889           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5890           fac=rrij**expon2
5891           e1=fac*fac*aad(itypj,iteli)
5892           e2=fac*bad(itypj,iteli)
5893           if (iabs(j-i) .le. 2) then
5894             e1=scal14*e1
5895             e2=scal14*e2
5896             evdw2_14=evdw2_14+(e1+e2)*sss
5897           endif
5898           evdwij=e1+e2
5899           evdw2=evdw2+evdwij*sss
5900           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5901      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5902      &       bad(itypj,iteli)
5903 C
5904 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5905 C
5906           fac=-(evdwij+e1)*rrij*sss
5907           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5908           ggg(1)=xj*fac
5909           ggg(2)=yj*fac
5910           ggg(3)=zj*fac
5911 cgrad          if (j.lt.i) then
5912 cd          write (iout,*) 'j<i'
5913 C Uncomment following three lines for SC-p interactions
5914 c           do k=1,3
5915 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5916 c           enddo
5917 cgrad          else
5918 cd          write (iout,*) 'j>i'
5919 cgrad            do k=1,3
5920 cgrad              ggg(k)=-ggg(k)
5921 C Uncomment following line for SC-p interactions
5922 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5923 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5924 cgrad            enddo
5925 cgrad          endif
5926 cgrad          do k=1,3
5927 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5928 cgrad          enddo
5929 cgrad          kstart=min0(i+1,j)
5930 cgrad          kend=max0(i-1,j-1)
5931 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5932 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5933 cgrad          do k=kstart,kend
5934 cgrad            do l=1,3
5935 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5936 cgrad            enddo
5937 cgrad          enddo
5938           do k=1,3
5939             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5940             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5941           enddo
5942 c        endif !endif for sscale cutoff
5943         enddo ! j
5944
5945         enddo ! iint
5946       enddo ! i
5947 c      enddo !zshift
5948 c      enddo !yshift
5949 c      enddo !xshift
5950       do i=1,nct
5951         do j=1,3
5952           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5953           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5954           gradx_scp(j,i)=expon*gradx_scp(j,i)
5955         enddo
5956       enddo
5957 C******************************************************************************
5958 C
5959 C                              N O T E !!!
5960 C
5961 C To save time the factor EXPON has been extracted from ALL components
5962 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5963 C use!
5964 C
5965 C******************************************************************************
5966       return
5967       end
5968 C--------------------------------------------------------------------------
5969       subroutine edis(ehpb)
5970 C
5971 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5972 C
5973       implicit real*8 (a-h,o-z)
5974       include 'DIMENSIONS'
5975       include 'COMMON.SBRIDGE'
5976       include 'COMMON.CHAIN'
5977       include 'COMMON.DERIV'
5978       include 'COMMON.VAR'
5979       include 'COMMON.INTERACT'
5980       include 'COMMON.IOUNITS'
5981       include 'COMMON.CONTROL'
5982       dimension ggg(3)
5983       ehpb=0.0D0
5984       do i=1,3
5985        ggg(i)=0.0d0
5986       enddo
5987 C      write (iout,*) ,"link_end",link_end,constr_dist
5988 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5989 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5990       if (link_end.eq.0) return
5991       do i=link_start,link_end
5992 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5993 C CA-CA distance used in regularization of structure.
5994         ii=ihpb(i)
5995         jj=jhpb(i)
5996 C iii and jjj point to the residues for which the distance is assigned.
5997         if (ii.gt.nres) then
5998           iii=ii-nres
5999           jjj=jj-nres
6000         else
6001           iii=ii
6002           jjj=jj
6003         endif
6004 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6005 c     &    dhpb(i),dhpb1(i),forcon(i)
6006 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6007 C    distance and angle dependent SS bond potential.
6008 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6009 C     & iabs(itype(jjj)).eq.1) then
6010 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6011 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6012         if (.not.dyn_ss .and. i.le.nss) then
6013 C 15/02/13 CC dynamic SSbond - additional check
6014          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6015      & iabs(itype(jjj)).eq.1) then
6016           call ssbond_ene(iii,jjj,eij)
6017           ehpb=ehpb+2*eij
6018          endif
6019 cd          write (iout,*) "eij",eij
6020 cd   &   ' waga=',waga,' fac=',fac
6021         else if (ii.gt.nres .and. jj.gt.nres) then
6022 c Restraints from contact prediction
6023           dd=dist(ii,jj)
6024           if (constr_dist.eq.11) then
6025             ehpb=ehpb+fordepth(i)**4.0d0
6026      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6027             fac=fordepth(i)**4.0d0
6028      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6029           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6030      &    ehpb,fordepth(i),dd
6031            else
6032           if (dhpb1(i).gt.0.0d0) then
6033             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6034             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6035 c            write (iout,*) "beta nmr",
6036 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6037           else
6038             dd=dist(ii,jj)
6039             rdis=dd-dhpb(i)
6040 C Get the force constant corresponding to this distance.
6041             waga=forcon(i)
6042 C Calculate the contribution to energy.
6043             ehpb=ehpb+waga*rdis*rdis
6044 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6045 C
6046 C Evaluate gradient.
6047 C
6048             fac=waga*rdis/dd
6049           endif
6050           endif
6051           do j=1,3
6052             ggg(j)=fac*(c(j,jj)-c(j,ii))
6053           enddo
6054           do j=1,3
6055             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6056             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6057           enddo
6058           do k=1,3
6059             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6060             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6061           enddo
6062         else
6063 C Calculate the distance between the two points and its difference from the
6064 C target distance.
6065           dd=dist(ii,jj)
6066           if (constr_dist.eq.11) then
6067             ehpb=ehpb+fordepth(i)**4.0d0
6068      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6069             fac=fordepth(i)**4.0d0
6070      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6071           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6072      &    ehpb,fordepth(i),dd
6073            else
6074           if (dhpb1(i).gt.0.0d0) then
6075             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6076             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6077 c            write (iout,*) "alph nmr",
6078 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6079           else
6080             rdis=dd-dhpb(i)
6081 C Get the force constant corresponding to this distance.
6082             waga=forcon(i)
6083 C Calculate the contribution to energy.
6084             ehpb=ehpb+waga*rdis*rdis
6085 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6086 C
6087 C Evaluate gradient.
6088 C
6089             fac=waga*rdis/dd
6090           endif
6091           endif
6092             do j=1,3
6093               ggg(j)=fac*(c(j,jj)-c(j,ii))
6094             enddo
6095 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6096 C If this is a SC-SC distance, we need to calculate the contributions to the
6097 C Cartesian gradient in the SC vectors (ghpbx).
6098           if (iii.lt.ii) then
6099           do j=1,3
6100             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6101             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6102           enddo
6103           endif
6104 cgrad        do j=iii,jjj-1
6105 cgrad          do k=1,3
6106 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6107 cgrad          enddo
6108 cgrad        enddo
6109           do k=1,3
6110             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6111             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6112           enddo
6113         endif
6114       enddo
6115       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6116       return
6117       end
6118 C--------------------------------------------------------------------------
6119       subroutine ssbond_ene(i,j,eij)
6120 C
6121 C Calculate the distance and angle dependent SS-bond potential energy
6122 C using a free-energy function derived based on RHF/6-31G** ab initio
6123 C calculations of diethyl disulfide.
6124 C
6125 C A. Liwo and U. Kozlowska, 11/24/03
6126 C
6127       implicit real*8 (a-h,o-z)
6128       include 'DIMENSIONS'
6129       include 'COMMON.SBRIDGE'
6130       include 'COMMON.CHAIN'
6131       include 'COMMON.DERIV'
6132       include 'COMMON.LOCAL'
6133       include 'COMMON.INTERACT'
6134       include 'COMMON.VAR'
6135       include 'COMMON.IOUNITS'
6136       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6137       itypi=iabs(itype(i))
6138       xi=c(1,nres+i)
6139       yi=c(2,nres+i)
6140       zi=c(3,nres+i)
6141       dxi=dc_norm(1,nres+i)
6142       dyi=dc_norm(2,nres+i)
6143       dzi=dc_norm(3,nres+i)
6144 c      dsci_inv=dsc_inv(itypi)
6145       dsci_inv=vbld_inv(nres+i)
6146       itypj=iabs(itype(j))
6147 c      dscj_inv=dsc_inv(itypj)
6148       dscj_inv=vbld_inv(nres+j)
6149       xj=c(1,nres+j)-xi
6150       yj=c(2,nres+j)-yi
6151       zj=c(3,nres+j)-zi
6152       dxj=dc_norm(1,nres+j)
6153       dyj=dc_norm(2,nres+j)
6154       dzj=dc_norm(3,nres+j)
6155       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6156       rij=dsqrt(rrij)
6157       erij(1)=xj*rij
6158       erij(2)=yj*rij
6159       erij(3)=zj*rij
6160       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6161       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6162       om12=dxi*dxj+dyi*dyj+dzi*dzj
6163       do k=1,3
6164         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6165         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6166       enddo
6167       rij=1.0d0/rij
6168       deltad=rij-d0cm
6169       deltat1=1.0d0-om1
6170       deltat2=1.0d0+om2
6171       deltat12=om2-om1+2.0d0
6172       cosphi=om12-om1*om2
6173       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6174      &  +akct*deltad*deltat12
6175      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6176 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6177 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6178 c     &  " deltat12",deltat12," eij",eij
6179       ed=2*akcm*deltad+akct*deltat12
6180       pom1=akct*deltad
6181       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6182       eom1=-2*akth*deltat1-pom1-om2*pom2
6183       eom2= 2*akth*deltat2+pom1-om1*pom2
6184       eom12=pom2
6185       do k=1,3
6186         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6187         ghpbx(k,i)=ghpbx(k,i)-ggk
6188      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6189      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6190         ghpbx(k,j)=ghpbx(k,j)+ggk
6191      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6192      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6193         ghpbc(k,i)=ghpbc(k,i)-ggk
6194         ghpbc(k,j)=ghpbc(k,j)+ggk
6195       enddo
6196 C
6197 C Calculate the components of the gradient in DC and X
6198 C
6199 cgrad      do k=i,j-1
6200 cgrad        do l=1,3
6201 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6202 cgrad        enddo
6203 cgrad      enddo
6204       return
6205       end
6206 C--------------------------------------------------------------------------
6207       subroutine ebond(estr)
6208 c
6209 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6210 c
6211       implicit real*8 (a-h,o-z)
6212       include 'DIMENSIONS'
6213       include 'COMMON.LOCAL'
6214       include 'COMMON.GEO'
6215       include 'COMMON.INTERACT'
6216       include 'COMMON.DERIV'
6217       include 'COMMON.VAR'
6218       include 'COMMON.CHAIN'
6219       include 'COMMON.IOUNITS'
6220       include 'COMMON.NAMES'
6221       include 'COMMON.FFIELD'
6222       include 'COMMON.CONTROL'
6223       include 'COMMON.SETUP'
6224       double precision u(3),ud(3)
6225       estr=0.0d0
6226       estr1=0.0d0
6227       do i=ibondp_start,ibondp_end
6228         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6229 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6230 c          do j=1,3
6231 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6232 c     &      *dc(j,i-1)/vbld(i)
6233 c          enddo
6234 c          if (energy_dec) write(iout,*)
6235 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6236 c        else
6237 C       Checking if it involves dummy (NH3+ or COO-) group
6238          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6239 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6240         diff = vbld(i)-vbldpDUM
6241         if (energy_dec) write(iout,*) "dum_bond",i,diff
6242          else
6243 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6244         diff = vbld(i)-vbldp0
6245          endif
6246         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6247      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6248         estr=estr+diff*diff
6249         do j=1,3
6250           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6251         enddo
6252 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6253 c        endif
6254       enddo
6255
6256       estr=0.5d0*AKP*estr+estr1
6257 c
6258 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6259 c
6260       do i=ibond_start,ibond_end
6261         iti=iabs(itype(i))
6262         if (iti.ne.10 .and. iti.ne.ntyp1) then
6263           nbi=nbondterm(iti)
6264           if (nbi.eq.1) then
6265             diff=vbld(i+nres)-vbldsc0(1,iti)
6266             if (energy_dec)  write (iout,*)
6267      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6268      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6269             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6270             do j=1,3
6271               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6272             enddo
6273           else
6274             do j=1,nbi
6275               diff=vbld(i+nres)-vbldsc0(j,iti)
6276               ud(j)=aksc(j,iti)*diff
6277               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6278             enddo
6279             uprod=u(1)
6280             do j=2,nbi
6281               uprod=uprod*u(j)
6282             enddo
6283             usum=0.0d0
6284             usumsqder=0.0d0
6285             do j=1,nbi
6286               uprod1=1.0d0
6287               uprod2=1.0d0
6288               do k=1,nbi
6289                 if (k.ne.j) then
6290                   uprod1=uprod1*u(k)
6291                   uprod2=uprod2*u(k)*u(k)
6292                 endif
6293               enddo
6294               usum=usum+uprod1
6295               usumsqder=usumsqder+ud(j)*uprod2
6296             enddo
6297             estr=estr+uprod/usum
6298             do j=1,3
6299              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6300             enddo
6301           endif
6302         endif
6303       enddo
6304       return
6305       end
6306 #ifdef CRYST_THETA
6307 C--------------------------------------------------------------------------
6308       subroutine ebend(etheta,ethetacnstr)
6309 C
6310 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6311 C angles gamma and its derivatives in consecutive thetas and gammas.
6312 C
6313       implicit real*8 (a-h,o-z)
6314       include 'DIMENSIONS'
6315       include 'COMMON.LOCAL'
6316       include 'COMMON.GEO'
6317       include 'COMMON.INTERACT'
6318       include 'COMMON.DERIV'
6319       include 'COMMON.VAR'
6320       include 'COMMON.CHAIN'
6321       include 'COMMON.IOUNITS'
6322       include 'COMMON.NAMES'
6323       include 'COMMON.FFIELD'
6324       include 'COMMON.CONTROL'
6325       include 'COMMON.TORCNSTR'
6326       common /calcthet/ term1,term2,termm,diffak,ratak,
6327      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6328      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6329       double precision y(2),z(2)
6330       delta=0.02d0*pi
6331 c      time11=dexp(-2*time)
6332 c      time12=1.0d0
6333       etheta=0.0D0
6334 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6335       do i=ithet_start,ithet_end
6336         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6337      &  .or.itype(i).eq.ntyp1) cycle
6338 C Zero the energy function and its derivative at 0 or pi.
6339         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6340         it=itype(i-1)
6341         ichir1=isign(1,itype(i-2))
6342         ichir2=isign(1,itype(i))
6343          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6344          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6345          if (itype(i-1).eq.10) then
6346           itype1=isign(10,itype(i-2))
6347           ichir11=isign(1,itype(i-2))
6348           ichir12=isign(1,itype(i-2))
6349           itype2=isign(10,itype(i))
6350           ichir21=isign(1,itype(i))
6351           ichir22=isign(1,itype(i))
6352          endif
6353
6354         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6355 #ifdef OSF
6356           phii=phi(i)
6357           if (phii.ne.phii) phii=150.0
6358 #else
6359           phii=phi(i)
6360 #endif
6361           y(1)=dcos(phii)
6362           y(2)=dsin(phii)
6363         else
6364           y(1)=0.0D0
6365           y(2)=0.0D0
6366         endif
6367         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6368 #ifdef OSF
6369           phii1=phi(i+1)
6370           if (phii1.ne.phii1) phii1=150.0
6371           phii1=pinorm(phii1)
6372           z(1)=cos(phii1)
6373 #else
6374           phii1=phi(i+1)
6375 #endif
6376           z(1)=dcos(phii1)
6377           z(2)=dsin(phii1)
6378         else
6379           z(1)=0.0D0
6380           z(2)=0.0D0
6381         endif
6382 C Calculate the "mean" value of theta from the part of the distribution
6383 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6384 C In following comments this theta will be referred to as t_c.
6385         thet_pred_mean=0.0d0
6386         do k=1,2
6387             athetk=athet(k,it,ichir1,ichir2)
6388             bthetk=bthet(k,it,ichir1,ichir2)
6389           if (it.eq.10) then
6390              athetk=athet(k,itype1,ichir11,ichir12)
6391              bthetk=bthet(k,itype2,ichir21,ichir22)
6392           endif
6393          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6394 c         write(iout,*) 'chuj tu', y(k),z(k)
6395         enddo
6396         dthett=thet_pred_mean*ssd
6397         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6398 C Derivatives of the "mean" values in gamma1 and gamma2.
6399         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6400      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6401          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6402      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6403          if (it.eq.10) then
6404       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6405      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6406         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6407      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6408          endif
6409         if (theta(i).gt.pi-delta) then
6410           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6411      &         E_tc0)
6412           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6413           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6414           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6415      &        E_theta)
6416           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6417      &        E_tc)
6418         else if (theta(i).lt.delta) then
6419           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6420           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6421           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6422      &        E_theta)
6423           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6424           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6425      &        E_tc)
6426         else
6427           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6428      &        E_theta,E_tc)
6429         endif
6430         etheta=etheta+ethetai
6431         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6432      &      'ebend',i,ethetai,theta(i),itype(i)
6433         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6434         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6435         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6436       enddo
6437       ethetacnstr=0.0d0
6438 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6439       do i=ithetaconstr_start,ithetaconstr_end
6440         itheta=itheta_constr(i)
6441         thetiii=theta(itheta)
6442         difi=pinorm(thetiii-theta_constr0(i))
6443         if (difi.gt.theta_drange(i)) then
6444           difi=difi-theta_drange(i)
6445           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6446           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6447      &    +for_thet_constr(i)*difi**3
6448         else if (difi.lt.-drange(i)) then
6449           difi=difi+drange(i)
6450           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6451           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6452      &    +for_thet_constr(i)*difi**3
6453         else
6454           difi=0.0
6455         endif
6456        if (energy_dec) then
6457         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6458      &    i,itheta,rad2deg*thetiii,
6459      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6460      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6461      &    gloc(itheta+nphi-2,icg)
6462         endif
6463       enddo
6464
6465 C Ufff.... We've done all this!!!
6466       return
6467       end
6468 C---------------------------------------------------------------------------
6469       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6470      &     E_tc)
6471       implicit real*8 (a-h,o-z)
6472       include 'DIMENSIONS'
6473       include 'COMMON.LOCAL'
6474       include 'COMMON.IOUNITS'
6475       common /calcthet/ term1,term2,termm,diffak,ratak,
6476      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6477      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6478 C Calculate the contributions to both Gaussian lobes.
6479 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6480 C The "polynomial part" of the "standard deviation" of this part of
6481 C the distributioni.
6482 ccc        write (iout,*) thetai,thet_pred_mean
6483         sig=polthet(3,it)
6484         do j=2,0,-1
6485           sig=sig*thet_pred_mean+polthet(j,it)
6486         enddo
6487 C Derivative of the "interior part" of the "standard deviation of the"
6488 C gamma-dependent Gaussian lobe in t_c.
6489         sigtc=3*polthet(3,it)
6490         do j=2,1,-1
6491           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6492         enddo
6493         sigtc=sig*sigtc
6494 C Set the parameters of both Gaussian lobes of the distribution.
6495 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6496         fac=sig*sig+sigc0(it)
6497         sigcsq=fac+fac
6498         sigc=1.0D0/sigcsq
6499 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6500         sigsqtc=-4.0D0*sigcsq*sigtc
6501 c       print *,i,sig,sigtc,sigsqtc
6502 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6503         sigtc=-sigtc/(fac*fac)
6504 C Following variable is sigma(t_c)**(-2)
6505         sigcsq=sigcsq*sigcsq
6506         sig0i=sig0(it)
6507         sig0inv=1.0D0/sig0i**2
6508         delthec=thetai-thet_pred_mean
6509         delthe0=thetai-theta0i
6510         term1=-0.5D0*sigcsq*delthec*delthec
6511         term2=-0.5D0*sig0inv*delthe0*delthe0
6512 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6513 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6514 C NaNs in taking the logarithm. We extract the largest exponent which is added
6515 C to the energy (this being the log of the distribution) at the end of energy
6516 C term evaluation for this virtual-bond angle.
6517         if (term1.gt.term2) then
6518           termm=term1
6519           term2=dexp(term2-termm)
6520           term1=1.0d0
6521         else
6522           termm=term2
6523           term1=dexp(term1-termm)
6524           term2=1.0d0
6525         endif
6526 C The ratio between the gamma-independent and gamma-dependent lobes of
6527 C the distribution is a Gaussian function of thet_pred_mean too.
6528         diffak=gthet(2,it)-thet_pred_mean
6529         ratak=diffak/gthet(3,it)**2
6530         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6531 C Let's differentiate it in thet_pred_mean NOW.
6532         aktc=ak*ratak
6533 C Now put together the distribution terms to make complete distribution.
6534         termexp=term1+ak*term2
6535         termpre=sigc+ak*sig0i
6536 C Contribution of the bending energy from this theta is just the -log of
6537 C the sum of the contributions from the two lobes and the pre-exponential
6538 C factor. Simple enough, isn't it?
6539         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6540 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6541 C NOW the derivatives!!!
6542 C 6/6/97 Take into account the deformation.
6543         E_theta=(delthec*sigcsq*term1
6544      &       +ak*delthe0*sig0inv*term2)/termexp
6545         E_tc=((sigtc+aktc*sig0i)/termpre
6546      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6547      &       aktc*term2)/termexp)
6548       return
6549       end
6550 c-----------------------------------------------------------------------------
6551       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6552       implicit real*8 (a-h,o-z)
6553       include 'DIMENSIONS'
6554       include 'COMMON.LOCAL'
6555       include 'COMMON.IOUNITS'
6556       common /calcthet/ term1,term2,termm,diffak,ratak,
6557      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6558      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6559       delthec=thetai-thet_pred_mean
6560       delthe0=thetai-theta0i
6561 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6562       t3 = thetai-thet_pred_mean
6563       t6 = t3**2
6564       t9 = term1
6565       t12 = t3*sigcsq
6566       t14 = t12+t6*sigsqtc
6567       t16 = 1.0d0
6568       t21 = thetai-theta0i
6569       t23 = t21**2
6570       t26 = term2
6571       t27 = t21*t26
6572       t32 = termexp
6573       t40 = t32**2
6574       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6575      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6576      & *(-t12*t9-ak*sig0inv*t27)
6577       return
6578       end
6579 #else
6580 C--------------------------------------------------------------------------
6581       subroutine ebend(etheta,ethetacnstr)
6582 C
6583 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6584 C angles gamma and its derivatives in consecutive thetas and gammas.
6585 C ab initio-derived potentials from
6586 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6587 C
6588       implicit real*8 (a-h,o-z)
6589       include 'DIMENSIONS'
6590       include 'COMMON.LOCAL'
6591       include 'COMMON.GEO'
6592       include 'COMMON.INTERACT'
6593       include 'COMMON.DERIV'
6594       include 'COMMON.VAR'
6595       include 'COMMON.CHAIN'
6596       include 'COMMON.IOUNITS'
6597       include 'COMMON.NAMES'
6598       include 'COMMON.FFIELD'
6599       include 'COMMON.CONTROL'
6600       include 'COMMON.TORCNSTR'
6601       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6602      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6603      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6604      & sinph1ph2(maxdouble,maxdouble)
6605       logical lprn /.false./, lprn1 /.false./
6606       etheta=0.0D0
6607       do i=ithet_start,ithet_end
6608 c        print *,i,itype(i-1),itype(i),itype(i-2)
6609         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6610      &  .or.itype(i).eq.ntyp1) cycle
6611 C        print *,i,theta(i)
6612         if (iabs(itype(i+1)).eq.20) iblock=2
6613         if (iabs(itype(i+1)).ne.20) iblock=1
6614         dethetai=0.0d0
6615         dephii=0.0d0
6616         dephii1=0.0d0
6617         theti2=0.5d0*theta(i)
6618         ityp2=ithetyp((itype(i-1)))
6619         do k=1,nntheterm
6620           coskt(k)=dcos(k*theti2)
6621           sinkt(k)=dsin(k*theti2)
6622         enddo
6623 C        print *,ethetai
6624         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6625 #ifdef OSF
6626           phii=phi(i)
6627           if (phii.ne.phii) phii=150.0
6628 #else
6629           phii=phi(i)
6630 #endif
6631           ityp1=ithetyp((itype(i-2)))
6632 C propagation of chirality for glycine type
6633           do k=1,nsingle
6634             cosph1(k)=dcos(k*phii)
6635             sinph1(k)=dsin(k*phii)
6636           enddo
6637         else
6638           phii=0.0d0
6639           do k=1,nsingle
6640           ityp1=ithetyp((itype(i-2)))
6641             cosph1(k)=0.0d0
6642             sinph1(k)=0.0d0
6643           enddo
6644         endif
6645         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6646 #ifdef OSF
6647           phii1=phi(i+1)
6648           if (phii1.ne.phii1) phii1=150.0
6649           phii1=pinorm(phii1)
6650 #else
6651           phii1=phi(i+1)
6652 #endif
6653           ityp3=ithetyp((itype(i)))
6654           do k=1,nsingle
6655             cosph2(k)=dcos(k*phii1)
6656             sinph2(k)=dsin(k*phii1)
6657           enddo
6658         else
6659           phii1=0.0d0
6660           ityp3=ithetyp((itype(i)))
6661           do k=1,nsingle
6662             cosph2(k)=0.0d0
6663             sinph2(k)=0.0d0
6664           enddo
6665         endif
6666         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6667         do k=1,ndouble
6668           do l=1,k-1
6669             ccl=cosph1(l)*cosph2(k-l)
6670             ssl=sinph1(l)*sinph2(k-l)
6671             scl=sinph1(l)*cosph2(k-l)
6672             csl=cosph1(l)*sinph2(k-l)
6673             cosph1ph2(l,k)=ccl-ssl
6674             cosph1ph2(k,l)=ccl+ssl
6675             sinph1ph2(l,k)=scl+csl
6676             sinph1ph2(k,l)=scl-csl
6677           enddo
6678         enddo
6679         if (lprn) then
6680         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6681      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6682         write (iout,*) "coskt and sinkt"
6683         do k=1,nntheterm
6684           write (iout,*) k,coskt(k),sinkt(k)
6685         enddo
6686         endif
6687         do k=1,ntheterm
6688           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6689           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6690      &      *coskt(k)
6691           if (lprn)
6692      &    write (iout,*) "k",k,"
6693      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6694      &     " ethetai",ethetai
6695         enddo
6696         if (lprn) then
6697         write (iout,*) "cosph and sinph"
6698         do k=1,nsingle
6699           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6700         enddo
6701         write (iout,*) "cosph1ph2 and sinph2ph2"
6702         do k=2,ndouble
6703           do l=1,k-1
6704             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6705      &         sinph1ph2(l,k),sinph1ph2(k,l)
6706           enddo
6707         enddo
6708         write(iout,*) "ethetai",ethetai
6709         endif
6710 C       print *,ethetai
6711         do m=1,ntheterm2
6712           do k=1,nsingle
6713             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6714      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6715      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6716      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6717             ethetai=ethetai+sinkt(m)*aux
6718             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6719             dephii=dephii+k*sinkt(m)*(
6720      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6721      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6722             dephii1=dephii1+k*sinkt(m)*(
6723      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6724      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6725             if (lprn)
6726      &      write (iout,*) "m",m," k",k," bbthet",
6727      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6728      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6729      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6730      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6731 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6732           enddo
6733         enddo
6734 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6735 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6736 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6737 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6738         if (lprn)
6739      &  write(iout,*) "ethetai",ethetai
6740 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6741         do m=1,ntheterm3
6742           do k=2,ndouble
6743             do l=1,k-1
6744               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6745      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6746      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6747      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6748               ethetai=ethetai+sinkt(m)*aux
6749               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6750               dephii=dephii+l*sinkt(m)*(
6751      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6752      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6753      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6754      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6755               dephii1=dephii1+(k-l)*sinkt(m)*(
6756      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6757      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6758      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6759      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6760               if (lprn) then
6761               write (iout,*) "m",m," k",k," l",l," ffthet",
6762      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6763      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6764      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6765      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6766      &            " ethetai",ethetai
6767               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6768      &            cosph1ph2(k,l)*sinkt(m),
6769      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6770               endif
6771             enddo
6772           enddo
6773         enddo
6774 10      continue
6775 c        lprn1=.true.
6776 C        print *,ethetai
6777         if (lprn1)
6778      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6779      &   i,theta(i)*rad2deg,phii*rad2deg,
6780      &   phii1*rad2deg,ethetai
6781 c        lprn1=.false.
6782         etheta=etheta+ethetai
6783         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6784         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6785         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6786       enddo
6787 C now constrains
6788       ethetacnstr=0.0d0
6789 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6790       do i=ithetaconstr_start,ithetaconstr_end
6791         itheta=itheta_constr(i)
6792         thetiii=theta(itheta)
6793         difi=pinorm(thetiii-theta_constr0(i))
6794         if (difi.gt.theta_drange(i)) then
6795           difi=difi-theta_drange(i)
6796           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6797           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6798      &    +for_thet_constr(i)*difi**3
6799         else if (difi.lt.-drange(i)) then
6800           difi=difi+drange(i)
6801           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6802           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6803      &    +for_thet_constr(i)*difi**3
6804         else
6805           difi=0.0
6806         endif
6807        if (energy_dec) then
6808         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6809      &    i,itheta,rad2deg*thetiii,
6810      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6811      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6812      &    gloc(itheta+nphi-2,icg)
6813         endif
6814       enddo
6815
6816       return
6817       end
6818 #endif
6819 #ifdef CRYST_SC
6820 c-----------------------------------------------------------------------------
6821       subroutine esc(escloc)
6822 C Calculate the local energy of a side chain and its derivatives in the
6823 C corresponding virtual-bond valence angles THETA and the spherical angles
6824 C ALPHA and OMEGA.
6825       implicit real*8 (a-h,o-z)
6826       include 'DIMENSIONS'
6827       include 'COMMON.GEO'
6828       include 'COMMON.LOCAL'
6829       include 'COMMON.VAR'
6830       include 'COMMON.INTERACT'
6831       include 'COMMON.DERIV'
6832       include 'COMMON.CHAIN'
6833       include 'COMMON.IOUNITS'
6834       include 'COMMON.NAMES'
6835       include 'COMMON.FFIELD'
6836       include 'COMMON.CONTROL'
6837       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6838      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6839       common /sccalc/ time11,time12,time112,theti,it,nlobit
6840       delta=0.02d0*pi
6841       escloc=0.0D0
6842 c     write (iout,'(a)') 'ESC'
6843       do i=loc_start,loc_end
6844         it=itype(i)
6845         if (it.eq.ntyp1) cycle
6846         if (it.eq.10) goto 1
6847         nlobit=nlob(iabs(it))
6848 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6849 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6850         theti=theta(i+1)-pipol
6851         x(1)=dtan(theti)
6852         x(2)=alph(i)
6853         x(3)=omeg(i)
6854
6855         if (x(2).gt.pi-delta) then
6856           xtemp(1)=x(1)
6857           xtemp(2)=pi-delta
6858           xtemp(3)=x(3)
6859           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6860           xtemp(2)=pi
6861           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6862           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6863      &        escloci,dersc(2))
6864           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6865      &        ddersc0(1),dersc(1))
6866           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6867      &        ddersc0(3),dersc(3))
6868           xtemp(2)=pi-delta
6869           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6870           xtemp(2)=pi
6871           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6872           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6873      &            dersc0(2),esclocbi,dersc02)
6874           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6875      &            dersc12,dersc01)
6876           call splinthet(x(2),0.5d0*delta,ss,ssd)
6877           dersc0(1)=dersc01
6878           dersc0(2)=dersc02
6879           dersc0(3)=0.0d0
6880           do k=1,3
6881             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6882           enddo
6883           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6884 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6885 c    &             esclocbi,ss,ssd
6886           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6887 c         escloci=esclocbi
6888 c         write (iout,*) escloci
6889         else if (x(2).lt.delta) then
6890           xtemp(1)=x(1)
6891           xtemp(2)=delta
6892           xtemp(3)=x(3)
6893           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6894           xtemp(2)=0.0d0
6895           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6896           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6897      &        escloci,dersc(2))
6898           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6899      &        ddersc0(1),dersc(1))
6900           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6901      &        ddersc0(3),dersc(3))
6902           xtemp(2)=delta
6903           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6904           xtemp(2)=0.0d0
6905           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6906           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6907      &            dersc0(2),esclocbi,dersc02)
6908           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6909      &            dersc12,dersc01)
6910           dersc0(1)=dersc01
6911           dersc0(2)=dersc02
6912           dersc0(3)=0.0d0
6913           call splinthet(x(2),0.5d0*delta,ss,ssd)
6914           do k=1,3
6915             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6916           enddo
6917           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6918 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6919 c    &             esclocbi,ss,ssd
6920           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6921 c         write (iout,*) escloci
6922         else
6923           call enesc(x,escloci,dersc,ddummy,.false.)
6924         endif
6925
6926         escloc=escloc+escloci
6927         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6928      &     'escloc',i,escloci
6929 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6930
6931         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6932      &   wscloc*dersc(1)
6933         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6934         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6935     1   continue
6936       enddo
6937       return
6938       end
6939 C---------------------------------------------------------------------------
6940       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6941       implicit real*8 (a-h,o-z)
6942       include 'DIMENSIONS'
6943       include 'COMMON.GEO'
6944       include 'COMMON.LOCAL'
6945       include 'COMMON.IOUNITS'
6946       common /sccalc/ time11,time12,time112,theti,it,nlobit
6947       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6948       double precision contr(maxlob,-1:1)
6949       logical mixed
6950 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6951         escloc_i=0.0D0
6952         do j=1,3
6953           dersc(j)=0.0D0
6954           if (mixed) ddersc(j)=0.0d0
6955         enddo
6956         x3=x(3)
6957
6958 C Because of periodicity of the dependence of the SC energy in omega we have
6959 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6960 C To avoid underflows, first compute & store the exponents.
6961
6962         do iii=-1,1
6963
6964           x(3)=x3+iii*dwapi
6965
6966           do j=1,nlobit
6967             do k=1,3
6968               z(k)=x(k)-censc(k,j,it)
6969             enddo
6970             do k=1,3
6971               Axk=0.0D0
6972               do l=1,3
6973                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6974               enddo
6975               Ax(k,j,iii)=Axk
6976             enddo
6977             expfac=0.0D0
6978             do k=1,3
6979               expfac=expfac+Ax(k,j,iii)*z(k)
6980             enddo
6981             contr(j,iii)=expfac
6982           enddo ! j
6983
6984         enddo ! iii
6985
6986         x(3)=x3
6987 C As in the case of ebend, we want to avoid underflows in exponentiation and
6988 C subsequent NaNs and INFs in energy calculation.
6989 C Find the largest exponent
6990         emin=contr(1,-1)
6991         do iii=-1,1
6992           do j=1,nlobit
6993             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6994           enddo
6995         enddo
6996         emin=0.5D0*emin
6997 cd      print *,'it=',it,' emin=',emin
6998
6999 C Compute the contribution to SC energy and derivatives
7000         do iii=-1,1
7001
7002           do j=1,nlobit
7003 #ifdef OSF
7004             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7005             if(adexp.ne.adexp) adexp=1.0
7006             expfac=dexp(adexp)
7007 #else
7008             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7009 #endif
7010 cd          print *,'j=',j,' expfac=',expfac
7011             escloc_i=escloc_i+expfac
7012             do k=1,3
7013               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7014             enddo
7015             if (mixed) then
7016               do k=1,3,2
7017                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7018      &            +gaussc(k,2,j,it))*expfac
7019               enddo
7020             endif
7021           enddo
7022
7023         enddo ! iii
7024
7025         dersc(1)=dersc(1)/cos(theti)**2
7026         ddersc(1)=ddersc(1)/cos(theti)**2
7027         ddersc(3)=ddersc(3)
7028
7029         escloci=-(dlog(escloc_i)-emin)
7030         do j=1,3
7031           dersc(j)=dersc(j)/escloc_i
7032         enddo
7033         if (mixed) then
7034           do j=1,3,2
7035             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7036           enddo
7037         endif
7038       return
7039       end
7040 C------------------------------------------------------------------------------
7041       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7042       implicit real*8 (a-h,o-z)
7043       include 'DIMENSIONS'
7044       include 'COMMON.GEO'
7045       include 'COMMON.LOCAL'
7046       include 'COMMON.IOUNITS'
7047       common /sccalc/ time11,time12,time112,theti,it,nlobit
7048       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7049       double precision contr(maxlob)
7050       logical mixed
7051
7052       escloc_i=0.0D0
7053
7054       do j=1,3
7055         dersc(j)=0.0D0
7056       enddo
7057
7058       do j=1,nlobit
7059         do k=1,2
7060           z(k)=x(k)-censc(k,j,it)
7061         enddo
7062         z(3)=dwapi
7063         do k=1,3
7064           Axk=0.0D0
7065           do l=1,3
7066             Axk=Axk+gaussc(l,k,j,it)*z(l)
7067           enddo
7068           Ax(k,j)=Axk
7069         enddo
7070         expfac=0.0D0
7071         do k=1,3
7072           expfac=expfac+Ax(k,j)*z(k)
7073         enddo
7074         contr(j)=expfac
7075       enddo ! j
7076
7077 C As in the case of ebend, we want to avoid underflows in exponentiation and
7078 C subsequent NaNs and INFs in energy calculation.
7079 C Find the largest exponent
7080       emin=contr(1)
7081       do j=1,nlobit
7082         if (emin.gt.contr(j)) emin=contr(j)
7083       enddo
7084       emin=0.5D0*emin
7085
7086 C Compute the contribution to SC energy and derivatives
7087
7088       dersc12=0.0d0
7089       do j=1,nlobit
7090         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7091         escloc_i=escloc_i+expfac
7092         do k=1,2
7093           dersc(k)=dersc(k)+Ax(k,j)*expfac
7094         enddo
7095         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7096      &            +gaussc(1,2,j,it))*expfac
7097         dersc(3)=0.0d0
7098       enddo
7099
7100       dersc(1)=dersc(1)/cos(theti)**2
7101       dersc12=dersc12/cos(theti)**2
7102       escloci=-(dlog(escloc_i)-emin)
7103       do j=1,2
7104         dersc(j)=dersc(j)/escloc_i
7105       enddo
7106       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7107       return
7108       end
7109 #else
7110 c----------------------------------------------------------------------------------
7111       subroutine esc(escloc)
7112 C Calculate the local energy of a side chain and its derivatives in the
7113 C corresponding virtual-bond valence angles THETA and the spherical angles
7114 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7115 C added by Urszula Kozlowska. 07/11/2007
7116 C
7117       implicit real*8 (a-h,o-z)
7118       include 'DIMENSIONS'
7119       include 'COMMON.GEO'
7120       include 'COMMON.LOCAL'
7121       include 'COMMON.VAR'
7122       include 'COMMON.SCROT'
7123       include 'COMMON.INTERACT'
7124       include 'COMMON.DERIV'
7125       include 'COMMON.CHAIN'
7126       include 'COMMON.IOUNITS'
7127       include 'COMMON.NAMES'
7128       include 'COMMON.FFIELD'
7129       include 'COMMON.CONTROL'
7130       include 'COMMON.VECTORS'
7131       double precision x_prime(3),y_prime(3),z_prime(3)
7132      &    , sumene,dsc_i,dp2_i,x(65),
7133      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7134      &    de_dxx,de_dyy,de_dzz,de_dt
7135       double precision s1_t,s1_6_t,s2_t,s2_6_t
7136       double precision
7137      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7138      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7139      & dt_dCi(3),dt_dCi1(3)
7140       common /sccalc/ time11,time12,time112,theti,it,nlobit
7141       delta=0.02d0*pi
7142       escloc=0.0D0
7143       do i=loc_start,loc_end
7144         if (itype(i).eq.ntyp1) cycle
7145         costtab(i+1) =dcos(theta(i+1))
7146         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7147         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7148         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7149         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7150         cosfac=dsqrt(cosfac2)
7151         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7152         sinfac=dsqrt(sinfac2)
7153         it=iabs(itype(i))
7154         if (it.eq.10) goto 1
7155 c
7156 C  Compute the axes of tghe local cartesian coordinates system; store in
7157 c   x_prime, y_prime and z_prime
7158 c
7159         do j=1,3
7160           x_prime(j) = 0.00
7161           y_prime(j) = 0.00
7162           z_prime(j) = 0.00
7163         enddo
7164 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7165 C     &   dc_norm(3,i+nres)
7166         do j = 1,3
7167           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7168           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7169         enddo
7170         do j = 1,3
7171           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7172         enddo
7173 c       write (2,*) "i",i
7174 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7175 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7176 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7177 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7178 c      & " xy",scalar(x_prime(1),y_prime(1)),
7179 c      & " xz",scalar(x_prime(1),z_prime(1)),
7180 c      & " yy",scalar(y_prime(1),y_prime(1)),
7181 c      & " yz",scalar(y_prime(1),z_prime(1)),
7182 c      & " zz",scalar(z_prime(1),z_prime(1))
7183 c
7184 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7185 C to local coordinate system. Store in xx, yy, zz.
7186 c
7187         xx=0.0d0
7188         yy=0.0d0
7189         zz=0.0d0
7190         do j = 1,3
7191           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7192           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7193           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7194         enddo
7195
7196         xxtab(i)=xx
7197         yytab(i)=yy
7198         zztab(i)=zz
7199 C
7200 C Compute the energy of the ith side cbain
7201 C
7202 c        write (2,*) "xx",xx," yy",yy," zz",zz
7203         it=iabs(itype(i))
7204         do j = 1,65
7205           x(j) = sc_parmin(j,it)
7206         enddo
7207 #ifdef CHECK_COORD
7208 Cc diagnostics - remove later
7209         xx1 = dcos(alph(2))
7210         yy1 = dsin(alph(2))*dcos(omeg(2))
7211         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7212         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7213      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7214      &    xx1,yy1,zz1
7215 C,"  --- ", xx_w,yy_w,zz_w
7216 c end diagnostics
7217 #endif
7218         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7219      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7220      &   + x(10)*yy*zz
7221         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7222      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7223      & + x(20)*yy*zz
7224         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7225      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7226      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7227      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7228      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7229      &  +x(40)*xx*yy*zz
7230         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7231      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7232      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7233      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7234      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7235      &  +x(60)*xx*yy*zz
7236         dsc_i   = 0.743d0+x(61)
7237         dp2_i   = 1.9d0+x(62)
7238         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7239      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7240         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7241      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7242         s1=(1+x(63))/(0.1d0 + dscp1)
7243         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7244         s2=(1+x(65))/(0.1d0 + dscp2)
7245         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7246         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7247      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7248 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7249 c     &   sumene4,
7250 c     &   dscp1,dscp2,sumene
7251 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7252         escloc = escloc + sumene
7253 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7254 c     & ,zz,xx,yy
7255 c#define DEBUG
7256 #ifdef DEBUG
7257 C
7258 C This section to check the numerical derivatives of the energy of ith side
7259 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7260 C #define DEBUG in the code to turn it on.
7261 C
7262         write (2,*) "sumene               =",sumene
7263         aincr=1.0d-7
7264         xxsave=xx
7265         xx=xx+aincr
7266         write (2,*) xx,yy,zz
7267         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7268         de_dxx_num=(sumenep-sumene)/aincr
7269         xx=xxsave
7270         write (2,*) "xx+ sumene from enesc=",sumenep
7271         yysave=yy
7272         yy=yy+aincr
7273         write (2,*) xx,yy,zz
7274         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7275         de_dyy_num=(sumenep-sumene)/aincr
7276         yy=yysave
7277         write (2,*) "yy+ sumene from enesc=",sumenep
7278         zzsave=zz
7279         zz=zz+aincr
7280         write (2,*) xx,yy,zz
7281         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7282         de_dzz_num=(sumenep-sumene)/aincr
7283         zz=zzsave
7284         write (2,*) "zz+ sumene from enesc=",sumenep
7285         costsave=cost2tab(i+1)
7286         sintsave=sint2tab(i+1)
7287         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7288         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7289         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7290         de_dt_num=(sumenep-sumene)/aincr
7291         write (2,*) " t+ sumene from enesc=",sumenep
7292         cost2tab(i+1)=costsave
7293         sint2tab(i+1)=sintsave
7294 C End of diagnostics section.
7295 #endif
7296 C
7297 C Compute the gradient of esc
7298 C
7299 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7300         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7301         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7302         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7303         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7304         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7305         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7306         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7307         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7308         pom1=(sumene3*sint2tab(i+1)+sumene1)
7309      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7310         pom2=(sumene4*cost2tab(i+1)+sumene2)
7311      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7312         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7313         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7314      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7315      &  +x(40)*yy*zz
7316         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7317         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7318      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7319      &  +x(60)*yy*zz
7320         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7321      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7322      &        +(pom1+pom2)*pom_dx
7323 #ifdef DEBUG
7324         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7325 #endif
7326 C
7327         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7328         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7329      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7330      &  +x(40)*xx*zz
7331         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7332         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7333      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7334      &  +x(59)*zz**2 +x(60)*xx*zz
7335         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7336      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7337      &        +(pom1-pom2)*pom_dy
7338 #ifdef DEBUG
7339         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7340 #endif
7341 C
7342         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7343      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7344      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7345      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7346      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7347      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7348      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7349      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7350 #ifdef DEBUG
7351         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7352 #endif
7353 C
7354         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7355      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7356      &  +pom1*pom_dt1+pom2*pom_dt2
7357 #ifdef DEBUG
7358         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7359 #endif
7360 c#undef DEBUG
7361 c
7362 C
7363        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7364        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7365        cosfac2xx=cosfac2*xx
7366        sinfac2yy=sinfac2*yy
7367        do k = 1,3
7368          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7369      &      vbld_inv(i+1)
7370          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7371      &      vbld_inv(i)
7372          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7373          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7374 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7375 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7376 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7377 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7378          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7379          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7380          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7381          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7382          dZZ_Ci1(k)=0.0d0
7383          dZZ_Ci(k)=0.0d0
7384          do j=1,3
7385            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7386      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7387            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7388      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7389          enddo
7390
7391          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7392          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7393          dZZ_XYZ(k)=vbld_inv(i+nres)*
7394      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7395 c
7396          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7397          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7398        enddo
7399
7400        do k=1,3
7401          dXX_Ctab(k,i)=dXX_Ci(k)
7402          dXX_C1tab(k,i)=dXX_Ci1(k)
7403          dYY_Ctab(k,i)=dYY_Ci(k)
7404          dYY_C1tab(k,i)=dYY_Ci1(k)
7405          dZZ_Ctab(k,i)=dZZ_Ci(k)
7406          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7407          dXX_XYZtab(k,i)=dXX_XYZ(k)
7408          dYY_XYZtab(k,i)=dYY_XYZ(k)
7409          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7410        enddo
7411
7412        do k = 1,3
7413 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7414 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7415 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7416 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7417 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7418 c     &    dt_dci(k)
7419 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7420 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7421          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7422      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7423          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7424      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7425          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7426      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7427        enddo
7428 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7429 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7430
7431 C to check gradient call subroutine check_grad
7432
7433     1 continue
7434       enddo
7435       return
7436       end
7437 c------------------------------------------------------------------------------
7438       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7439       implicit none
7440       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7441      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7442       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7443      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7444      &   + x(10)*yy*zz
7445       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7446      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7447      & + x(20)*yy*zz
7448       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7449      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7450      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7451      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7452      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7453      &  +x(40)*xx*yy*zz
7454       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7455      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7456      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7457      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7458      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7459      &  +x(60)*xx*yy*zz
7460       dsc_i   = 0.743d0+x(61)
7461       dp2_i   = 1.9d0+x(62)
7462       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7463      &          *(xx*cost2+yy*sint2))
7464       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7465      &          *(xx*cost2-yy*sint2))
7466       s1=(1+x(63))/(0.1d0 + dscp1)
7467       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7468       s2=(1+x(65))/(0.1d0 + dscp2)
7469       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7470       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7471      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7472       enesc=sumene
7473       return
7474       end
7475 #endif
7476 c------------------------------------------------------------------------------
7477       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7478 C
7479 C This procedure calculates two-body contact function g(rij) and its derivative:
7480 C
7481 C           eps0ij                                     !       x < -1
7482 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7483 C            0                                         !       x > 1
7484 C
7485 C where x=(rij-r0ij)/delta
7486 C
7487 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7488 C
7489       implicit none
7490       double precision rij,r0ij,eps0ij,fcont,fprimcont
7491       double precision x,x2,x4,delta
7492 c     delta=0.02D0*r0ij
7493 c      delta=0.2D0*r0ij
7494       x=(rij-r0ij)/delta
7495       if (x.lt.-1.0D0) then
7496         fcont=eps0ij
7497         fprimcont=0.0D0
7498       else if (x.le.1.0D0) then
7499         x2=x*x
7500         x4=x2*x2
7501         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7502         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7503       else
7504         fcont=0.0D0
7505         fprimcont=0.0D0
7506       endif
7507       return
7508       end
7509 c------------------------------------------------------------------------------
7510       subroutine splinthet(theti,delta,ss,ssder)
7511       implicit real*8 (a-h,o-z)
7512       include 'DIMENSIONS'
7513       include 'COMMON.VAR'
7514       include 'COMMON.GEO'
7515       thetup=pi-delta
7516       thetlow=delta
7517       if (theti.gt.pipol) then
7518         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7519       else
7520         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7521         ssder=-ssder
7522       endif
7523       return
7524       end
7525 c------------------------------------------------------------------------------
7526       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7527       implicit none
7528       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7529       double precision ksi,ksi2,ksi3,a1,a2,a3
7530       a1=fprim0*delta/(f1-f0)
7531       a2=3.0d0-2.0d0*a1
7532       a3=a1-2.0d0
7533       ksi=(x-x0)/delta
7534       ksi2=ksi*ksi
7535       ksi3=ksi2*ksi
7536       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7537       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7538       return
7539       end
7540 c------------------------------------------------------------------------------
7541       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7542       implicit none
7543       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7544       double precision ksi,ksi2,ksi3,a1,a2,a3
7545       ksi=(x-x0)/delta
7546       ksi2=ksi*ksi
7547       ksi3=ksi2*ksi
7548       a1=fprim0x*delta
7549       a2=3*(f1x-f0x)-2*fprim0x*delta
7550       a3=fprim0x*delta-2*(f1x-f0x)
7551       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7552       return
7553       end
7554 C-----------------------------------------------------------------------------
7555 #ifdef CRYST_TOR
7556 C-----------------------------------------------------------------------------
7557       subroutine etor(etors,edihcnstr)
7558       implicit real*8 (a-h,o-z)
7559       include 'DIMENSIONS'
7560       include 'COMMON.VAR'
7561       include 'COMMON.GEO'
7562       include 'COMMON.LOCAL'
7563       include 'COMMON.TORSION'
7564       include 'COMMON.INTERACT'
7565       include 'COMMON.DERIV'
7566       include 'COMMON.CHAIN'
7567       include 'COMMON.NAMES'
7568       include 'COMMON.IOUNITS'
7569       include 'COMMON.FFIELD'
7570       include 'COMMON.TORCNSTR'
7571       include 'COMMON.CONTROL'
7572       logical lprn
7573 C Set lprn=.true. for debugging
7574       lprn=.false.
7575 c      lprn=.true.
7576       etors=0.0D0
7577       do i=iphi_start,iphi_end
7578       etors_ii=0.0D0
7579         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7580      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7581         itori=itortyp(itype(i-2))
7582         itori1=itortyp(itype(i-1))
7583         phii=phi(i)
7584         gloci=0.0D0
7585 C Proline-Proline pair is a special case...
7586         if (itori.eq.3 .and. itori1.eq.3) then
7587           if (phii.gt.-dwapi3) then
7588             cosphi=dcos(3*phii)
7589             fac=1.0D0/(1.0D0-cosphi)
7590             etorsi=v1(1,3,3)*fac
7591             etorsi=etorsi+etorsi
7592             etors=etors+etorsi-v1(1,3,3)
7593             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7594             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7595           endif
7596           do j=1,3
7597             v1ij=v1(j+1,itori,itori1)
7598             v2ij=v2(j+1,itori,itori1)
7599             cosphi=dcos(j*phii)
7600             sinphi=dsin(j*phii)
7601             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7602             if (energy_dec) etors_ii=etors_ii+
7603      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7604             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7605           enddo
7606         else
7607           do j=1,nterm_old
7608             v1ij=v1(j,itori,itori1)
7609             v2ij=v2(j,itori,itori1)
7610             cosphi=dcos(j*phii)
7611             sinphi=dsin(j*phii)
7612             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7613             if (energy_dec) etors_ii=etors_ii+
7614      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7615             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7616           enddo
7617         endif
7618         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7619              'etor',i,etors_ii
7620         if (lprn)
7621      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7622      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7623      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7624         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7625 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7626       enddo
7627 ! 6/20/98 - dihedral angle constraints
7628       edihcnstr=0.0d0
7629       do i=1,ndih_constr
7630         itori=idih_constr(i)
7631         phii=phi(itori)
7632         difi=phii-phi0(i)
7633         if (difi.gt.drange(i)) then
7634           difi=difi-drange(i)
7635           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7636           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7637         else if (difi.lt.-drange(i)) then
7638           difi=difi+drange(i)
7639           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7640           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7641         endif
7642 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7643 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7644       enddo
7645 !      write (iout,*) 'edihcnstr',edihcnstr
7646       return
7647       end
7648 c------------------------------------------------------------------------------
7649       subroutine etor_d(etors_d)
7650       etors_d=0.0d0
7651       return
7652       end
7653 c----------------------------------------------------------------------------
7654 #else
7655       subroutine etor(etors,edihcnstr)
7656       implicit real*8 (a-h,o-z)
7657       include 'DIMENSIONS'
7658       include 'COMMON.VAR'
7659       include 'COMMON.GEO'
7660       include 'COMMON.LOCAL'
7661       include 'COMMON.TORSION'
7662       include 'COMMON.INTERACT'
7663       include 'COMMON.DERIV'
7664       include 'COMMON.CHAIN'
7665       include 'COMMON.NAMES'
7666       include 'COMMON.IOUNITS'
7667       include 'COMMON.FFIELD'
7668       include 'COMMON.TORCNSTR'
7669       include 'COMMON.CONTROL'
7670       logical lprn
7671 C Set lprn=.true. for debugging
7672       lprn=.false.
7673 c     lprn=.true.
7674       etors=0.0D0
7675       do i=iphi_start,iphi_end
7676 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7677 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7678 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7679 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7680         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7681      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7682 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7683 C For introducing the NH3+ and COO- group please check the etor_d for reference
7684 C and guidance
7685         etors_ii=0.0D0
7686          if (iabs(itype(i)).eq.20) then
7687          iblock=2
7688          else
7689          iblock=1
7690          endif
7691         itori=itortyp(itype(i-2))
7692         itori1=itortyp(itype(i-1))
7693         phii=phi(i)
7694         gloci=0.0D0
7695 C Regular cosine and sine terms
7696         do j=1,nterm(itori,itori1,iblock)
7697           v1ij=v1(j,itori,itori1,iblock)
7698           v2ij=v2(j,itori,itori1,iblock)
7699           cosphi=dcos(j*phii)
7700           sinphi=dsin(j*phii)
7701           etors=etors+v1ij*cosphi+v2ij*sinphi
7702           if (energy_dec) etors_ii=etors_ii+
7703      &                v1ij*cosphi+v2ij*sinphi
7704           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7705         enddo
7706 C Lorentz terms
7707 C                         v1
7708 C  E = SUM ----------------------------------- - v1
7709 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7710 C
7711         cosphi=dcos(0.5d0*phii)
7712         sinphi=dsin(0.5d0*phii)
7713         do j=1,nlor(itori,itori1,iblock)
7714           vl1ij=vlor1(j,itori,itori1)
7715           vl2ij=vlor2(j,itori,itori1)
7716           vl3ij=vlor3(j,itori,itori1)
7717           pom=vl2ij*cosphi+vl3ij*sinphi
7718           pom1=1.0d0/(pom*pom+1.0d0)
7719           etors=etors+vl1ij*pom1
7720           if (energy_dec) etors_ii=etors_ii+
7721      &                vl1ij*pom1
7722           pom=-pom*pom1*pom1
7723           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7724         enddo
7725 C Subtract the constant term
7726         etors=etors-v0(itori,itori1,iblock)
7727           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7728      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7729         if (lprn)
7730      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7731      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7732      &  (v1(j,itori,itori1,iblock),j=1,6),
7733      &  (v2(j,itori,itori1,iblock),j=1,6)
7734         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7735 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7736       enddo
7737 ! 6/20/98 - dihedral angle constraints
7738       edihcnstr=0.0d0
7739 c      do i=1,ndih_constr
7740       do i=idihconstr_start,idihconstr_end
7741         itori=idih_constr(i)
7742         phii=phi(itori)
7743         difi=pinorm(phii-phi0(i))
7744         if (difi.gt.drange(i)) then
7745           difi=difi-drange(i)
7746           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7747           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7748         else if (difi.lt.-drange(i)) then
7749           difi=difi+drange(i)
7750           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7751           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7752         else
7753           difi=0.0
7754         endif
7755        if (energy_dec) then
7756         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7757      &    i,itori,rad2deg*phii,
7758      &    rad2deg*phi0(i),  rad2deg*drange(i),
7759      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7760         endif
7761       enddo
7762 cd       write (iout,*) 'edihcnstr',edihcnstr
7763       return
7764       end
7765 c----------------------------------------------------------------------------
7766       subroutine etor_d(etors_d)
7767 C 6/23/01 Compute double torsional energy
7768       implicit real*8 (a-h,o-z)
7769       include 'DIMENSIONS'
7770       include 'COMMON.VAR'
7771       include 'COMMON.GEO'
7772       include 'COMMON.LOCAL'
7773       include 'COMMON.TORSION'
7774       include 'COMMON.INTERACT'
7775       include 'COMMON.DERIV'
7776       include 'COMMON.CHAIN'
7777       include 'COMMON.NAMES'
7778       include 'COMMON.IOUNITS'
7779       include 'COMMON.FFIELD'
7780       include 'COMMON.TORCNSTR'
7781       logical lprn
7782 C Set lprn=.true. for debugging
7783       lprn=.false.
7784 c     lprn=.true.
7785       etors_d=0.0D0
7786 c      write(iout,*) "a tu??"
7787       do i=iphid_start,iphid_end
7788 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7789 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7790 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7791 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7792 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7793          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7794      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7795      &  (itype(i+1).eq.ntyp1)) cycle
7796 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7797         itori=itortyp(itype(i-2))
7798         itori1=itortyp(itype(i-1))
7799         itori2=itortyp(itype(i))
7800         phii=phi(i)
7801         phii1=phi(i+1)
7802         gloci1=0.0D0
7803         gloci2=0.0D0
7804         iblock=1
7805         if (iabs(itype(i+1)).eq.20) iblock=2
7806 C Iblock=2 Proline type
7807 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7808 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7809 C        if (itype(i+1).eq.ntyp1) iblock=3
7810 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7811 C IS or IS NOT need for this
7812 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7813 C        is (itype(i-3).eq.ntyp1) ntblock=2
7814 C        ntblock is N-terminal blocking group
7815
7816 C Regular cosine and sine terms
7817         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7818 C Example of changes for NH3+ blocking group
7819 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7820 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7821           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7822           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7823           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7824           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7825           cosphi1=dcos(j*phii)
7826           sinphi1=dsin(j*phii)
7827           cosphi2=dcos(j*phii1)
7828           sinphi2=dsin(j*phii1)
7829           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7830      &     v2cij*cosphi2+v2sij*sinphi2
7831           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7832           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7833         enddo
7834         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7835           do l=1,k-1
7836             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7837             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7838             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7839             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7840             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7841             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7842             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7843             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7844             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7845      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7846             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7847      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7848             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7849      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7850           enddo
7851         enddo
7852         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7853         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7854       enddo
7855       return
7856       end
7857 #endif
7858 C----------------------------------------------------------------------------------
7859 C The rigorous attempt to derive energy function
7860       subroutine etor_kcc(etors,edihcnstr)
7861       implicit real*8 (a-h,o-z)
7862       include 'DIMENSIONS'
7863       include 'COMMON.VAR'
7864       include 'COMMON.GEO'
7865       include 'COMMON.LOCAL'
7866       include 'COMMON.TORSION'
7867       include 'COMMON.INTERACT'
7868       include 'COMMON.DERIV'
7869       include 'COMMON.CHAIN'
7870       include 'COMMON.NAMES'
7871       include 'COMMON.IOUNITS'
7872       include 'COMMON.FFIELD'
7873       include 'COMMON.TORCNSTR'
7874       include 'COMMON.CONTROL'
7875       logical lprn
7876 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7877 C Set lprn=.true. for debugging
7878       lprn=.false.
7879 c     lprn=.true.
7880 C      print *,"wchodze kcc"
7881       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7882       if (tor_mode.ne.2) then
7883       etors=0.0D0
7884       endif
7885       do i=iphi_start,iphi_end
7886 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7887 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7888 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7889 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7890         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7891      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7892         itori=itortyp_kcc(itype(i-2))
7893         itori1=itortyp_kcc(itype(i-1))
7894         phii=phi(i)
7895         glocig=0.0D0
7896         glocit1=0.0d0
7897         glocit2=0.0d0
7898         sumnonchebyshev=0.0d0
7899         sumchebyshev=0.0d0
7900 C to avoid multiple devision by 2
7901 c        theti22=0.5d0*theta(i)
7902 C theta 12 is the theta_1 /2
7903 C theta 22 is theta_2 /2
7904 c        theti12=0.5d0*theta(i-1)
7905 C and appropriate sinus function
7906         sinthet1=dsin(theta(i-1))
7907         sinthet2=dsin(theta(i))
7908         costhet1=dcos(theta(i-1))
7909         costhet2=dcos(theta(i))
7910 c Cosines of halves thetas
7911         costheti12=0.5d0*(1.0d0+costhet1)
7912         costheti22=0.5d0*(1.0d0+costhet2)
7913 C to speed up lets store its mutliplication
7914         sint1t2=sinthet2*sinthet1
7915         sint1t2n=1.0d0
7916 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7917 C +d_n*sin(n*gamma)) *
7918 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7919 C we have two sum 1) Non-Chebyshev which is with n and gamma
7920         etori=0.0d0
7921         do j=1,nterm_kcc(itori,itori1)
7922
7923           nval=nterm_kcc_Tb(itori,itori1)
7924           v1ij=v1_kcc(j,itori,itori1)
7925           v2ij=v2_kcc(j,itori,itori1)
7926 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7927 C v1ij is c_n and d_n in euation above
7928           cosphi=dcos(j*phii)
7929           sinphi=dsin(j*phii)
7930           sint1t2n1=sint1t2n
7931           sint1t2n=sint1t2n*sint1t2
7932           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7933      &        costheti12)
7934           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7935      &        v11_chyb(1,j,itori,itori1),costheti12)
7936 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7937 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7938           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7939      &        costheti22)
7940           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7941      &        v21_chyb(1,j,itori,itori1),costheti22)
7942 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7943 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7944           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7945      &        costheti12)
7946           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7947      &        v12_chyb(1,j,itori,itori1),costheti12)
7948 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7949 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7950           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7951      &        costheti22)
7952           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7953      &        v22_chyb(1,j,itori,itori1),costheti22)
7954 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7955 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7956 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7957 C          if (energy_dec) etors_ii=etors_ii+
7958 C     &                v1ij*cosphi+v2ij*sinphi
7959 C glocig is the gradient local i site in gamma
7960           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7961           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7962           etori=etori+sint1t2n*(actval1+actval2)
7963           glocig=glocig+
7964      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7965      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7966 C now gradient over theta_1
7967           glocit1=glocit1+
7968      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7969      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7970           glocit2=glocit2+
7971      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7972      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7973
7974 C now the Czebyshev polinominal sum
7975 c        do k=1,nterm_kcc_Tb(itori,itori1)
7976 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7977 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7978 C         thybt1(k)=0.0
7979 C         thybt2(k)=0.0
7980 c        enddo
7981 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7982 C     &         gradtschebyshev
7983 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7984 C     &         dcos(theti22)**2),
7985 C     &         dsin(theti22)
7986
7987 C now overal sumation
7988 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7989         enddo ! j
7990         etors=etors+etori
7991 C derivative over gamma
7992         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7993 C derivative over theta1
7994         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7995 C now derivative over theta2
7996         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7997         if (lprn)
7998      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7999      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8000       enddo
8001 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8002 ! 6/20/98 - dihedral angle constraints
8003       if (tor_mode.ne.2) then
8004       edihcnstr=0.0d0
8005 c      do i=1,ndih_constr
8006       do i=idihconstr_start,idihconstr_end
8007         itori=idih_constr(i)
8008         phii=phi(itori)
8009         difi=pinorm(phii-phi0(i))
8010         if (difi.gt.drange(i)) then
8011           difi=difi-drange(i)
8012           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8013           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8014         else if (difi.lt.-drange(i)) then
8015           difi=difi+drange(i)
8016           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8017           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8018         else
8019           difi=0.0
8020         endif
8021        enddo
8022        endif
8023       return
8024       end
8025
8026 C The rigorous attempt to derive energy function
8027       subroutine ebend_kcc(etheta,ethetacnstr)
8028
8029       implicit real*8 (a-h,o-z)
8030       include 'DIMENSIONS'
8031       include 'COMMON.VAR'
8032       include 'COMMON.GEO'
8033       include 'COMMON.LOCAL'
8034       include 'COMMON.TORSION'
8035       include 'COMMON.INTERACT'
8036       include 'COMMON.DERIV'
8037       include 'COMMON.CHAIN'
8038       include 'COMMON.NAMES'
8039       include 'COMMON.IOUNITS'
8040       include 'COMMON.FFIELD'
8041       include 'COMMON.TORCNSTR'
8042       include 'COMMON.CONTROL'
8043       logical lprn
8044       double precision thybt1(maxtermkcc)
8045 C Set lprn=.true. for debugging
8046       lprn=.false.
8047 c     lprn=.true.
8048 C      print *,"wchodze kcc"
8049       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8050       if (tor_mode.ne.2) etheta=0.0D0
8051       do i=ithet_start,ithet_end
8052 c        print *,i,itype(i-1),itype(i),itype(i-2)
8053         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8054      &  .or.itype(i).eq.ntyp1) cycle
8055          iti=itortyp_kcc(itype(i-1))
8056         sinthet=dsin(theta(i)/2.0d0)
8057         costhet=dcos(theta(i)/2.0d0)
8058          do j=1,nbend_kcc_Tb(iti)
8059           thybt1(j)=v1bend_chyb(j,iti)
8060          enddo
8061          sumth1thyb=tschebyshev
8062      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8063         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8064      &    sumth1thyb
8065         ihelp=nbend_kcc_Tb(iti)-1
8066         gradthybt1=gradtschebyshev
8067      &         (0,ihelp,thybt1(1),costhet)
8068         etheta=etheta+sumth1thyb
8069 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8070         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8071      &   gradthybt1*sinthet*(-0.5d0)
8072       enddo
8073       if (tor_mode.ne.2) then
8074       ethetacnstr=0.0d0
8075 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8076       do i=ithetaconstr_start,ithetaconstr_end
8077         itheta=itheta_constr(i)
8078         thetiii=theta(itheta)
8079         difi=pinorm(thetiii-theta_constr0(i))
8080         if (difi.gt.theta_drange(i)) then
8081           difi=difi-theta_drange(i)
8082           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8083           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8084      &    +for_thet_constr(i)*difi**3
8085         else if (difi.lt.-drange(i)) then
8086           difi=difi+drange(i)
8087           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8088           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8089      &    +for_thet_constr(i)*difi**3
8090         else
8091           difi=0.0
8092         endif
8093        if (energy_dec) then
8094         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8095      &    i,itheta,rad2deg*thetiii,
8096      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8097      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8098      &    gloc(itheta+nphi-2,icg)
8099         endif
8100       enddo
8101       endif
8102       return
8103       end
8104 c------------------------------------------------------------------------------
8105       subroutine eback_sc_corr(esccor)
8106 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8107 c        conformational states; temporarily implemented as differences
8108 c        between UNRES torsional potentials (dependent on three types of
8109 c        residues) and the torsional potentials dependent on all 20 types
8110 c        of residues computed from AM1  energy surfaces of terminally-blocked
8111 c        amino-acid residues.
8112       implicit real*8 (a-h,o-z)
8113       include 'DIMENSIONS'
8114       include 'COMMON.VAR'
8115       include 'COMMON.GEO'
8116       include 'COMMON.LOCAL'
8117       include 'COMMON.TORSION'
8118       include 'COMMON.SCCOR'
8119       include 'COMMON.INTERACT'
8120       include 'COMMON.DERIV'
8121       include 'COMMON.CHAIN'
8122       include 'COMMON.NAMES'
8123       include 'COMMON.IOUNITS'
8124       include 'COMMON.FFIELD'
8125       include 'COMMON.CONTROL'
8126       logical lprn
8127 C Set lprn=.true. for debugging
8128       lprn=.false.
8129 c      lprn=.true.
8130 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8131       esccor=0.0D0
8132       do i=itau_start,itau_end
8133         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8134         esccor_ii=0.0D0
8135         isccori=isccortyp(itype(i-2))
8136         isccori1=isccortyp(itype(i-1))
8137 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8138         phii=phi(i)
8139         do intertyp=1,3 !intertyp
8140 cc Added 09 May 2012 (Adasko)
8141 cc  Intertyp means interaction type of backbone mainchain correlation:
8142 c   1 = SC...Ca...Ca...Ca
8143 c   2 = Ca...Ca...Ca...SC
8144 c   3 = SC...Ca...Ca...SCi
8145         gloci=0.0D0
8146         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8147      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8148      &      (itype(i-1).eq.ntyp1)))
8149      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8150      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8151      &     .or.(itype(i).eq.ntyp1)))
8152      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8153      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8154      &      (itype(i-3).eq.ntyp1)))) cycle
8155         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8156         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8157      & cycle
8158        do j=1,nterm_sccor(isccori,isccori1)
8159           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8160           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8161           cosphi=dcos(j*tauangle(intertyp,i))
8162           sinphi=dsin(j*tauangle(intertyp,i))
8163           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8164           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8165         enddo
8166 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8167         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8168         if (lprn)
8169      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8170      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8171      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8172      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8173         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8174        enddo !intertyp
8175       enddo
8176
8177       return
8178       end
8179 c----------------------------------------------------------------------------
8180       subroutine multibody(ecorr)
8181 C This subroutine calculates multi-body contributions to energy following
8182 C the idea of Skolnick et al. If side chains I and J make a contact and
8183 C at the same time side chains I+1 and J+1 make a contact, an extra
8184 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8185       implicit real*8 (a-h,o-z)
8186       include 'DIMENSIONS'
8187       include 'COMMON.IOUNITS'
8188       include 'COMMON.DERIV'
8189       include 'COMMON.INTERACT'
8190       include 'COMMON.CONTACTS'
8191       double precision gx(3),gx1(3)
8192       logical lprn
8193
8194 C Set lprn=.true. for debugging
8195       lprn=.false.
8196
8197       if (lprn) then
8198         write (iout,'(a)') 'Contact function values:'
8199         do i=nnt,nct-2
8200           write (iout,'(i2,20(1x,i2,f10.5))')
8201      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8202         enddo
8203       endif
8204       ecorr=0.0D0
8205       do i=nnt,nct
8206         do j=1,3
8207           gradcorr(j,i)=0.0D0
8208           gradxorr(j,i)=0.0D0
8209         enddo
8210       enddo
8211       do i=nnt,nct-2
8212
8213         DO ISHIFT = 3,4
8214
8215         i1=i+ishift
8216         num_conti=num_cont(i)
8217         num_conti1=num_cont(i1)
8218         do jj=1,num_conti
8219           j=jcont(jj,i)
8220           do kk=1,num_conti1
8221             j1=jcont(kk,i1)
8222             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8223 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8224 cd   &                   ' ishift=',ishift
8225 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8226 C The system gains extra energy.
8227               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8228             endif   ! j1==j+-ishift
8229           enddo     ! kk
8230         enddo       ! jj
8231
8232         ENDDO ! ISHIFT
8233
8234       enddo         ! i
8235       return
8236       end
8237 c------------------------------------------------------------------------------
8238       double precision function esccorr(i,j,k,l,jj,kk)
8239       implicit real*8 (a-h,o-z)
8240       include 'DIMENSIONS'
8241       include 'COMMON.IOUNITS'
8242       include 'COMMON.DERIV'
8243       include 'COMMON.INTERACT'
8244       include 'COMMON.CONTACTS'
8245       include 'COMMON.SHIELD'
8246       double precision gx(3),gx1(3)
8247       logical lprn
8248       lprn=.false.
8249       eij=facont(jj,i)
8250       ekl=facont(kk,k)
8251 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8252 C Calculate the multi-body contribution to energy.
8253 C Calculate multi-body contributions to the gradient.
8254 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8255 cd   & k,l,(gacont(m,kk,k),m=1,3)
8256       do m=1,3
8257         gx(m) =ekl*gacont(m,jj,i)
8258         gx1(m)=eij*gacont(m,kk,k)
8259         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8260         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8261         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8262         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8263       enddo
8264       do m=i,j-1
8265         do ll=1,3
8266           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8267         enddo
8268       enddo
8269       do m=k,l-1
8270         do ll=1,3
8271           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8272         enddo
8273       enddo
8274       esccorr=-eij*ekl
8275       return
8276       end
8277 c------------------------------------------------------------------------------
8278       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8279 C This subroutine calculates multi-body contributions to hydrogen-bonding
8280       implicit real*8 (a-h,o-z)
8281       include 'DIMENSIONS'
8282       include 'COMMON.IOUNITS'
8283 #ifdef MPI
8284       include "mpif.h"
8285       parameter (max_cont=maxconts)
8286       parameter (max_dim=26)
8287       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8288       double precision zapas(max_dim,maxconts,max_fg_procs),
8289      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8290       common /przechowalnia/ zapas
8291       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8292      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8293 #endif
8294       include 'COMMON.SETUP'
8295       include 'COMMON.FFIELD'
8296       include 'COMMON.DERIV'
8297       include 'COMMON.INTERACT'
8298       include 'COMMON.CONTACTS'
8299       include 'COMMON.CONTROL'
8300       include 'COMMON.LOCAL'
8301       double precision gx(3),gx1(3),time00
8302       logical lprn,ldone
8303
8304 C Set lprn=.true. for debugging
8305       lprn=.false.
8306 #ifdef MPI
8307       n_corr=0
8308       n_corr1=0
8309       if (nfgtasks.le.1) goto 30
8310       if (lprn) then
8311         write (iout,'(a)') 'Contact function values before RECEIVE:'
8312         do i=nnt,nct-2
8313           write (iout,'(2i3,50(1x,i2,f5.2))')
8314      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8315      &    j=1,num_cont_hb(i))
8316         enddo
8317       endif
8318       call flush(iout)
8319       do i=1,ntask_cont_from
8320         ncont_recv(i)=0
8321       enddo
8322       do i=1,ntask_cont_to
8323         ncont_sent(i)=0
8324       enddo
8325 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8326 c     & ntask_cont_to
8327 C Make the list of contacts to send to send to other procesors
8328 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8329 c      call flush(iout)
8330       do i=iturn3_start,iturn3_end
8331 c        write (iout,*) "make contact list turn3",i," num_cont",
8332 c     &    num_cont_hb(i)
8333         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8334       enddo
8335       do i=iturn4_start,iturn4_end
8336 c        write (iout,*) "make contact list turn4",i," num_cont",
8337 c     &   num_cont_hb(i)
8338         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8339       enddo
8340       do ii=1,nat_sent
8341         i=iat_sent(ii)
8342 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8343 c     &    num_cont_hb(i)
8344         do j=1,num_cont_hb(i)
8345         do k=1,4
8346           jjc=jcont_hb(j,i)
8347           iproc=iint_sent_local(k,jjc,ii)
8348 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8349           if (iproc.gt.0) then
8350             ncont_sent(iproc)=ncont_sent(iproc)+1
8351             nn=ncont_sent(iproc)
8352             zapas(1,nn,iproc)=i
8353             zapas(2,nn,iproc)=jjc
8354             zapas(3,nn,iproc)=facont_hb(j,i)
8355             zapas(4,nn,iproc)=ees0p(j,i)
8356             zapas(5,nn,iproc)=ees0m(j,i)
8357             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8358             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8359             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8360             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8361             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8362             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8363             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8364             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8365             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8366             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8367             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8368             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8369             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8370             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8371             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8372             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8373             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8374             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8375             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8376             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8377             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8378           endif
8379         enddo
8380         enddo
8381       enddo
8382       if (lprn) then
8383       write (iout,*)
8384      &  "Numbers of contacts to be sent to other processors",
8385      &  (ncont_sent(i),i=1,ntask_cont_to)
8386       write (iout,*) "Contacts sent"
8387       do ii=1,ntask_cont_to
8388         nn=ncont_sent(ii)
8389         iproc=itask_cont_to(ii)
8390         write (iout,*) nn," contacts to processor",iproc,
8391      &   " of CONT_TO_COMM group"
8392         do i=1,nn
8393           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8394         enddo
8395       enddo
8396       call flush(iout)
8397       endif
8398       CorrelType=477
8399       CorrelID=fg_rank+1
8400       CorrelType1=478
8401       CorrelID1=nfgtasks+fg_rank+1
8402       ireq=0
8403 C Receive the numbers of needed contacts from other processors
8404       do ii=1,ntask_cont_from
8405         iproc=itask_cont_from(ii)
8406         ireq=ireq+1
8407         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8408      &    FG_COMM,req(ireq),IERR)
8409       enddo
8410 c      write (iout,*) "IRECV ended"
8411 c      call flush(iout)
8412 C Send the number of contacts needed by other processors
8413       do ii=1,ntask_cont_to
8414         iproc=itask_cont_to(ii)
8415         ireq=ireq+1
8416         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8417      &    FG_COMM,req(ireq),IERR)
8418       enddo
8419 c      write (iout,*) "ISEND ended"
8420 c      write (iout,*) "number of requests (nn)",ireq
8421       call flush(iout)
8422       if (ireq.gt.0)
8423      &  call MPI_Waitall(ireq,req,status_array,ierr)
8424 c      write (iout,*)
8425 c     &  "Numbers of contacts to be received from other processors",
8426 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8427 c      call flush(iout)
8428 C Receive contacts
8429       ireq=0
8430       do ii=1,ntask_cont_from
8431         iproc=itask_cont_from(ii)
8432         nn=ncont_recv(ii)
8433 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8434 c     &   " of CONT_TO_COMM group"
8435         call flush(iout)
8436         if (nn.gt.0) then
8437           ireq=ireq+1
8438           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8439      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8440 c          write (iout,*) "ireq,req",ireq,req(ireq)
8441         endif
8442       enddo
8443 C Send the contacts to processors that need them
8444       do ii=1,ntask_cont_to
8445         iproc=itask_cont_to(ii)
8446         nn=ncont_sent(ii)
8447 c        write (iout,*) nn," contacts to processor",iproc,
8448 c     &   " of CONT_TO_COMM group"
8449         if (nn.gt.0) then
8450           ireq=ireq+1
8451           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8452      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8453 c          write (iout,*) "ireq,req",ireq,req(ireq)
8454 c          do i=1,nn
8455 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8456 c          enddo
8457         endif
8458       enddo
8459 c      write (iout,*) "number of requests (contacts)",ireq
8460 c      write (iout,*) "req",(req(i),i=1,4)
8461 c      call flush(iout)
8462       if (ireq.gt.0)
8463      & call MPI_Waitall(ireq,req,status_array,ierr)
8464       do iii=1,ntask_cont_from
8465         iproc=itask_cont_from(iii)
8466         nn=ncont_recv(iii)
8467         if (lprn) then
8468         write (iout,*) "Received",nn," contacts from processor",iproc,
8469      &   " of CONT_FROM_COMM group"
8470         call flush(iout)
8471         do i=1,nn
8472           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8473         enddo
8474         call flush(iout)
8475         endif
8476         do i=1,nn
8477           ii=zapas_recv(1,i,iii)
8478 c Flag the received contacts to prevent double-counting
8479           jj=-zapas_recv(2,i,iii)
8480 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8481 c          call flush(iout)
8482           nnn=num_cont_hb(ii)+1
8483           num_cont_hb(ii)=nnn
8484           jcont_hb(nnn,ii)=jj
8485           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8486           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8487           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8488           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8489           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8490           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8491           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8492           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8493           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8494           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8495           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8496           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8497           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8498           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8499           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8500           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8501           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8502           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8503           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8504           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8505           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8506           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8507           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8508           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8509         enddo
8510       enddo
8511       call flush(iout)
8512       if (lprn) then
8513         write (iout,'(a)') 'Contact function values after receive:'
8514         do i=nnt,nct-2
8515           write (iout,'(2i3,50(1x,i3,f5.2))')
8516      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8517      &    j=1,num_cont_hb(i))
8518         enddo
8519         call flush(iout)
8520       endif
8521    30 continue
8522 #endif
8523       if (lprn) then
8524         write (iout,'(a)') 'Contact function values:'
8525         do i=nnt,nct-2
8526           write (iout,'(2i3,50(1x,i3,f5.2))')
8527      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8528      &    j=1,num_cont_hb(i))
8529         enddo
8530       endif
8531       ecorr=0.0D0
8532 C Remove the loop below after debugging !!!
8533       do i=nnt,nct
8534         do j=1,3
8535           gradcorr(j,i)=0.0D0
8536           gradxorr(j,i)=0.0D0
8537         enddo
8538       enddo
8539 C Calculate the local-electrostatic correlation terms
8540       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8541         i1=i+1
8542         num_conti=num_cont_hb(i)
8543         num_conti1=num_cont_hb(i+1)
8544         do jj=1,num_conti
8545           j=jcont_hb(jj,i)
8546           jp=iabs(j)
8547           do kk=1,num_conti1
8548             j1=jcont_hb(kk,i1)
8549             jp1=iabs(j1)
8550 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8551 c     &         ' jj=',jj,' kk=',kk
8552             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8553      &          .or. j.lt.0 .and. j1.gt.0) .and.
8554      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8555 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8556 C The system gains extra energy.
8557               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8558               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8559      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8560               n_corr=n_corr+1
8561             else if (j1.eq.j) then
8562 C Contacts I-J and I-(J+1) occur simultaneously.
8563 C The system loses extra energy.
8564 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8565             endif
8566           enddo ! kk
8567           do kk=1,num_conti
8568             j1=jcont_hb(kk,i)
8569 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8570 c    &         ' jj=',jj,' kk=',kk
8571             if (j1.eq.j+1) then
8572 C Contacts I-J and (I+1)-J occur simultaneously.
8573 C The system loses extra energy.
8574 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8575             endif ! j1==j+1
8576           enddo ! kk
8577         enddo ! jj
8578       enddo ! i
8579       return
8580       end
8581 c------------------------------------------------------------------------------
8582       subroutine add_hb_contact(ii,jj,itask)
8583       implicit real*8 (a-h,o-z)
8584       include "DIMENSIONS"
8585       include "COMMON.IOUNITS"
8586       integer max_cont
8587       integer max_dim
8588       parameter (max_cont=maxconts)
8589       parameter (max_dim=26)
8590       include "COMMON.CONTACTS"
8591       double precision zapas(max_dim,maxconts,max_fg_procs),
8592      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8593       common /przechowalnia/ zapas
8594       integer i,j,ii,jj,iproc,itask(4),nn
8595 c      write (iout,*) "itask",itask
8596       do i=1,2
8597         iproc=itask(i)
8598         if (iproc.gt.0) then
8599           do j=1,num_cont_hb(ii)
8600             jjc=jcont_hb(j,ii)
8601 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8602             if (jjc.eq.jj) then
8603               ncont_sent(iproc)=ncont_sent(iproc)+1
8604               nn=ncont_sent(iproc)
8605               zapas(1,nn,iproc)=ii
8606               zapas(2,nn,iproc)=jjc
8607               zapas(3,nn,iproc)=facont_hb(j,ii)
8608               zapas(4,nn,iproc)=ees0p(j,ii)
8609               zapas(5,nn,iproc)=ees0m(j,ii)
8610               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8611               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8612               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8613               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8614               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8615               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8616               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8617               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8618               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8619               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8620               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8621               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8622               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8623               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8624               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8625               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8626               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8627               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8628               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8629               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8630               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8631               exit
8632             endif
8633           enddo
8634         endif
8635       enddo
8636       return
8637       end
8638 c------------------------------------------------------------------------------
8639       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8640      &  n_corr1)
8641 C This subroutine calculates multi-body contributions to hydrogen-bonding
8642       implicit real*8 (a-h,o-z)
8643       include 'DIMENSIONS'
8644       include 'COMMON.IOUNITS'
8645 #ifdef MPI
8646       include "mpif.h"
8647       parameter (max_cont=maxconts)
8648       parameter (max_dim=70)
8649       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8650       double precision zapas(max_dim,maxconts,max_fg_procs),
8651      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8652       common /przechowalnia/ zapas
8653       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8654      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8655 #endif
8656       include 'COMMON.SETUP'
8657       include 'COMMON.FFIELD'
8658       include 'COMMON.DERIV'
8659       include 'COMMON.LOCAL'
8660       include 'COMMON.INTERACT'
8661       include 'COMMON.CONTACTS'
8662       include 'COMMON.CHAIN'
8663       include 'COMMON.CONTROL'
8664       include 'COMMON.SHIELD'
8665       double precision gx(3),gx1(3)
8666       integer num_cont_hb_old(maxres)
8667       logical lprn,ldone
8668       double precision eello4,eello5,eelo6,eello_turn6
8669       external eello4,eello5,eello6,eello_turn6
8670 C Set lprn=.true. for debugging
8671       lprn=.false.
8672       eturn6=0.0d0
8673 #ifdef MPI
8674       do i=1,nres
8675         num_cont_hb_old(i)=num_cont_hb(i)
8676       enddo
8677       n_corr=0
8678       n_corr1=0
8679       if (nfgtasks.le.1) goto 30
8680       if (lprn) then
8681         write (iout,'(a)') 'Contact function values before RECEIVE:'
8682         do i=nnt,nct-2
8683           write (iout,'(2i3,50(1x,i2,f5.2))')
8684      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8685      &    j=1,num_cont_hb(i))
8686         enddo
8687       endif
8688       call flush(iout)
8689       do i=1,ntask_cont_from
8690         ncont_recv(i)=0
8691       enddo
8692       do i=1,ntask_cont_to
8693         ncont_sent(i)=0
8694       enddo
8695 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8696 c     & ntask_cont_to
8697 C Make the list of contacts to send to send to other procesors
8698       do i=iturn3_start,iturn3_end
8699 c        write (iout,*) "make contact list turn3",i," num_cont",
8700 c     &    num_cont_hb(i)
8701         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8702       enddo
8703       do i=iturn4_start,iturn4_end
8704 c        write (iout,*) "make contact list turn4",i," num_cont",
8705 c     &   num_cont_hb(i)
8706         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8707       enddo
8708       do ii=1,nat_sent
8709         i=iat_sent(ii)
8710 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8711 c     &    num_cont_hb(i)
8712         do j=1,num_cont_hb(i)
8713         do k=1,4
8714           jjc=jcont_hb(j,i)
8715           iproc=iint_sent_local(k,jjc,ii)
8716 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8717           if (iproc.ne.0) then
8718             ncont_sent(iproc)=ncont_sent(iproc)+1
8719             nn=ncont_sent(iproc)
8720             zapas(1,nn,iproc)=i
8721             zapas(2,nn,iproc)=jjc
8722             zapas(3,nn,iproc)=d_cont(j,i)
8723             ind=3
8724             do kk=1,3
8725               ind=ind+1
8726               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8727             enddo
8728             do kk=1,2
8729               do ll=1,2
8730                 ind=ind+1
8731                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8732               enddo
8733             enddo
8734             do jj=1,5
8735               do kk=1,3
8736                 do ll=1,2
8737                   do mm=1,2
8738                     ind=ind+1
8739                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8740                   enddo
8741                 enddo
8742               enddo
8743             enddo
8744           endif
8745         enddo
8746         enddo
8747       enddo
8748       if (lprn) then
8749       write (iout,*)
8750      &  "Numbers of contacts to be sent to other processors",
8751      &  (ncont_sent(i),i=1,ntask_cont_to)
8752       write (iout,*) "Contacts sent"
8753       do ii=1,ntask_cont_to
8754         nn=ncont_sent(ii)
8755         iproc=itask_cont_to(ii)
8756         write (iout,*) nn," contacts to processor",iproc,
8757      &   " of CONT_TO_COMM group"
8758         do i=1,nn
8759           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8760         enddo
8761       enddo
8762       call flush(iout)
8763       endif
8764       CorrelType=477
8765       CorrelID=fg_rank+1
8766       CorrelType1=478
8767       CorrelID1=nfgtasks+fg_rank+1
8768       ireq=0
8769 C Receive the numbers of needed contacts from other processors
8770       do ii=1,ntask_cont_from
8771         iproc=itask_cont_from(ii)
8772         ireq=ireq+1
8773         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8774      &    FG_COMM,req(ireq),IERR)
8775       enddo
8776 c      write (iout,*) "IRECV ended"
8777 c      call flush(iout)
8778 C Send the number of contacts needed by other processors
8779       do ii=1,ntask_cont_to
8780         iproc=itask_cont_to(ii)
8781         ireq=ireq+1
8782         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8783      &    FG_COMM,req(ireq),IERR)
8784       enddo
8785 c      write (iout,*) "ISEND ended"
8786 c      write (iout,*) "number of requests (nn)",ireq
8787       call flush(iout)
8788       if (ireq.gt.0)
8789      &  call MPI_Waitall(ireq,req,status_array,ierr)
8790 c      write (iout,*)
8791 c     &  "Numbers of contacts to be received from other processors",
8792 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8793 c      call flush(iout)
8794 C Receive contacts
8795       ireq=0
8796       do ii=1,ntask_cont_from
8797         iproc=itask_cont_from(ii)
8798         nn=ncont_recv(ii)
8799 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8800 c     &   " of CONT_TO_COMM group"
8801         call flush(iout)
8802         if (nn.gt.0) then
8803           ireq=ireq+1
8804           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8805      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8806 c          write (iout,*) "ireq,req",ireq,req(ireq)
8807         endif
8808       enddo
8809 C Send the contacts to processors that need them
8810       do ii=1,ntask_cont_to
8811         iproc=itask_cont_to(ii)
8812         nn=ncont_sent(ii)
8813 c        write (iout,*) nn," contacts to processor",iproc,
8814 c     &   " of CONT_TO_COMM group"
8815         if (nn.gt.0) then
8816           ireq=ireq+1
8817           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8818      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8819 c          write (iout,*) "ireq,req",ireq,req(ireq)
8820 c          do i=1,nn
8821 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8822 c          enddo
8823         endif
8824       enddo
8825 c      write (iout,*) "number of requests (contacts)",ireq
8826 c      write (iout,*) "req",(req(i),i=1,4)
8827 c      call flush(iout)
8828       if (ireq.gt.0)
8829      & call MPI_Waitall(ireq,req,status_array,ierr)
8830       do iii=1,ntask_cont_from
8831         iproc=itask_cont_from(iii)
8832         nn=ncont_recv(iii)
8833         if (lprn) then
8834         write (iout,*) "Received",nn," contacts from processor",iproc,
8835      &   " of CONT_FROM_COMM group"
8836         call flush(iout)
8837         do i=1,nn
8838           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8839         enddo
8840         call flush(iout)
8841         endif
8842         do i=1,nn
8843           ii=zapas_recv(1,i,iii)
8844 c Flag the received contacts to prevent double-counting
8845           jj=-zapas_recv(2,i,iii)
8846 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8847 c          call flush(iout)
8848           nnn=num_cont_hb(ii)+1
8849           num_cont_hb(ii)=nnn
8850           jcont_hb(nnn,ii)=jj
8851           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8852           ind=3
8853           do kk=1,3
8854             ind=ind+1
8855             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8856           enddo
8857           do kk=1,2
8858             do ll=1,2
8859               ind=ind+1
8860               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8861             enddo
8862           enddo
8863           do jj=1,5
8864             do kk=1,3
8865               do ll=1,2
8866                 do mm=1,2
8867                   ind=ind+1
8868                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8869                 enddo
8870               enddo
8871             enddo
8872           enddo
8873         enddo
8874       enddo
8875       call flush(iout)
8876       if (lprn) then
8877         write (iout,'(a)') 'Contact function values after receive:'
8878         do i=nnt,nct-2
8879           write (iout,'(2i3,50(1x,i3,5f6.3))')
8880      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8881      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8882         enddo
8883         call flush(iout)
8884       endif
8885    30 continue
8886 #endif
8887       if (lprn) then
8888         write (iout,'(a)') 'Contact function values:'
8889         do i=nnt,nct-2
8890           write (iout,'(2i3,50(1x,i2,5f6.3))')
8891      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8892      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8893         enddo
8894       endif
8895       ecorr=0.0D0
8896       ecorr5=0.0d0
8897       ecorr6=0.0d0
8898 C Remove the loop below after debugging !!!
8899       do i=nnt,nct
8900         do j=1,3
8901           gradcorr(j,i)=0.0D0
8902           gradxorr(j,i)=0.0D0
8903         enddo
8904       enddo
8905 C Calculate the dipole-dipole interaction energies
8906       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8907       do i=iatel_s,iatel_e+1
8908         num_conti=num_cont_hb(i)
8909         do jj=1,num_conti
8910           j=jcont_hb(jj,i)
8911 #ifdef MOMENT
8912           call dipole(i,j,jj)
8913 #endif
8914         enddo
8915       enddo
8916       endif
8917 C Calculate the local-electrostatic correlation terms
8918 c                write (iout,*) "gradcorr5 in eello5 before loop"
8919 c                do iii=1,nres
8920 c                  write (iout,'(i5,3f10.5)')
8921 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8922 c                enddo
8923       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8924 c        write (iout,*) "corr loop i",i
8925         i1=i+1
8926         num_conti=num_cont_hb(i)
8927         num_conti1=num_cont_hb(i+1)
8928         do jj=1,num_conti
8929           j=jcont_hb(jj,i)
8930           jp=iabs(j)
8931           do kk=1,num_conti1
8932             j1=jcont_hb(kk,i1)
8933             jp1=iabs(j1)
8934 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8935 c     &         ' jj=',jj,' kk=',kk
8936 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8937             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8938      &          .or. j.lt.0 .and. j1.gt.0) .and.
8939      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8940 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8941 C The system gains extra energy.
8942               n_corr=n_corr+1
8943               sqd1=dsqrt(d_cont(jj,i))
8944               sqd2=dsqrt(d_cont(kk,i1))
8945               sred_geom = sqd1*sqd2
8946               IF (sred_geom.lt.cutoff_corr) THEN
8947                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8948      &            ekont,fprimcont)
8949 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8950 cd     &         ' jj=',jj,' kk=',kk
8951                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8952                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8953                 do l=1,3
8954                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8955                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8956                 enddo
8957                 n_corr1=n_corr1+1
8958 cd               write (iout,*) 'sred_geom=',sred_geom,
8959 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8960 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8961 cd               write (iout,*) "g_contij",g_contij
8962 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8963 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8964                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8965                 if (wcorr4.gt.0.0d0)
8966      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8967 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8968                   if (energy_dec.and.wcorr4.gt.0.0d0)
8969      1                 write (iout,'(a6,4i5,0pf7.3)')
8970      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8971 c                write (iout,*) "gradcorr5 before eello5"
8972 c                do iii=1,nres
8973 c                  write (iout,'(i5,3f10.5)')
8974 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8975 c                enddo
8976                 if (wcorr5.gt.0.0d0)
8977      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8978 c                write (iout,*) "gradcorr5 after eello5"
8979 c                do iii=1,nres
8980 c                  write (iout,'(i5,3f10.5)')
8981 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8982 c                enddo
8983                   if (energy_dec.and.wcorr5.gt.0.0d0)
8984      1                 write (iout,'(a6,4i5,0pf7.3)')
8985      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8986 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8987 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8988                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8989      &               .or. wturn6.eq.0.0d0))then
8990 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8991                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8992                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8993      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8994 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8995 cd     &            'ecorr6=',ecorr6
8996 cd                write (iout,'(4e15.5)') sred_geom,
8997 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8998 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8999 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9000                 else if (wturn6.gt.0.0d0
9001      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9002 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9003                   eturn6=eturn6+eello_turn6(i,jj,kk)
9004                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9005      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9006 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9007                 endif
9008               ENDIF
9009 1111          continue
9010             endif
9011           enddo ! kk
9012         enddo ! jj
9013       enddo ! i
9014       do i=1,nres
9015         num_cont_hb(i)=num_cont_hb_old(i)
9016       enddo
9017 c                write (iout,*) "gradcorr5 in eello5"
9018 c                do iii=1,nres
9019 c                  write (iout,'(i5,3f10.5)')
9020 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9021 c                enddo
9022       return
9023       end
9024 c------------------------------------------------------------------------------
9025       subroutine add_hb_contact_eello(ii,jj,itask)
9026       implicit real*8 (a-h,o-z)
9027       include "DIMENSIONS"
9028       include "COMMON.IOUNITS"
9029       integer max_cont
9030       integer max_dim
9031       parameter (max_cont=maxconts)
9032       parameter (max_dim=70)
9033       include "COMMON.CONTACTS"
9034       double precision zapas(max_dim,maxconts,max_fg_procs),
9035      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9036       common /przechowalnia/ zapas
9037       integer i,j,ii,jj,iproc,itask(4),nn
9038 c      write (iout,*) "itask",itask
9039       do i=1,2
9040         iproc=itask(i)
9041         if (iproc.gt.0) then
9042           do j=1,num_cont_hb(ii)
9043             jjc=jcont_hb(j,ii)
9044 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9045             if (jjc.eq.jj) then
9046               ncont_sent(iproc)=ncont_sent(iproc)+1
9047               nn=ncont_sent(iproc)
9048               zapas(1,nn,iproc)=ii
9049               zapas(2,nn,iproc)=jjc
9050               zapas(3,nn,iproc)=d_cont(j,ii)
9051               ind=3
9052               do kk=1,3
9053                 ind=ind+1
9054                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9055               enddo
9056               do kk=1,2
9057                 do ll=1,2
9058                   ind=ind+1
9059                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9060                 enddo
9061               enddo
9062               do jj=1,5
9063                 do kk=1,3
9064                   do ll=1,2
9065                     do mm=1,2
9066                       ind=ind+1
9067                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9068                     enddo
9069                   enddo
9070                 enddo
9071               enddo
9072               exit
9073             endif
9074           enddo
9075         endif
9076       enddo
9077       return
9078       end
9079 c------------------------------------------------------------------------------
9080       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9081       implicit real*8 (a-h,o-z)
9082       include 'DIMENSIONS'
9083       include 'COMMON.IOUNITS'
9084       include 'COMMON.DERIV'
9085       include 'COMMON.INTERACT'
9086       include 'COMMON.CONTACTS'
9087       include 'COMMON.SHIELD'
9088       include 'COMMON.CONTROL'
9089       double precision gx(3),gx1(3)
9090       logical lprn
9091       lprn=.false.
9092 C      print *,"wchodze",fac_shield(i),shield_mode
9093       eij=facont_hb(jj,i)
9094       ekl=facont_hb(kk,k)
9095       ees0pij=ees0p(jj,i)
9096       ees0pkl=ees0p(kk,k)
9097       ees0mij=ees0m(jj,i)
9098       ees0mkl=ees0m(kk,k)
9099       ekont=eij*ekl
9100       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9101 C*
9102 C     & fac_shield(i)**2*fac_shield(j)**2
9103 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9104 C Following 4 lines for diagnostics.
9105 cd    ees0pkl=0.0D0
9106 cd    ees0pij=1.0D0
9107 cd    ees0mkl=0.0D0
9108 cd    ees0mij=1.0D0
9109 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9110 c     & 'Contacts ',i,j,
9111 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9112 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9113 c     & 'gradcorr_long'
9114 C Calculate the multi-body contribution to energy.
9115 C      ecorr=ecorr+ekont*ees
9116 C Calculate multi-body contributions to the gradient.
9117       coeffpees0pij=coeffp*ees0pij
9118       coeffmees0mij=coeffm*ees0mij
9119       coeffpees0pkl=coeffp*ees0pkl
9120       coeffmees0mkl=coeffm*ees0mkl
9121       do ll=1,3
9122 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9123         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9124      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9125      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9126         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9127      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9128      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9129 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9130         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9131      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9132      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9133         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9134      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9135      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9136         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9137      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9138      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9139         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9140         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9141         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9142      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9143      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9144         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9145         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9146 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9147       enddo
9148 c      write (iout,*)
9149 cgrad      do m=i+1,j-1
9150 cgrad        do ll=1,3
9151 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9152 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9153 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9154 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9155 cgrad        enddo
9156 cgrad      enddo
9157 cgrad      do m=k+1,l-1
9158 cgrad        do ll=1,3
9159 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9160 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9161 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9162 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9163 cgrad        enddo
9164 cgrad      enddo
9165 c      write (iout,*) "ehbcorr",ekont*ees
9166 C      print *,ekont,ees,i,k
9167       ehbcorr=ekont*ees
9168 C now gradient over shielding
9169 C      return
9170       if (shield_mode.gt.0) then
9171        j=ees0plist(jj,i)
9172        l=ees0plist(kk,k)
9173 C        print *,i,j,fac_shield(i),fac_shield(j),
9174 C     &fac_shield(k),fac_shield(l)
9175         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9176      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9177           do ilist=1,ishield_list(i)
9178            iresshield=shield_list(ilist,i)
9179            do m=1,3
9180            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9181 C     &      *2.0
9182            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9183      &              rlocshield
9184      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9185             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9186      &+rlocshield
9187            enddo
9188           enddo
9189           do ilist=1,ishield_list(j)
9190            iresshield=shield_list(ilist,j)
9191            do m=1,3
9192            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9193 C     &     *2.0
9194            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9195      &              rlocshield
9196      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9197            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9198      &     +rlocshield
9199            enddo
9200           enddo
9201
9202           do ilist=1,ishield_list(k)
9203            iresshield=shield_list(ilist,k)
9204            do m=1,3
9205            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9206 C     &     *2.0
9207            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9208      &              rlocshield
9209      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9210            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9211      &     +rlocshield
9212            enddo
9213           enddo
9214           do ilist=1,ishield_list(l)
9215            iresshield=shield_list(ilist,l)
9216            do m=1,3
9217            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9218 C     &     *2.0
9219            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9220      &              rlocshield
9221      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9222            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9223      &     +rlocshield
9224            enddo
9225           enddo
9226 C          print *,gshieldx(m,iresshield)
9227           do m=1,3
9228             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9229      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9230             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9231      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9232             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9233      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9234             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9235      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9236
9237             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9238      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9239             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9240      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9241             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9242      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9243             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9244      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9245
9246            enddo
9247       endif
9248       endif
9249       return
9250       end
9251 #ifdef MOMENT
9252 C---------------------------------------------------------------------------
9253       subroutine dipole(i,j,jj)
9254       implicit real*8 (a-h,o-z)
9255       include 'DIMENSIONS'
9256       include 'COMMON.IOUNITS'
9257       include 'COMMON.CHAIN'
9258       include 'COMMON.FFIELD'
9259       include 'COMMON.DERIV'
9260       include 'COMMON.INTERACT'
9261       include 'COMMON.CONTACTS'
9262       include 'COMMON.TORSION'
9263       include 'COMMON.VAR'
9264       include 'COMMON.GEO'
9265       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9266      &  auxmat(2,2)
9267       iti1 = itortyp(itype(i+1))
9268       if (j.lt.nres-1) then
9269         itj1 = itype2loc(itype(j+1))
9270       else
9271         itj1=nloctyp
9272       endif
9273       do iii=1,2
9274         dipi(iii,1)=Ub2(iii,i)
9275         dipderi(iii)=Ub2der(iii,i)
9276         dipi(iii,2)=b1(iii,i+1)
9277         dipj(iii,1)=Ub2(iii,j)
9278         dipderj(iii)=Ub2der(iii,j)
9279         dipj(iii,2)=b1(iii,j+1)
9280       enddo
9281       kkk=0
9282       do iii=1,2
9283         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9284         do jjj=1,2
9285           kkk=kkk+1
9286           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9287         enddo
9288       enddo
9289       do kkk=1,5
9290         do lll=1,3
9291           mmm=0
9292           do iii=1,2
9293             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9294      &        auxvec(1))
9295             do jjj=1,2
9296               mmm=mmm+1
9297               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9298             enddo
9299           enddo
9300         enddo
9301       enddo
9302       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9303       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9304       do iii=1,2
9305         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9306       enddo
9307       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9308       do iii=1,2
9309         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9310       enddo
9311       return
9312       end
9313 #endif
9314 C---------------------------------------------------------------------------
9315       subroutine calc_eello(i,j,k,l,jj,kk)
9316 C
9317 C This subroutine computes matrices and vectors needed to calculate
9318 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9319 C
9320       implicit real*8 (a-h,o-z)
9321       include 'DIMENSIONS'
9322       include 'COMMON.IOUNITS'
9323       include 'COMMON.CHAIN'
9324       include 'COMMON.DERIV'
9325       include 'COMMON.INTERACT'
9326       include 'COMMON.CONTACTS'
9327       include 'COMMON.TORSION'
9328       include 'COMMON.VAR'
9329       include 'COMMON.GEO'
9330       include 'COMMON.FFIELD'
9331       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9332      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9333       logical lprn
9334       common /kutas/ lprn
9335 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9336 cd     & ' jj=',jj,' kk=',kk
9337 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9338 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9339 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9340       do iii=1,2
9341         do jjj=1,2
9342           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9343           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9344         enddo
9345       enddo
9346       call transpose2(aa1(1,1),aa1t(1,1))
9347       call transpose2(aa2(1,1),aa2t(1,1))
9348       do kkk=1,5
9349         do lll=1,3
9350           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9351      &      aa1tder(1,1,lll,kkk))
9352           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9353      &      aa2tder(1,1,lll,kkk))
9354         enddo
9355       enddo
9356       if (l.eq.j+1) then
9357 C parallel orientation of the two CA-CA-CA frames.
9358         if (i.gt.1) then
9359           iti=itype2loc(itype(i))
9360         else
9361           iti=nloctyp
9362         endif
9363         itk1=itype2loc(itype(k+1))
9364         itj=itype2loc(itype(j))
9365         if (l.lt.nres-1) then
9366           itl1=itype2loc(itype(l+1))
9367         else
9368           itl1=nloctyp
9369         endif
9370 C A1 kernel(j+1) A2T
9371 cd        do iii=1,2
9372 cd          write (iout,'(3f10.5,5x,3f10.5)')
9373 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9374 cd        enddo
9375         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9376      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9377      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9378 C Following matrices are needed only for 6-th order cumulants
9379         IF (wcorr6.gt.0.0d0) THEN
9380         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9381      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9382      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9383         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9384      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9385      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9386      &   ADtEAderx(1,1,1,1,1,1))
9387         lprn=.false.
9388         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9389      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9390      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9391      &   ADtEA1derx(1,1,1,1,1,1))
9392         ENDIF
9393 C End 6-th order cumulants
9394 cd        lprn=.false.
9395 cd        if (lprn) then
9396 cd        write (2,*) 'In calc_eello6'
9397 cd        do iii=1,2
9398 cd          write (2,*) 'iii=',iii
9399 cd          do kkk=1,5
9400 cd            write (2,*) 'kkk=',kkk
9401 cd            do jjj=1,2
9402 cd              write (2,'(3(2f10.5),5x)')
9403 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9404 cd            enddo
9405 cd          enddo
9406 cd        enddo
9407 cd        endif
9408         call transpose2(EUgder(1,1,k),auxmat(1,1))
9409         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9410         call transpose2(EUg(1,1,k),auxmat(1,1))
9411         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9412         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9413         do iii=1,2
9414           do kkk=1,5
9415             do lll=1,3
9416               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9417      &          EAEAderx(1,1,lll,kkk,iii,1))
9418             enddo
9419           enddo
9420         enddo
9421 C A1T kernel(i+1) A2
9422         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9423      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9424      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9425 C Following matrices are needed only for 6-th order cumulants
9426         IF (wcorr6.gt.0.0d0) THEN
9427         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9428      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9429      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9430         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9431      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9432      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9433      &   ADtEAderx(1,1,1,1,1,2))
9434         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9435      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9436      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9437      &   ADtEA1derx(1,1,1,1,1,2))
9438         ENDIF
9439 C End 6-th order cumulants
9440         call transpose2(EUgder(1,1,l),auxmat(1,1))
9441         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9442         call transpose2(EUg(1,1,l),auxmat(1,1))
9443         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9444         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9445         do iii=1,2
9446           do kkk=1,5
9447             do lll=1,3
9448               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9449      &          EAEAderx(1,1,lll,kkk,iii,2))
9450             enddo
9451           enddo
9452         enddo
9453 C AEAb1 and AEAb2
9454 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9455 C They are needed only when the fifth- or the sixth-order cumulants are
9456 C indluded.
9457         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9458         call transpose2(AEA(1,1,1),auxmat(1,1))
9459         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9460         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9461         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9462         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9463         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9464         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9465         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9466         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9467         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9468         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9469         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9470         call transpose2(AEA(1,1,2),auxmat(1,1))
9471         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9472         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9473         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9474         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9475         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9476         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9477         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9478         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9479         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9480         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9481         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9482 C Calculate the Cartesian derivatives of the vectors.
9483         do iii=1,2
9484           do kkk=1,5
9485             do lll=1,3
9486               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9487               call matvec2(auxmat(1,1),b1(1,i),
9488      &          AEAb1derx(1,lll,kkk,iii,1,1))
9489               call matvec2(auxmat(1,1),Ub2(1,i),
9490      &          AEAb2derx(1,lll,kkk,iii,1,1))
9491               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9492      &          AEAb1derx(1,lll,kkk,iii,2,1))
9493               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9494      &          AEAb2derx(1,lll,kkk,iii,2,1))
9495               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9496               call matvec2(auxmat(1,1),b1(1,j),
9497      &          AEAb1derx(1,lll,kkk,iii,1,2))
9498               call matvec2(auxmat(1,1),Ub2(1,j),
9499      &          AEAb2derx(1,lll,kkk,iii,1,2))
9500               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9501      &          AEAb1derx(1,lll,kkk,iii,2,2))
9502               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9503      &          AEAb2derx(1,lll,kkk,iii,2,2))
9504             enddo
9505           enddo
9506         enddo
9507         ENDIF
9508 C End vectors
9509       else
9510 C Antiparallel orientation of the two CA-CA-CA frames.
9511         if (i.gt.1) then
9512           iti=itype2loc(itype(i))
9513         else
9514           iti=nloctyp
9515         endif
9516         itk1=itype2loc(itype(k+1))
9517         itl=itype2loc(itype(l))
9518         itj=itype2loc(itype(j))
9519         if (j.lt.nres-1) then
9520           itj1=itype2loc(itype(j+1))
9521         else
9522           itj1=nloctyp
9523         endif
9524 C A2 kernel(j-1)T A1T
9525         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9526      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9527      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9528 C Following matrices are needed only for 6-th order cumulants
9529         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9530      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9531         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9532      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9533      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9534         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9535      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9536      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9537      &   ADtEAderx(1,1,1,1,1,1))
9538         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9539      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9540      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9541      &   ADtEA1derx(1,1,1,1,1,1))
9542         ENDIF
9543 C End 6-th order cumulants
9544         call transpose2(EUgder(1,1,k),auxmat(1,1))
9545         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9546         call transpose2(EUg(1,1,k),auxmat(1,1))
9547         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9548         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9549         do iii=1,2
9550           do kkk=1,5
9551             do lll=1,3
9552               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9553      &          EAEAderx(1,1,lll,kkk,iii,1))
9554             enddo
9555           enddo
9556         enddo
9557 C A2T kernel(i+1)T A1
9558         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9559      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9560      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9561 C Following matrices are needed only for 6-th order cumulants
9562         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9563      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9564         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9565      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9566      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9567         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9568      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9569      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9570      &   ADtEAderx(1,1,1,1,1,2))
9571         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9572      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9573      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9574      &   ADtEA1derx(1,1,1,1,1,2))
9575         ENDIF
9576 C End 6-th order cumulants
9577         call transpose2(EUgder(1,1,j),auxmat(1,1))
9578         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9579         call transpose2(EUg(1,1,j),auxmat(1,1))
9580         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9581         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9582         do iii=1,2
9583           do kkk=1,5
9584             do lll=1,3
9585               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9586      &          EAEAderx(1,1,lll,kkk,iii,2))
9587             enddo
9588           enddo
9589         enddo
9590 C AEAb1 and AEAb2
9591 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9592 C They are needed only when the fifth- or the sixth-order cumulants are
9593 C indluded.
9594         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9595      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9596         call transpose2(AEA(1,1,1),auxmat(1,1))
9597         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9598         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9599         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9600         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9601         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9602         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9603         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9604         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9605         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9606         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9607         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9608         call transpose2(AEA(1,1,2),auxmat(1,1))
9609         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9610         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9611         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9612         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9613         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9614         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9615         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9616         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9617         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9618         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9619         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9620 C Calculate the Cartesian derivatives of the vectors.
9621         do iii=1,2
9622           do kkk=1,5
9623             do lll=1,3
9624               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9625               call matvec2(auxmat(1,1),b1(1,i),
9626      &          AEAb1derx(1,lll,kkk,iii,1,1))
9627               call matvec2(auxmat(1,1),Ub2(1,i),
9628      &          AEAb2derx(1,lll,kkk,iii,1,1))
9629               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9630      &          AEAb1derx(1,lll,kkk,iii,2,1))
9631               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9632      &          AEAb2derx(1,lll,kkk,iii,2,1))
9633               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9634               call matvec2(auxmat(1,1),b1(1,l),
9635      &          AEAb1derx(1,lll,kkk,iii,1,2))
9636               call matvec2(auxmat(1,1),Ub2(1,l),
9637      &          AEAb2derx(1,lll,kkk,iii,1,2))
9638               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9639      &          AEAb1derx(1,lll,kkk,iii,2,2))
9640               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9641      &          AEAb2derx(1,lll,kkk,iii,2,2))
9642             enddo
9643           enddo
9644         enddo
9645         ENDIF
9646 C End vectors
9647       endif
9648       return
9649       end
9650 C---------------------------------------------------------------------------
9651       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9652      &  KK,KKderg,AKA,AKAderg,AKAderx)
9653       implicit none
9654       integer nderg
9655       logical transp
9656       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9657      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9658      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9659       integer iii,kkk,lll
9660       integer jjj,mmm
9661       logical lprn
9662       common /kutas/ lprn
9663       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9664       do iii=1,nderg
9665         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9666      &    AKAderg(1,1,iii))
9667       enddo
9668 cd      if (lprn) write (2,*) 'In kernel'
9669       do kkk=1,5
9670 cd        if (lprn) write (2,*) 'kkk=',kkk
9671         do lll=1,3
9672           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9673      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9674 cd          if (lprn) then
9675 cd            write (2,*) 'lll=',lll
9676 cd            write (2,*) 'iii=1'
9677 cd            do jjj=1,2
9678 cd              write (2,'(3(2f10.5),5x)')
9679 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9680 cd            enddo
9681 cd          endif
9682           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9683      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9684 cd          if (lprn) then
9685 cd            write (2,*) 'lll=',lll
9686 cd            write (2,*) 'iii=2'
9687 cd            do jjj=1,2
9688 cd              write (2,'(3(2f10.5),5x)')
9689 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9690 cd            enddo
9691 cd          endif
9692         enddo
9693       enddo
9694       return
9695       end
9696 C---------------------------------------------------------------------------
9697       double precision function eello4(i,j,k,l,jj,kk)
9698       implicit real*8 (a-h,o-z)
9699       include 'DIMENSIONS'
9700       include 'COMMON.IOUNITS'
9701       include 'COMMON.CHAIN'
9702       include 'COMMON.DERIV'
9703       include 'COMMON.INTERACT'
9704       include 'COMMON.CONTACTS'
9705       include 'COMMON.TORSION'
9706       include 'COMMON.VAR'
9707       include 'COMMON.GEO'
9708       double precision pizda(2,2),ggg1(3),ggg2(3)
9709 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9710 cd        eello4=0.0d0
9711 cd        return
9712 cd      endif
9713 cd      print *,'eello4:',i,j,k,l,jj,kk
9714 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9715 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9716 cold      eij=facont_hb(jj,i)
9717 cold      ekl=facont_hb(kk,k)
9718 cold      ekont=eij*ekl
9719       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9720 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9721       gcorr_loc(k-1)=gcorr_loc(k-1)
9722      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9723       if (l.eq.j+1) then
9724         gcorr_loc(l-1)=gcorr_loc(l-1)
9725      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9726       else
9727         gcorr_loc(j-1)=gcorr_loc(j-1)
9728      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9729       endif
9730       do iii=1,2
9731         do kkk=1,5
9732           do lll=1,3
9733             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9734      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9735 cd            derx(lll,kkk,iii)=0.0d0
9736           enddo
9737         enddo
9738       enddo
9739 cd      gcorr_loc(l-1)=0.0d0
9740 cd      gcorr_loc(j-1)=0.0d0
9741 cd      gcorr_loc(k-1)=0.0d0
9742 cd      eel4=1.0d0
9743 cd      write (iout,*)'Contacts have occurred for peptide groups',
9744 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9745 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9746       if (j.lt.nres-1) then
9747         j1=j+1
9748         j2=j-1
9749       else
9750         j1=j-1
9751         j2=j-2
9752       endif
9753       if (l.lt.nres-1) then
9754         l1=l+1
9755         l2=l-1
9756       else
9757         l1=l-1
9758         l2=l-2
9759       endif
9760       do ll=1,3
9761 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9762 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9763         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9764         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9765 cgrad        ghalf=0.5d0*ggg1(ll)
9766         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9767         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9768         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9769         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9770         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9771         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9772 cgrad        ghalf=0.5d0*ggg2(ll)
9773         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9774         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9775         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9776         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9777         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9778         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9779       enddo
9780 cgrad      do m=i+1,j-1
9781 cgrad        do ll=1,3
9782 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9783 cgrad        enddo
9784 cgrad      enddo
9785 cgrad      do m=k+1,l-1
9786 cgrad        do ll=1,3
9787 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9788 cgrad        enddo
9789 cgrad      enddo
9790 cgrad      do m=i+2,j2
9791 cgrad        do ll=1,3
9792 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9793 cgrad        enddo
9794 cgrad      enddo
9795 cgrad      do m=k+2,l2
9796 cgrad        do ll=1,3
9797 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9798 cgrad        enddo
9799 cgrad      enddo
9800 cd      do iii=1,nres-3
9801 cd        write (2,*) iii,gcorr_loc(iii)
9802 cd      enddo
9803       eello4=ekont*eel4
9804 cd      write (2,*) 'ekont',ekont
9805 cd      write (iout,*) 'eello4',ekont*eel4
9806       return
9807       end
9808 C---------------------------------------------------------------------------
9809       double precision function eello5(i,j,k,l,jj,kk)
9810       implicit real*8 (a-h,o-z)
9811       include 'DIMENSIONS'
9812       include 'COMMON.IOUNITS'
9813       include 'COMMON.CHAIN'
9814       include 'COMMON.DERIV'
9815       include 'COMMON.INTERACT'
9816       include 'COMMON.CONTACTS'
9817       include 'COMMON.TORSION'
9818       include 'COMMON.VAR'
9819       include 'COMMON.GEO'
9820       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9821       double precision ggg1(3),ggg2(3)
9822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9823 C                                                                              C
9824 C                            Parallel chains                                   C
9825 C                                                                              C
9826 C          o             o                   o             o                   C
9827 C         /l\           / \             \   / \           / \   /              C
9828 C        /   \         /   \             \ /   \         /   \ /               C
9829 C       j| o |l1       | o |              o| o |         | o |o                C
9830 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9831 C      \i/   \         /   \ /             /   \         /   \                 C
9832 C       o    k1             o                                                  C
9833 C         (I)          (II)                (III)          (IV)                 C
9834 C                                                                              C
9835 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9836 C                                                                              C
9837 C                            Antiparallel chains                               C
9838 C                                                                              C
9839 C          o             o                   o             o                   C
9840 C         /j\           / \             \   / \           / \   /              C
9841 C        /   \         /   \             \ /   \         /   \ /               C
9842 C      j1| o |l        | o |              o| o |         | o |o                C
9843 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9844 C      \i/   \         /   \ /             /   \         /   \                 C
9845 C       o     k1            o                                                  C
9846 C         (I)          (II)                (III)          (IV)                 C
9847 C                                                                              C
9848 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9849 C                                                                              C
9850 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9851 C                                                                              C
9852 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9853 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9854 cd        eello5=0.0d0
9855 cd        return
9856 cd      endif
9857 cd      write (iout,*)
9858 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9859 cd     &   ' and',k,l
9860       itk=itype2loc(itype(k))
9861       itl=itype2loc(itype(l))
9862       itj=itype2loc(itype(j))
9863       eello5_1=0.0d0
9864       eello5_2=0.0d0
9865       eello5_3=0.0d0
9866       eello5_4=0.0d0
9867 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9868 cd     &   eel5_3_num,eel5_4_num)
9869       do iii=1,2
9870         do kkk=1,5
9871           do lll=1,3
9872             derx(lll,kkk,iii)=0.0d0
9873           enddo
9874         enddo
9875       enddo
9876 cd      eij=facont_hb(jj,i)
9877 cd      ekl=facont_hb(kk,k)
9878 cd      ekont=eij*ekl
9879 cd      write (iout,*)'Contacts have occurred for peptide groups',
9880 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9881 cd      goto 1111
9882 C Contribution from the graph I.
9883 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9884 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9885       call transpose2(EUg(1,1,k),auxmat(1,1))
9886       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9887       vv(1)=pizda(1,1)-pizda(2,2)
9888       vv(2)=pizda(1,2)+pizda(2,1)
9889       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9890      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9891 C Explicit gradient in virtual-dihedral angles.
9892       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9893      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9894      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9895       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9896       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9897       vv(1)=pizda(1,1)-pizda(2,2)
9898       vv(2)=pizda(1,2)+pizda(2,1)
9899       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9900      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9901      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9902       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9903       vv(1)=pizda(1,1)-pizda(2,2)
9904       vv(2)=pizda(1,2)+pizda(2,1)
9905       if (l.eq.j+1) then
9906         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9907      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9908      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9909       else
9910         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9911      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9912      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9913       endif
9914 C Cartesian gradient
9915       do iii=1,2
9916         do kkk=1,5
9917           do lll=1,3
9918             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9919      &        pizda(1,1))
9920             vv(1)=pizda(1,1)-pizda(2,2)
9921             vv(2)=pizda(1,2)+pizda(2,1)
9922             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9923      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9924      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9925           enddo
9926         enddo
9927       enddo
9928 c      goto 1112
9929 c1111  continue
9930 C Contribution from graph II
9931       call transpose2(EE(1,1,k),auxmat(1,1))
9932       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9933       vv(1)=pizda(1,1)+pizda(2,2)
9934       vv(2)=pizda(2,1)-pizda(1,2)
9935       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9936      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9937 C Explicit gradient in virtual-dihedral angles.
9938       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9939      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9940       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9941       vv(1)=pizda(1,1)+pizda(2,2)
9942       vv(2)=pizda(2,1)-pizda(1,2)
9943       if (l.eq.j+1) then
9944         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9945      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9946      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9947       else
9948         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9949      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9950      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9951       endif
9952 C Cartesian gradient
9953       do iii=1,2
9954         do kkk=1,5
9955           do lll=1,3
9956             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9957      &        pizda(1,1))
9958             vv(1)=pizda(1,1)+pizda(2,2)
9959             vv(2)=pizda(2,1)-pizda(1,2)
9960             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9961      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9962      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9963           enddo
9964         enddo
9965       enddo
9966 cd      goto 1112
9967 cd1111  continue
9968       if (l.eq.j+1) then
9969 cd        goto 1110
9970 C Parallel orientation
9971 C Contribution from graph III
9972         call transpose2(EUg(1,1,l),auxmat(1,1))
9973         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9974         vv(1)=pizda(1,1)-pizda(2,2)
9975         vv(2)=pizda(1,2)+pizda(2,1)
9976         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9977      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9978 C Explicit gradient in virtual-dihedral angles.
9979         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9980      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9981      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9982         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9983         vv(1)=pizda(1,1)-pizda(2,2)
9984         vv(2)=pizda(1,2)+pizda(2,1)
9985         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9986      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9987      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9988         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9989         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9990         vv(1)=pizda(1,1)-pizda(2,2)
9991         vv(2)=pizda(1,2)+pizda(2,1)
9992         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9993      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9994      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9995 C Cartesian gradient
9996         do iii=1,2
9997           do kkk=1,5
9998             do lll=1,3
9999               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10000      &          pizda(1,1))
10001               vv(1)=pizda(1,1)-pizda(2,2)
10002               vv(2)=pizda(1,2)+pizda(2,1)
10003               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10004      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10005      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10006             enddo
10007           enddo
10008         enddo
10009 cd        goto 1112
10010 C Contribution from graph IV
10011 cd1110    continue
10012         call transpose2(EE(1,1,l),auxmat(1,1))
10013         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10014         vv(1)=pizda(1,1)+pizda(2,2)
10015         vv(2)=pizda(2,1)-pizda(1,2)
10016         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10017      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10018 C Explicit gradient in virtual-dihedral angles.
10019         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10020      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10021         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10022         vv(1)=pizda(1,1)+pizda(2,2)
10023         vv(2)=pizda(2,1)-pizda(1,2)
10024         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10025      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10026      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10027 C Cartesian gradient
10028         do iii=1,2
10029           do kkk=1,5
10030             do lll=1,3
10031               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10032      &          pizda(1,1))
10033               vv(1)=pizda(1,1)+pizda(2,2)
10034               vv(2)=pizda(2,1)-pizda(1,2)
10035               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10036      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10037      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10038             enddo
10039           enddo
10040         enddo
10041       else
10042 C Antiparallel orientation
10043 C Contribution from graph III
10044 c        goto 1110
10045         call transpose2(EUg(1,1,j),auxmat(1,1))
10046         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10047         vv(1)=pizda(1,1)-pizda(2,2)
10048         vv(2)=pizda(1,2)+pizda(2,1)
10049         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10050      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10051 C Explicit gradient in virtual-dihedral angles.
10052         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10053      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10054      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10055         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10056         vv(1)=pizda(1,1)-pizda(2,2)
10057         vv(2)=pizda(1,2)+pizda(2,1)
10058         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10059      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10060      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10061         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10062         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10063         vv(1)=pizda(1,1)-pizda(2,2)
10064         vv(2)=pizda(1,2)+pizda(2,1)
10065         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10066      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10067      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10068 C Cartesian gradient
10069         do iii=1,2
10070           do kkk=1,5
10071             do lll=1,3
10072               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10073      &          pizda(1,1))
10074               vv(1)=pizda(1,1)-pizda(2,2)
10075               vv(2)=pizda(1,2)+pizda(2,1)
10076               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10077      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10078      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10079             enddo
10080           enddo
10081         enddo
10082 cd        goto 1112
10083 C Contribution from graph IV
10084 1110    continue
10085         call transpose2(EE(1,1,j),auxmat(1,1))
10086         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10087         vv(1)=pizda(1,1)+pizda(2,2)
10088         vv(2)=pizda(2,1)-pizda(1,2)
10089         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10090      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10091 C Explicit gradient in virtual-dihedral angles.
10092         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10093      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10094         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10095         vv(1)=pizda(1,1)+pizda(2,2)
10096         vv(2)=pizda(2,1)-pizda(1,2)
10097         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10098      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10099      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10100 C Cartesian gradient
10101         do iii=1,2
10102           do kkk=1,5
10103             do lll=1,3
10104               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10105      &          pizda(1,1))
10106               vv(1)=pizda(1,1)+pizda(2,2)
10107               vv(2)=pizda(2,1)-pizda(1,2)
10108               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10109      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10110      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10111             enddo
10112           enddo
10113         enddo
10114       endif
10115 1112  continue
10116       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10117 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10118 cd        write (2,*) 'ijkl',i,j,k,l
10119 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10120 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10121 cd      endif
10122 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10123 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10124 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10125 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10126       if (j.lt.nres-1) then
10127         j1=j+1
10128         j2=j-1
10129       else
10130         j1=j-1
10131         j2=j-2
10132       endif
10133       if (l.lt.nres-1) then
10134         l1=l+1
10135         l2=l-1
10136       else
10137         l1=l-1
10138         l2=l-2
10139       endif
10140 cd      eij=1.0d0
10141 cd      ekl=1.0d0
10142 cd      ekont=1.0d0
10143 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10144 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10145 C        summed up outside the subrouine as for the other subroutines
10146 C        handling long-range interactions. The old code is commented out
10147 C        with "cgrad" to keep track of changes.
10148       do ll=1,3
10149 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10150 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10151         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10152         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10153 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10154 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10155 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10156 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10157 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10158 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10159 c     &   gradcorr5ij,
10160 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10161 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10162 cgrad        ghalf=0.5d0*ggg1(ll)
10163 cd        ghalf=0.0d0
10164         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10165         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10166         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10167         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10168         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10169         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10170 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10171 cgrad        ghalf=0.5d0*ggg2(ll)
10172 cd        ghalf=0.0d0
10173         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10174         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10175         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10176         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10177         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10178         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10179       enddo
10180 cd      goto 1112
10181 cgrad      do m=i+1,j-1
10182 cgrad        do ll=1,3
10183 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10184 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10185 cgrad        enddo
10186 cgrad      enddo
10187 cgrad      do m=k+1,l-1
10188 cgrad        do ll=1,3
10189 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10190 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10191 cgrad        enddo
10192 cgrad      enddo
10193 c1112  continue
10194 cgrad      do m=i+2,j2
10195 cgrad        do ll=1,3
10196 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10197 cgrad        enddo
10198 cgrad      enddo
10199 cgrad      do m=k+2,l2
10200 cgrad        do ll=1,3
10201 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10202 cgrad        enddo
10203 cgrad      enddo
10204 cd      do iii=1,nres-3
10205 cd        write (2,*) iii,g_corr5_loc(iii)
10206 cd      enddo
10207       eello5=ekont*eel5
10208 cd      write (2,*) 'ekont',ekont
10209 cd      write (iout,*) 'eello5',ekont*eel5
10210       return
10211       end
10212 c--------------------------------------------------------------------------
10213       double precision function eello6(i,j,k,l,jj,kk)
10214       implicit real*8 (a-h,o-z)
10215       include 'DIMENSIONS'
10216       include 'COMMON.IOUNITS'
10217       include 'COMMON.CHAIN'
10218       include 'COMMON.DERIV'
10219       include 'COMMON.INTERACT'
10220       include 'COMMON.CONTACTS'
10221       include 'COMMON.TORSION'
10222       include 'COMMON.VAR'
10223       include 'COMMON.GEO'
10224       include 'COMMON.FFIELD'
10225       double precision ggg1(3),ggg2(3)
10226 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10227 cd        eello6=0.0d0
10228 cd        return
10229 cd      endif
10230 cd      write (iout,*)
10231 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10232 cd     &   ' and',k,l
10233       eello6_1=0.0d0
10234       eello6_2=0.0d0
10235       eello6_3=0.0d0
10236       eello6_4=0.0d0
10237       eello6_5=0.0d0
10238       eello6_6=0.0d0
10239 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10240 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10241       do iii=1,2
10242         do kkk=1,5
10243           do lll=1,3
10244             derx(lll,kkk,iii)=0.0d0
10245           enddo
10246         enddo
10247       enddo
10248 cd      eij=facont_hb(jj,i)
10249 cd      ekl=facont_hb(kk,k)
10250 cd      ekont=eij*ekl
10251 cd      eij=1.0d0
10252 cd      ekl=1.0d0
10253 cd      ekont=1.0d0
10254       if (l.eq.j+1) then
10255         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10256         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10257         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10258         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10259         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10260         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10261       else
10262         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10263         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10264         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10265         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10266         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10267           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10268         else
10269           eello6_5=0.0d0
10270         endif
10271         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10272       endif
10273 C If turn contributions are considered, they will be handled separately.
10274       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10275 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10276 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10277 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10278 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10279 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10280 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10281 cd      goto 1112
10282       if (j.lt.nres-1) then
10283         j1=j+1
10284         j2=j-1
10285       else
10286         j1=j-1
10287         j2=j-2
10288       endif
10289       if (l.lt.nres-1) then
10290         l1=l+1
10291         l2=l-1
10292       else
10293         l1=l-1
10294         l2=l-2
10295       endif
10296       do ll=1,3
10297 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10298 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10299 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10300 cgrad        ghalf=0.5d0*ggg1(ll)
10301 cd        ghalf=0.0d0
10302         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10303         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10304         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10305         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10306         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10307         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10308         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10309         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10310 cgrad        ghalf=0.5d0*ggg2(ll)
10311 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10312 cd        ghalf=0.0d0
10313         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10314         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10315         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10316         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10317         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10318         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10319       enddo
10320 cd      goto 1112
10321 cgrad      do m=i+1,j-1
10322 cgrad        do ll=1,3
10323 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10324 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10325 cgrad        enddo
10326 cgrad      enddo
10327 cgrad      do m=k+1,l-1
10328 cgrad        do ll=1,3
10329 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10330 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10331 cgrad        enddo
10332 cgrad      enddo
10333 cgrad1112  continue
10334 cgrad      do m=i+2,j2
10335 cgrad        do ll=1,3
10336 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10337 cgrad        enddo
10338 cgrad      enddo
10339 cgrad      do m=k+2,l2
10340 cgrad        do ll=1,3
10341 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10342 cgrad        enddo
10343 cgrad      enddo
10344 cd      do iii=1,nres-3
10345 cd        write (2,*) iii,g_corr6_loc(iii)
10346 cd      enddo
10347       eello6=ekont*eel6
10348 cd      write (2,*) 'ekont',ekont
10349 cd      write (iout,*) 'eello6',ekont*eel6
10350       return
10351       end
10352 c--------------------------------------------------------------------------
10353       double precision function eello6_graph1(i,j,k,l,imat,swap)
10354       implicit real*8 (a-h,o-z)
10355       include 'DIMENSIONS'
10356       include 'COMMON.IOUNITS'
10357       include 'COMMON.CHAIN'
10358       include 'COMMON.DERIV'
10359       include 'COMMON.INTERACT'
10360       include 'COMMON.CONTACTS'
10361       include 'COMMON.TORSION'
10362       include 'COMMON.VAR'
10363       include 'COMMON.GEO'
10364       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10365       logical swap
10366       logical lprn
10367       common /kutas/ lprn
10368 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10369 C                                                                              C
10370 C      Parallel       Antiparallel                                             C
10371 C                                                                              C
10372 C          o             o                                                     C
10373 C         /l\           /j\                                                    C
10374 C        /   \         /   \                                                   C
10375 C       /| o |         | o |\                                                  C
10376 C     \ j|/k\|  /   \  |/k\|l /                                                C
10377 C      \ /   \ /     \ /   \ /                                                 C
10378 C       o     o       o     o                                                  C
10379 C       i             i                                                        C
10380 C                                                                              C
10381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10382       itk=itype2loc(itype(k))
10383       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10384       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10385       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10386       call transpose2(EUgC(1,1,k),auxmat(1,1))
10387       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10388       vv1(1)=pizda1(1,1)-pizda1(2,2)
10389       vv1(2)=pizda1(1,2)+pizda1(2,1)
10390       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10391       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10392       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10393       s5=scalar2(vv(1),Dtobr2(1,i))
10394 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10395       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10396       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10397      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10398      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10399      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10400      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10401      & +scalar2(vv(1),Dtobr2der(1,i)))
10402       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10403       vv1(1)=pizda1(1,1)-pizda1(2,2)
10404       vv1(2)=pizda1(1,2)+pizda1(2,1)
10405       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10406       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10407       if (l.eq.j+1) then
10408         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10409      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10410      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10411      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10412      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10413       else
10414         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10415      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10416      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10417      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10418      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10419       endif
10420       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10421       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10422       vv1(1)=pizda1(1,1)-pizda1(2,2)
10423       vv1(2)=pizda1(1,2)+pizda1(2,1)
10424       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10425      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10426      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10427      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10428       do iii=1,2
10429         if (swap) then
10430           ind=3-iii
10431         else
10432           ind=iii
10433         endif
10434         do kkk=1,5
10435           do lll=1,3
10436             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10437             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10438             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10439             call transpose2(EUgC(1,1,k),auxmat(1,1))
10440             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10441      &        pizda1(1,1))
10442             vv1(1)=pizda1(1,1)-pizda1(2,2)
10443             vv1(2)=pizda1(1,2)+pizda1(2,1)
10444             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10445             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10446      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10447             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10448      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10449             s5=scalar2(vv(1),Dtobr2(1,i))
10450             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10451           enddo
10452         enddo
10453       enddo
10454       return
10455       end
10456 c----------------------------------------------------------------------------
10457       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10458       implicit real*8 (a-h,o-z)
10459       include 'DIMENSIONS'
10460       include 'COMMON.IOUNITS'
10461       include 'COMMON.CHAIN'
10462       include 'COMMON.DERIV'
10463       include 'COMMON.INTERACT'
10464       include 'COMMON.CONTACTS'
10465       include 'COMMON.TORSION'
10466       include 'COMMON.VAR'
10467       include 'COMMON.GEO'
10468       logical swap
10469       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10470      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10471       logical lprn
10472       common /kutas/ lprn
10473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10474 C                                                                              C
10475 C      Parallel       Antiparallel                                             C
10476 C                                                                              C
10477 C          o             o                                                     C
10478 C     \   /l\           /j\   /                                                C
10479 C      \ /   \         /   \ /                                                 C
10480 C       o| o |         | o |o                                                  C
10481 C     \ j|/k\|      \  |/k\|l                                                  C
10482 C      \ /   \       \ /   \                                                   C
10483 C       o             o                                                        C
10484 C       i             i                                                        C
10485 C                                                                              C
10486 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10487 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10488 C AL 7/4/01 s1 would occur in the sixth-order moment,
10489 C           but not in a cluster cumulant
10490 #ifdef MOMENT
10491       s1=dip(1,jj,i)*dip(1,kk,k)
10492 #endif
10493       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10494       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10495       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10496       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10497       call transpose2(EUg(1,1,k),auxmat(1,1))
10498       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10499       vv(1)=pizda(1,1)-pizda(2,2)
10500       vv(2)=pizda(1,2)+pizda(2,1)
10501       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10502 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10503 #ifdef MOMENT
10504       eello6_graph2=-(s1+s2+s3+s4)
10505 #else
10506       eello6_graph2=-(s2+s3+s4)
10507 #endif
10508 c      eello6_graph2=-s3
10509 C Derivatives in gamma(i-1)
10510       if (i.gt.1) then
10511 #ifdef MOMENT
10512         s1=dipderg(1,jj,i)*dip(1,kk,k)
10513 #endif
10514         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10515         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10516         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10517         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10518 #ifdef MOMENT
10519         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10520 #else
10521         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10522 #endif
10523 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10524       endif
10525 C Derivatives in gamma(k-1)
10526 #ifdef MOMENT
10527       s1=dip(1,jj,i)*dipderg(1,kk,k)
10528 #endif
10529       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10530       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10531       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10532       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10533       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10534       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10535       vv(1)=pizda(1,1)-pizda(2,2)
10536       vv(2)=pizda(1,2)+pizda(2,1)
10537       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10538 #ifdef MOMENT
10539       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10540 #else
10541       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10542 #endif
10543 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10544 C Derivatives in gamma(j-1) or gamma(l-1)
10545       if (j.gt.1) then
10546 #ifdef MOMENT
10547         s1=dipderg(3,jj,i)*dip(1,kk,k)
10548 #endif
10549         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10550         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10551         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10552         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10553         vv(1)=pizda(1,1)-pizda(2,2)
10554         vv(2)=pizda(1,2)+pizda(2,1)
10555         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10556 #ifdef MOMENT
10557         if (swap) then
10558           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10559         else
10560           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10561         endif
10562 #endif
10563         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10564 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10565       endif
10566 C Derivatives in gamma(l-1) or gamma(j-1)
10567       if (l.gt.1) then
10568 #ifdef MOMENT
10569         s1=dip(1,jj,i)*dipderg(3,kk,k)
10570 #endif
10571         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10572         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10573         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10574         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10575         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10576         vv(1)=pizda(1,1)-pizda(2,2)
10577         vv(2)=pizda(1,2)+pizda(2,1)
10578         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10579 #ifdef MOMENT
10580         if (swap) then
10581           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10582         else
10583           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10584         endif
10585 #endif
10586         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10587 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10588       endif
10589 C Cartesian derivatives.
10590       if (lprn) then
10591         write (2,*) 'In eello6_graph2'
10592         do iii=1,2
10593           write (2,*) 'iii=',iii
10594           do kkk=1,5
10595             write (2,*) 'kkk=',kkk
10596             do jjj=1,2
10597               write (2,'(3(2f10.5),5x)')
10598      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10599             enddo
10600           enddo
10601         enddo
10602       endif
10603       do iii=1,2
10604         do kkk=1,5
10605           do lll=1,3
10606 #ifdef MOMENT
10607             if (iii.eq.1) then
10608               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10609             else
10610               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10611             endif
10612 #endif
10613             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10614      &        auxvec(1))
10615             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10616             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10617      &        auxvec(1))
10618             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10619             call transpose2(EUg(1,1,k),auxmat(1,1))
10620             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10621      &        pizda(1,1))
10622             vv(1)=pizda(1,1)-pizda(2,2)
10623             vv(2)=pizda(1,2)+pizda(2,1)
10624             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10625 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10626 #ifdef MOMENT
10627             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10628 #else
10629             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10630 #endif
10631             if (swap) then
10632               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10633             else
10634               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10635             endif
10636           enddo
10637         enddo
10638       enddo
10639       return
10640       end
10641 c----------------------------------------------------------------------------
10642       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10643       implicit real*8 (a-h,o-z)
10644       include 'DIMENSIONS'
10645       include 'COMMON.IOUNITS'
10646       include 'COMMON.CHAIN'
10647       include 'COMMON.DERIV'
10648       include 'COMMON.INTERACT'
10649       include 'COMMON.CONTACTS'
10650       include 'COMMON.TORSION'
10651       include 'COMMON.VAR'
10652       include 'COMMON.GEO'
10653       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10654       logical swap
10655 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10656 C                                                                              C
10657 C      Parallel       Antiparallel                                             C
10658 C                                                                              C
10659 C          o             o                                                     C
10660 C         /l\   /   \   /j\                                                    C
10661 C        /   \ /     \ /   \                                                   C
10662 C       /| o |o       o| o |\                                                  C
10663 C       j|/k\|  /      |/k\|l /                                                C
10664 C        /   \ /       /   \ /                                                 C
10665 C       /     o       /     o                                                  C
10666 C       i             i                                                        C
10667 C                                                                              C
10668 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10669 C
10670 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10671 C           energy moment and not to the cluster cumulant.
10672       iti=itortyp(itype(i))
10673       if (j.lt.nres-1) then
10674         itj1=itype2loc(itype(j+1))
10675       else
10676         itj1=nloctyp
10677       endif
10678       itk=itype2loc(itype(k))
10679       itk1=itype2loc(itype(k+1))
10680       if (l.lt.nres-1) then
10681         itl1=itype2loc(itype(l+1))
10682       else
10683         itl1=nloctyp
10684       endif
10685 #ifdef MOMENT
10686       s1=dip(4,jj,i)*dip(4,kk,k)
10687 #endif
10688       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10689       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10690       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10691       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10692       call transpose2(EE(1,1,k),auxmat(1,1))
10693       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10694       vv(1)=pizda(1,1)+pizda(2,2)
10695       vv(2)=pizda(2,1)-pizda(1,2)
10696       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10697 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10698 cd     & "sum",-(s2+s3+s4)
10699 #ifdef MOMENT
10700       eello6_graph3=-(s1+s2+s3+s4)
10701 #else
10702       eello6_graph3=-(s2+s3+s4)
10703 #endif
10704 c      eello6_graph3=-s4
10705 C Derivatives in gamma(k-1)
10706       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10707       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10708       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10709       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10710 C Derivatives in gamma(l-1)
10711       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10712       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10713       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10714       vv(1)=pizda(1,1)+pizda(2,2)
10715       vv(2)=pizda(2,1)-pizda(1,2)
10716       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10717       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10718 C Cartesian derivatives.
10719       do iii=1,2
10720         do kkk=1,5
10721           do lll=1,3
10722 #ifdef MOMENT
10723             if (iii.eq.1) then
10724               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10725             else
10726               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10727             endif
10728 #endif
10729             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10730      &        auxvec(1))
10731             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10732             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10733      &        auxvec(1))
10734             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10735             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10736      &        pizda(1,1))
10737             vv(1)=pizda(1,1)+pizda(2,2)
10738             vv(2)=pizda(2,1)-pizda(1,2)
10739             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10740 #ifdef MOMENT
10741             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10742 #else
10743             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10744 #endif
10745             if (swap) then
10746               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10747             else
10748               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10749             endif
10750 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10751           enddo
10752         enddo
10753       enddo
10754       return
10755       end
10756 c----------------------------------------------------------------------------
10757       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10758       implicit real*8 (a-h,o-z)
10759       include 'DIMENSIONS'
10760       include 'COMMON.IOUNITS'
10761       include 'COMMON.CHAIN'
10762       include 'COMMON.DERIV'
10763       include 'COMMON.INTERACT'
10764       include 'COMMON.CONTACTS'
10765       include 'COMMON.TORSION'
10766       include 'COMMON.VAR'
10767       include 'COMMON.GEO'
10768       include 'COMMON.FFIELD'
10769       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10770      & auxvec1(2),auxmat1(2,2)
10771       logical swap
10772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10773 C                                                                              C
10774 C      Parallel       Antiparallel                                             C
10775 C                                                                              C
10776 C          o             o                                                     C
10777 C         /l\   /   \   /j\                                                    C
10778 C        /   \ /     \ /   \                                                   C
10779 C       /| o |o       o| o |\                                                  C
10780 C     \ j|/k\|      \  |/k\|l                                                  C
10781 C      \ /   \       \ /   \                                                   C
10782 C       o     \       o     \                                                  C
10783 C       i             i                                                        C
10784 C                                                                              C
10785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10786 C
10787 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10788 C           energy moment and not to the cluster cumulant.
10789 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10790       iti=itype2loc(itype(i))
10791       itj=itype2loc(itype(j))
10792       if (j.lt.nres-1) then
10793         itj1=itype2loc(itype(j+1))
10794       else
10795         itj1=nloctyp
10796       endif
10797       itk=itype2loc(itype(k))
10798       if (k.lt.nres-1) then
10799         itk1=itype2loc(itype(k+1))
10800       else
10801         itk1=nloctyp
10802       endif
10803       itl=itype2loc(itype(l))
10804       if (l.lt.nres-1) then
10805         itl1=itype2loc(itype(l+1))
10806       else
10807         itl1=nloctyp
10808       endif
10809 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10810 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10811 cd     & ' itl',itl,' itl1',itl1
10812 #ifdef MOMENT
10813       if (imat.eq.1) then
10814         s1=dip(3,jj,i)*dip(3,kk,k)
10815       else
10816         s1=dip(2,jj,j)*dip(2,kk,l)
10817       endif
10818 #endif
10819       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10820       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10821       if (j.eq.l+1) then
10822         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10823         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10824       else
10825         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10826         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10827       endif
10828       call transpose2(EUg(1,1,k),auxmat(1,1))
10829       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10830       vv(1)=pizda(1,1)-pizda(2,2)
10831       vv(2)=pizda(2,1)+pizda(1,2)
10832       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10833 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10834 #ifdef MOMENT
10835       eello6_graph4=-(s1+s2+s3+s4)
10836 #else
10837       eello6_graph4=-(s2+s3+s4)
10838 #endif
10839 C Derivatives in gamma(i-1)
10840       if (i.gt.1) then
10841 #ifdef MOMENT
10842         if (imat.eq.1) then
10843           s1=dipderg(2,jj,i)*dip(3,kk,k)
10844         else
10845           s1=dipderg(4,jj,j)*dip(2,kk,l)
10846         endif
10847 #endif
10848         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10849         if (j.eq.l+1) then
10850           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10851           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10852         else
10853           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10854           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10855         endif
10856         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10857         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10858 cd          write (2,*) 'turn6 derivatives'
10859 #ifdef MOMENT
10860           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10861 #else
10862           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10863 #endif
10864         else
10865 #ifdef MOMENT
10866           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10867 #else
10868           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10869 #endif
10870         endif
10871       endif
10872 C Derivatives in gamma(k-1)
10873 #ifdef MOMENT
10874       if (imat.eq.1) then
10875         s1=dip(3,jj,i)*dipderg(2,kk,k)
10876       else
10877         s1=dip(2,jj,j)*dipderg(4,kk,l)
10878       endif
10879 #endif
10880       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10881       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10882       if (j.eq.l+1) then
10883         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10884         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10885       else
10886         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10887         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10888       endif
10889       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10890       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10891       vv(1)=pizda(1,1)-pizda(2,2)
10892       vv(2)=pizda(2,1)+pizda(1,2)
10893       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10894       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10895 #ifdef MOMENT
10896         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10897 #else
10898         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10899 #endif
10900       else
10901 #ifdef MOMENT
10902         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10903 #else
10904         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10905 #endif
10906       endif
10907 C Derivatives in gamma(j-1) or gamma(l-1)
10908       if (l.eq.j+1 .and. l.gt.1) then
10909         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10910         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10911         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10912         vv(1)=pizda(1,1)-pizda(2,2)
10913         vv(2)=pizda(2,1)+pizda(1,2)
10914         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10915         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10916       else if (j.gt.1) then
10917         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10918         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10919         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10920         vv(1)=pizda(1,1)-pizda(2,2)
10921         vv(2)=pizda(2,1)+pizda(1,2)
10922         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10923         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10924           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10925         else
10926           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10927         endif
10928       endif
10929 C Cartesian derivatives.
10930       do iii=1,2
10931         do kkk=1,5
10932           do lll=1,3
10933 #ifdef MOMENT
10934             if (iii.eq.1) then
10935               if (imat.eq.1) then
10936                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10937               else
10938                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10939               endif
10940             else
10941               if (imat.eq.1) then
10942                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10943               else
10944                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10945               endif
10946             endif
10947 #endif
10948             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10949      &        auxvec(1))
10950             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10951             if (j.eq.l+1) then
10952               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10953      &          b1(1,j+1),auxvec(1))
10954               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10955             else
10956               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10957      &          b1(1,l+1),auxvec(1))
10958               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10959             endif
10960             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10961      &        pizda(1,1))
10962             vv(1)=pizda(1,1)-pizda(2,2)
10963             vv(2)=pizda(2,1)+pizda(1,2)
10964             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10965             if (swap) then
10966               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10967 #ifdef MOMENT
10968                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10969      &             -(s1+s2+s4)
10970 #else
10971                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10972      &             -(s2+s4)
10973 #endif
10974                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10975               else
10976 #ifdef MOMENT
10977                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10978 #else
10979                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10980 #endif
10981                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10982               endif
10983             else
10984 #ifdef MOMENT
10985               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10986 #else
10987               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10988 #endif
10989               if (l.eq.j+1) then
10990                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10991               else
10992                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10993               endif
10994             endif
10995           enddo
10996         enddo
10997       enddo
10998       return
10999       end
11000 c----------------------------------------------------------------------------
11001       double precision function eello_turn6(i,jj,kk)
11002       implicit real*8 (a-h,o-z)
11003       include 'DIMENSIONS'
11004       include 'COMMON.IOUNITS'
11005       include 'COMMON.CHAIN'
11006       include 'COMMON.DERIV'
11007       include 'COMMON.INTERACT'
11008       include 'COMMON.CONTACTS'
11009       include 'COMMON.TORSION'
11010       include 'COMMON.VAR'
11011       include 'COMMON.GEO'
11012       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11013      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11014      &  ggg1(3),ggg2(3)
11015       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11016      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11017 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11018 C           the respective energy moment and not to the cluster cumulant.
11019       s1=0.0d0
11020       s8=0.0d0
11021       s13=0.0d0
11022 c
11023       eello_turn6=0.0d0
11024       j=i+4
11025       k=i+1
11026       l=i+3
11027       iti=itype2loc(itype(i))
11028       itk=itype2loc(itype(k))
11029       itk1=itype2loc(itype(k+1))
11030       itl=itype2loc(itype(l))
11031       itj=itype2loc(itype(j))
11032 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11033 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11034 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11035 cd        eello6=0.0d0
11036 cd        return
11037 cd      endif
11038 cd      write (iout,*)
11039 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11040 cd     &   ' and',k,l
11041 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11042       do iii=1,2
11043         do kkk=1,5
11044           do lll=1,3
11045             derx_turn(lll,kkk,iii)=0.0d0
11046           enddo
11047         enddo
11048       enddo
11049 cd      eij=1.0d0
11050 cd      ekl=1.0d0
11051 cd      ekont=1.0d0
11052       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11053 cd      eello6_5=0.0d0
11054 cd      write (2,*) 'eello6_5',eello6_5
11055 #ifdef MOMENT
11056       call transpose2(AEA(1,1,1),auxmat(1,1))
11057       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11058       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11059       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11060 #endif
11061       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11062       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11063       s2 = scalar2(b1(1,k),vtemp1(1))
11064 #ifdef MOMENT
11065       call transpose2(AEA(1,1,2),atemp(1,1))
11066       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11067       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11068       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11069 #endif
11070       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11071       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11072       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11073 #ifdef MOMENT
11074       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11075       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11076       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11077       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11078       ss13 = scalar2(b1(1,k),vtemp4(1))
11079       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11080 #endif
11081 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11082 c      s1=0.0d0
11083 c      s2=0.0d0
11084 c      s8=0.0d0
11085 c      s12=0.0d0
11086 c      s13=0.0d0
11087       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11088 C Derivatives in gamma(i+2)
11089       s1d =0.0d0
11090       s8d =0.0d0
11091 #ifdef MOMENT
11092       call transpose2(AEA(1,1,1),auxmatd(1,1))
11093       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11094       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11095       call transpose2(AEAderg(1,1,2),atempd(1,1))
11096       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11097       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11098 #endif
11099       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11100       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11101       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11102 c      s1d=0.0d0
11103 c      s2d=0.0d0
11104 c      s8d=0.0d0
11105 c      s12d=0.0d0
11106 c      s13d=0.0d0
11107       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11108 C Derivatives in gamma(i+3)
11109 #ifdef MOMENT
11110       call transpose2(AEA(1,1,1),auxmatd(1,1))
11111       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11112       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11113       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11114 #endif
11115       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11116       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11117       s2d = scalar2(b1(1,k),vtemp1d(1))
11118 #ifdef MOMENT
11119       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11120       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11121 #endif
11122       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11123 #ifdef MOMENT
11124       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11125       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11126       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11127 #endif
11128 c      s1d=0.0d0
11129 c      s2d=0.0d0
11130 c      s8d=0.0d0
11131 c      s12d=0.0d0
11132 c      s13d=0.0d0
11133 #ifdef MOMENT
11134       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11135      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11136 #else
11137       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11138      &               -0.5d0*ekont*(s2d+s12d)
11139 #endif
11140 C Derivatives in gamma(i+4)
11141       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11142       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11143       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11144 #ifdef MOMENT
11145       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11146       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11147       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11148 #endif
11149 c      s1d=0.0d0
11150 c      s2d=0.0d0
11151 c      s8d=0.0d0
11152 C      s12d=0.0d0
11153 c      s13d=0.0d0
11154 #ifdef MOMENT
11155       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11156 #else
11157       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11158 #endif
11159 C Derivatives in gamma(i+5)
11160 #ifdef MOMENT
11161       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11162       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11163       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11164 #endif
11165       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11166       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11167       s2d = scalar2(b1(1,k),vtemp1d(1))
11168 #ifdef MOMENT
11169       call transpose2(AEA(1,1,2),atempd(1,1))
11170       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11171       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11172 #endif
11173       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11174       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11175 #ifdef MOMENT
11176       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11177       ss13d = scalar2(b1(1,k),vtemp4d(1))
11178       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11179 #endif
11180 c      s1d=0.0d0
11181 c      s2d=0.0d0
11182 c      s8d=0.0d0
11183 c      s12d=0.0d0
11184 c      s13d=0.0d0
11185 #ifdef MOMENT
11186       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11187      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11188 #else
11189       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11190      &               -0.5d0*ekont*(s2d+s12d)
11191 #endif
11192 C Cartesian derivatives
11193       do iii=1,2
11194         do kkk=1,5
11195           do lll=1,3
11196 #ifdef MOMENT
11197             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11198             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11199             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11200 #endif
11201             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11202             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11203      &          vtemp1d(1))
11204             s2d = scalar2(b1(1,k),vtemp1d(1))
11205 #ifdef MOMENT
11206             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11207             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11208             s8d = -(atempd(1,1)+atempd(2,2))*
11209      &           scalar2(cc(1,1,itl),vtemp2(1))
11210 #endif
11211             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11212      &           auxmatd(1,1))
11213             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11214             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11215 c      s1d=0.0d0
11216 c      s2d=0.0d0
11217 c      s8d=0.0d0
11218 c      s12d=0.0d0
11219 c      s13d=0.0d0
11220 #ifdef MOMENT
11221             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11222      &        - 0.5d0*(s1d+s2d)
11223 #else
11224             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11225      &        - 0.5d0*s2d
11226 #endif
11227 #ifdef MOMENT
11228             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11229      &        - 0.5d0*(s8d+s12d)
11230 #else
11231             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11232      &        - 0.5d0*s12d
11233 #endif
11234           enddo
11235         enddo
11236       enddo
11237 #ifdef MOMENT
11238       do kkk=1,5
11239         do lll=1,3
11240           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11241      &      achuj_tempd(1,1))
11242           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11243           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11244           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11245           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11246           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11247      &      vtemp4d(1))
11248           ss13d = scalar2(b1(1,k),vtemp4d(1))
11249           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11250           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11251         enddo
11252       enddo
11253 #endif
11254 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11255 cd     &  16*eel_turn6_num
11256 cd      goto 1112
11257       if (j.lt.nres-1) then
11258         j1=j+1
11259         j2=j-1
11260       else
11261         j1=j-1
11262         j2=j-2
11263       endif
11264       if (l.lt.nres-1) then
11265         l1=l+1
11266         l2=l-1
11267       else
11268         l1=l-1
11269         l2=l-2
11270       endif
11271       do ll=1,3
11272 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11273 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11274 cgrad        ghalf=0.5d0*ggg1(ll)
11275 cd        ghalf=0.0d0
11276         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11277         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11278         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11279      &    +ekont*derx_turn(ll,2,1)
11280         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11281         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11282      &    +ekont*derx_turn(ll,4,1)
11283         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11284         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11285         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11286 cgrad        ghalf=0.5d0*ggg2(ll)
11287 cd        ghalf=0.0d0
11288         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11289      &    +ekont*derx_turn(ll,2,2)
11290         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11291         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11292      &    +ekont*derx_turn(ll,4,2)
11293         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11294         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11295         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11296       enddo
11297 cd      goto 1112
11298 cgrad      do m=i+1,j-1
11299 cgrad        do ll=1,3
11300 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11301 cgrad        enddo
11302 cgrad      enddo
11303 cgrad      do m=k+1,l-1
11304 cgrad        do ll=1,3
11305 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11306 cgrad        enddo
11307 cgrad      enddo
11308 cgrad1112  continue
11309 cgrad      do m=i+2,j2
11310 cgrad        do ll=1,3
11311 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11312 cgrad        enddo
11313 cgrad      enddo
11314 cgrad      do m=k+2,l2
11315 cgrad        do ll=1,3
11316 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11317 cgrad        enddo
11318 cgrad      enddo
11319 cd      do iii=1,nres-3
11320 cd        write (2,*) iii,g_corr6_loc(iii)
11321 cd      enddo
11322       eello_turn6=ekont*eel_turn6
11323 cd      write (2,*) 'ekont',ekont
11324 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11325       return
11326       end
11327
11328 C-----------------------------------------------------------------------------
11329       double precision function scalar(u,v)
11330 !DIR$ INLINEALWAYS scalar
11331 #ifndef OSF
11332 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11333 #endif
11334       implicit none
11335       double precision u(3),v(3)
11336 cd      double precision sc
11337 cd      integer i
11338 cd      sc=0.0d0
11339 cd      do i=1,3
11340 cd        sc=sc+u(i)*v(i)
11341 cd      enddo
11342 cd      scalar=sc
11343
11344       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11345       return
11346       end
11347 crc-------------------------------------------------
11348       SUBROUTINE MATVEC2(A1,V1,V2)
11349 !DIR$ INLINEALWAYS MATVEC2
11350 #ifndef OSF
11351 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11352 #endif
11353       implicit real*8 (a-h,o-z)
11354       include 'DIMENSIONS'
11355       DIMENSION A1(2,2),V1(2),V2(2)
11356 c      DO 1 I=1,2
11357 c        VI=0.0
11358 c        DO 3 K=1,2
11359 c    3     VI=VI+A1(I,K)*V1(K)
11360 c        Vaux(I)=VI
11361 c    1 CONTINUE
11362
11363       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11364       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11365
11366       v2(1)=vaux1
11367       v2(2)=vaux2
11368       END
11369 C---------------------------------------
11370       SUBROUTINE MATMAT2(A1,A2,A3)
11371 #ifndef OSF
11372 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11373 #endif
11374       implicit real*8 (a-h,o-z)
11375       include 'DIMENSIONS'
11376       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11377 c      DIMENSION AI3(2,2)
11378 c        DO  J=1,2
11379 c          A3IJ=0.0
11380 c          DO K=1,2
11381 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11382 c          enddo
11383 c          A3(I,J)=A3IJ
11384 c       enddo
11385 c      enddo
11386
11387       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11388       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11389       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11390       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11391
11392       A3(1,1)=AI3_11
11393       A3(2,1)=AI3_21
11394       A3(1,2)=AI3_12
11395       A3(2,2)=AI3_22
11396       END
11397
11398 c-------------------------------------------------------------------------
11399       double precision function scalar2(u,v)
11400 !DIR$ INLINEALWAYS scalar2
11401       implicit none
11402       double precision u(2),v(2)
11403       double precision sc
11404       integer i
11405       scalar2=u(1)*v(1)+u(2)*v(2)
11406       return
11407       end
11408
11409 C-----------------------------------------------------------------------------
11410
11411       subroutine transpose2(a,at)
11412 !DIR$ INLINEALWAYS transpose2
11413 #ifndef OSF
11414 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11415 #endif
11416       implicit none
11417       double precision a(2,2),at(2,2)
11418       at(1,1)=a(1,1)
11419       at(1,2)=a(2,1)
11420       at(2,1)=a(1,2)
11421       at(2,2)=a(2,2)
11422       return
11423       end
11424 c--------------------------------------------------------------------------
11425       subroutine transpose(n,a,at)
11426       implicit none
11427       integer n,i,j
11428       double precision a(n,n),at(n,n)
11429       do i=1,n
11430         do j=1,n
11431           at(j,i)=a(i,j)
11432         enddo
11433       enddo
11434       return
11435       end
11436 C---------------------------------------------------------------------------
11437       subroutine prodmat3(a1,a2,kk,transp,prod)
11438 !DIR$ INLINEALWAYS prodmat3
11439 #ifndef OSF
11440 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11441 #endif
11442       implicit none
11443       integer i,j
11444       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11445       logical transp
11446 crc      double precision auxmat(2,2),prod_(2,2)
11447
11448       if (transp) then
11449 crc        call transpose2(kk(1,1),auxmat(1,1))
11450 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11451 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11452
11453            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11454      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11455            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11456      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11457            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11458      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11459            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11460      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11461
11462       else
11463 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11464 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11465
11466            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11467      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11468            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11469      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11470            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11471      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11472            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11473      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11474
11475       endif
11476 c      call transpose2(a2(1,1),a2t(1,1))
11477
11478 crc      print *,transp
11479 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11480 crc      print *,((prod(i,j),i=1,2),j=1,2)
11481
11482       return
11483       end
11484 CCC----------------------------------------------
11485       subroutine Eliptransfer(eliptran)
11486       implicit real*8 (a-h,o-z)
11487       include 'DIMENSIONS'
11488       include 'COMMON.GEO'
11489       include 'COMMON.VAR'
11490       include 'COMMON.LOCAL'
11491       include 'COMMON.CHAIN'
11492       include 'COMMON.DERIV'
11493       include 'COMMON.NAMES'
11494       include 'COMMON.INTERACT'
11495       include 'COMMON.IOUNITS'
11496       include 'COMMON.CALC'
11497       include 'COMMON.CONTROL'
11498       include 'COMMON.SPLITELE'
11499       include 'COMMON.SBRIDGE'
11500 C this is done by Adasko
11501 C      print *,"wchodze"
11502 C structure of box:
11503 C      water
11504 C--bordliptop-- buffore starts
11505 C--bufliptop--- here true lipid starts
11506 C      lipid
11507 C--buflipbot--- lipid ends buffore starts
11508 C--bordlipbot--buffore ends
11509       eliptran=0.0
11510       do i=ilip_start,ilip_end
11511 C       do i=1,1
11512         if (itype(i).eq.ntyp1) cycle
11513
11514         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11515         if (positi.le.0.0) positi=positi+boxzsize
11516 C        print *,i
11517 C first for peptide groups
11518 c for each residue check if it is in lipid or lipid water border area
11519        if ((positi.gt.bordlipbot)
11520      &.and.(positi.lt.bordliptop)) then
11521 C the energy transfer exist
11522         if (positi.lt.buflipbot) then
11523 C what fraction I am in
11524          fracinbuf=1.0d0-
11525      &        ((positi-bordlipbot)/lipbufthick)
11526 C lipbufthick is thickenes of lipid buffore
11527          sslip=sscalelip(fracinbuf)
11528          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11529          eliptran=eliptran+sslip*pepliptran
11530          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11531          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11532 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11533
11534 C        print *,"doing sccale for lower part"
11535 C         print *,i,sslip,fracinbuf,ssgradlip
11536         elseif (positi.gt.bufliptop) then
11537          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11538          sslip=sscalelip(fracinbuf)
11539          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11540          eliptran=eliptran+sslip*pepliptran
11541          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11542          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11543 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11544 C          print *, "doing sscalefor top part"
11545 C         print *,i,sslip,fracinbuf,ssgradlip
11546         else
11547          eliptran=eliptran+pepliptran
11548 C         print *,"I am in true lipid"
11549         endif
11550 C       else
11551 C       eliptran=elpitran+0.0 ! I am in water
11552        endif
11553        enddo
11554 C       print *, "nic nie bylo w lipidzie?"
11555 C now multiply all by the peptide group transfer factor
11556 C       eliptran=eliptran*pepliptran
11557 C now the same for side chains
11558 CV       do i=1,1
11559        do i=ilip_start,ilip_end
11560         if (itype(i).eq.ntyp1) cycle
11561         positi=(mod(c(3,i+nres),boxzsize))
11562         if (positi.le.0) positi=positi+boxzsize
11563 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11564 c for each residue check if it is in lipid or lipid water border area
11565 C       respos=mod(c(3,i+nres),boxzsize)
11566 C       print *,positi,bordlipbot,buflipbot
11567        if ((positi.gt.bordlipbot)
11568      & .and.(positi.lt.bordliptop)) then
11569 C the energy transfer exist
11570         if (positi.lt.buflipbot) then
11571          fracinbuf=1.0d0-
11572      &     ((positi-bordlipbot)/lipbufthick)
11573 C lipbufthick is thickenes of lipid buffore
11574          sslip=sscalelip(fracinbuf)
11575          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11576          eliptran=eliptran+sslip*liptranene(itype(i))
11577          gliptranx(3,i)=gliptranx(3,i)
11578      &+ssgradlip*liptranene(itype(i))
11579          gliptranc(3,i-1)= gliptranc(3,i-1)
11580      &+ssgradlip*liptranene(itype(i))
11581 C         print *,"doing sccale for lower part"
11582         elseif (positi.gt.bufliptop) then
11583          fracinbuf=1.0d0-
11584      &((bordliptop-positi)/lipbufthick)
11585          sslip=sscalelip(fracinbuf)
11586          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11587          eliptran=eliptran+sslip*liptranene(itype(i))
11588          gliptranx(3,i)=gliptranx(3,i)
11589      &+ssgradlip*liptranene(itype(i))
11590          gliptranc(3,i-1)= gliptranc(3,i-1)
11591      &+ssgradlip*liptranene(itype(i))
11592 C          print *, "doing sscalefor top part",sslip,fracinbuf
11593         else
11594          eliptran=eliptran+liptranene(itype(i))
11595 C         print *,"I am in true lipid"
11596         endif
11597         endif ! if in lipid or buffor
11598 C       else
11599 C       eliptran=elpitran+0.0 ! I am in water
11600        enddo
11601        return
11602        end
11603 C---------------------------------------------------------
11604 C AFM soubroutine for constant force
11605        subroutine AFMforce(Eafmforce)
11606        implicit real*8 (a-h,o-z)
11607       include 'DIMENSIONS'
11608       include 'COMMON.GEO'
11609       include 'COMMON.VAR'
11610       include 'COMMON.LOCAL'
11611       include 'COMMON.CHAIN'
11612       include 'COMMON.DERIV'
11613       include 'COMMON.NAMES'
11614       include 'COMMON.INTERACT'
11615       include 'COMMON.IOUNITS'
11616       include 'COMMON.CALC'
11617       include 'COMMON.CONTROL'
11618       include 'COMMON.SPLITELE'
11619       include 'COMMON.SBRIDGE'
11620       real*8 diffafm(3)
11621       dist=0.0d0
11622       Eafmforce=0.0d0
11623       do i=1,3
11624       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11625       dist=dist+diffafm(i)**2
11626       enddo
11627       dist=dsqrt(dist)
11628       Eafmforce=-forceAFMconst*(dist-distafminit)
11629       do i=1,3
11630       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11631       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11632       enddo
11633 C      print *,'AFM',Eafmforce
11634       return
11635       end
11636 C---------------------------------------------------------
11637 C AFM subroutine with pseudoconstant velocity
11638        subroutine AFMvel(Eafmforce)
11639        implicit real*8 (a-h,o-z)
11640       include 'DIMENSIONS'
11641       include 'COMMON.GEO'
11642       include 'COMMON.VAR'
11643       include 'COMMON.LOCAL'
11644       include 'COMMON.CHAIN'
11645       include 'COMMON.DERIV'
11646       include 'COMMON.NAMES'
11647       include 'COMMON.INTERACT'
11648       include 'COMMON.IOUNITS'
11649       include 'COMMON.CALC'
11650       include 'COMMON.CONTROL'
11651       include 'COMMON.SPLITELE'
11652       include 'COMMON.SBRIDGE'
11653       real*8 diffafm(3)
11654 C Only for check grad COMMENT if not used for checkgrad
11655 C      totT=3.0d0
11656 C--------------------------------------------------------
11657 C      print *,"wchodze"
11658       dist=0.0d0
11659       Eafmforce=0.0d0
11660       do i=1,3
11661       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11662       dist=dist+diffafm(i)**2
11663       enddo
11664       dist=dsqrt(dist)
11665       Eafmforce=0.5d0*forceAFMconst
11666      & *(distafminit+totTafm*velAFMconst-dist)**2
11667 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11668       do i=1,3
11669       gradafm(i,afmend-1)=-forceAFMconst*
11670      &(distafminit+totTafm*velAFMconst-dist)
11671      &*diffafm(i)/dist
11672       gradafm(i,afmbeg-1)=forceAFMconst*
11673      &(distafminit+totTafm*velAFMconst-dist)
11674      &*diffafm(i)/dist
11675       enddo
11676 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11677       return
11678       end
11679 C-----------------------------------------------------------
11680 C first for shielding is setting of function of side-chains
11681        subroutine set_shield_fac
11682       implicit real*8 (a-h,o-z)
11683       include 'DIMENSIONS'
11684       include 'COMMON.CHAIN'
11685       include 'COMMON.DERIV'
11686       include 'COMMON.IOUNITS'
11687       include 'COMMON.SHIELD'
11688       include 'COMMON.INTERACT'
11689 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11690       double precision div77_81/0.974996043d0/,
11691      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11692
11693 C the vector between center of side_chain and peptide group
11694        double precision pep_side(3),long,side_calf(3),
11695      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11696      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11697 C the line belowe needs to be changed for FGPROC>1
11698       do i=1,nres-1
11699       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11700       ishield_list(i)=0
11701 Cif there two consequtive dummy atoms there is no peptide group between them
11702 C the line below has to be changed for FGPROC>1
11703       VolumeTotal=0.0
11704       do k=1,nres
11705        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11706        dist_pep_side=0.0
11707        dist_side_calf=0.0
11708        do j=1,3
11709 C first lets set vector conecting the ithe side-chain with kth side-chain
11710       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11711 C      pep_side(j)=2.0d0
11712 C and vector conecting the side-chain with its proper calfa
11713       side_calf(j)=c(j,k+nres)-c(j,k)
11714 C      side_calf(j)=2.0d0
11715       pept_group(j)=c(j,i)-c(j,i+1)
11716 C lets have their lenght
11717       dist_pep_side=pep_side(j)**2+dist_pep_side
11718       dist_side_calf=dist_side_calf+side_calf(j)**2
11719       dist_pept_group=dist_pept_group+pept_group(j)**2
11720       enddo
11721        dist_pep_side=dsqrt(dist_pep_side)
11722        dist_pept_group=dsqrt(dist_pept_group)
11723        dist_side_calf=dsqrt(dist_side_calf)
11724       do j=1,3
11725         pep_side_norm(j)=pep_side(j)/dist_pep_side
11726         side_calf_norm(j)=dist_side_calf
11727       enddo
11728 C now sscale fraction
11729        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11730 C       print *,buff_shield,"buff"
11731 C now sscale
11732         if (sh_frac_dist.le.0.0) cycle
11733 C If we reach here it means that this side chain reaches the shielding sphere
11734 C Lets add him to the list for gradient
11735         ishield_list(i)=ishield_list(i)+1
11736 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11737 C this list is essential otherwise problem would be O3
11738         shield_list(ishield_list(i),i)=k
11739 C Lets have the sscale value
11740         if (sh_frac_dist.gt.1.0) then
11741          scale_fac_dist=1.0d0
11742          do j=1,3
11743          sh_frac_dist_grad(j)=0.0d0
11744          enddo
11745         else
11746          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11747      &                   *(2.0*sh_frac_dist-3.0d0)
11748          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11749      &                  /dist_pep_side/buff_shield*0.5
11750 C remember for the final gradient multiply sh_frac_dist_grad(j)
11751 C for side_chain by factor -2 !
11752          do j=1,3
11753          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11754 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11755 C     &                    sh_frac_dist_grad(j)
11756          enddo
11757         endif
11758 C        if ((i.eq.3).and.(k.eq.2)) then
11759 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11760 C     & ,"TU"
11761 C        endif
11762
11763 C this is what is now we have the distance scaling now volume...
11764       short=short_r_sidechain(itype(k))
11765       long=long_r_sidechain(itype(k))
11766       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11767 C now costhet_grad
11768 C       costhet=0.0d0
11769        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11770 C       costhet_fac=0.0d0
11771        do j=1,3
11772          costhet_grad(j)=costhet_fac*pep_side(j)
11773        enddo
11774 C remember for the final gradient multiply costhet_grad(j)
11775 C for side_chain by factor -2 !
11776 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11777 C pep_side0pept_group is vector multiplication
11778       pep_side0pept_group=0.0
11779       do j=1,3
11780       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11781       enddo
11782       cosalfa=(pep_side0pept_group/
11783      & (dist_pep_side*dist_side_calf))
11784       fac_alfa_sin=1.0-cosalfa**2
11785       fac_alfa_sin=dsqrt(fac_alfa_sin)
11786       rkprim=fac_alfa_sin*(long-short)+short
11787 C now costhet_grad
11788        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11789        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11790
11791        do j=1,3
11792          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11793      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11794      &*(long-short)/fac_alfa_sin*cosalfa/
11795      &((dist_pep_side*dist_side_calf))*
11796      &((side_calf(j))-cosalfa*
11797      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11798
11799         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11800      &*(long-short)/fac_alfa_sin*cosalfa
11801      &/((dist_pep_side*dist_side_calf))*
11802      &(pep_side(j)-
11803      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11804        enddo
11805
11806       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11807      &                    /VSolvSphere_div
11808      &                    *wshield
11809 C now the gradient...
11810 C grad_shield is gradient of Calfa for peptide groups
11811 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11812 C     &               costhet,cosphi
11813 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11814 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11815       do j=1,3
11816       grad_shield(j,i)=grad_shield(j,i)
11817 C gradient po skalowaniu
11818      &                +(sh_frac_dist_grad(j)
11819 C  gradient po costhet
11820      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11821      &-scale_fac_dist*(cosphi_grad_long(j))
11822      &/(1.0-cosphi) )*div77_81
11823      &*VofOverlap
11824 C grad_shield_side is Cbeta sidechain gradient
11825       grad_shield_side(j,ishield_list(i),i)=
11826      &        (sh_frac_dist_grad(j)*-2.0d0
11827      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11828      &       +scale_fac_dist*(cosphi_grad_long(j))
11829      &        *2.0d0/(1.0-cosphi))
11830      &        *div77_81*VofOverlap
11831
11832        grad_shield_loc(j,ishield_list(i),i)=
11833      &   scale_fac_dist*cosphi_grad_loc(j)
11834      &        *2.0d0/(1.0-cosphi)
11835      &        *div77_81*VofOverlap
11836       enddo
11837       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11838       enddo
11839       fac_shield(i)=VolumeTotal*div77_81+div4_81
11840 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11841       enddo
11842       return
11843       end
11844 C--------------------------------------------------------------------------
11845       double precision function tschebyshev(m,n,x,y)
11846       implicit none
11847       include "DIMENSIONS"
11848       integer i,m,n
11849       double precision x(n),y,yy(0:maxvar),aux
11850 c Tschebyshev polynomial. Note that the first term is omitted
11851 c m=0: the constant term is included
11852 c m=1: the constant term is not included
11853       yy(0)=1.0d0
11854       yy(1)=y
11855       do i=2,n
11856         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11857       enddo
11858       aux=0.0d0
11859       do i=m,n
11860         aux=aux+x(i)*yy(i)
11861       enddo
11862       tschebyshev=aux
11863       return
11864       end
11865 C--------------------------------------------------------------------------
11866       double precision function gradtschebyshev(m,n,x,y)
11867       implicit none
11868       include "DIMENSIONS"
11869       integer i,m,n
11870       double precision x(n+1),y,yy(0:maxvar),aux
11871 c Tschebyshev polynomial. Note that the first term is omitted
11872 c m=0: the constant term is included
11873 c m=1: the constant term is not included
11874       yy(0)=1.0d0
11875       yy(1)=2.0d0*y
11876       do i=2,n
11877         yy(i)=2*y*yy(i-1)-yy(i-2)
11878       enddo
11879       aux=0.0d0
11880       do i=m,n
11881         aux=aux+x(i+1)*yy(i)*(i+1)
11882 C        print *, x(i+1),yy(i),i
11883       enddo
11884       gradtschebyshev=aux
11885       return
11886       end
11887 C------------------------------------------------------------------------
11888 C first for shielding is setting of function of side-chains
11889        subroutine set_shield_fac2
11890       implicit real*8 (a-h,o-z)
11891       include 'DIMENSIONS'
11892       include 'COMMON.CHAIN'
11893       include 'COMMON.DERIV'
11894       include 'COMMON.IOUNITS'
11895       include 'COMMON.SHIELD'
11896       include 'COMMON.INTERACT'
11897       include 'COMMON.LOCAL'
11898
11899 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11900       double precision div77_81/0.974996043d0/,
11901      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11902
11903 C the vector between center of side_chain and peptide group
11904        double precision pep_side(3),long,side_calf(3),
11905      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11906      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11907 C      write(2,*) "ivec",ivec_start,ivec_end
11908       do i=1,nres
11909         fac_shield(i)=0.0d0
11910         do j=1,3
11911         grad_shield(j,i)=0.0d0
11912         enddo
11913       enddo
11914 C the line belowe needs to be changed for FGPROC>1
11915       do i=ivec_start,ivec_end
11916 C      do i=1,nres-1
11917 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11918       ishield_list(i)=0
11919       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11920 Cif there two consequtive dummy atoms there is no peptide group between them
11921 C the line below has to be changed for FGPROC>1
11922       VolumeTotal=0.0
11923       do k=1,nres
11924        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11925        dist_pep_side=0.0
11926        dist_side_calf=0.0
11927        do j=1,3
11928 C first lets set vector conecting the ithe side-chain with kth side-chain
11929       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11930 C      pep_side(j)=2.0d0
11931 C and vector conecting the side-chain with its proper calfa
11932       side_calf(j)=c(j,k+nres)-c(j,k)
11933 C      side_calf(j)=2.0d0
11934       pept_group(j)=c(j,i)-c(j,i+1)
11935 C lets have their lenght
11936       dist_pep_side=pep_side(j)**2+dist_pep_side
11937       dist_side_calf=dist_side_calf+side_calf(j)**2
11938       dist_pept_group=dist_pept_group+pept_group(j)**2
11939       enddo
11940        dist_pep_side=dsqrt(dist_pep_side)
11941        dist_pept_group=dsqrt(dist_pept_group)
11942        dist_side_calf=dsqrt(dist_side_calf)
11943       do j=1,3
11944         pep_side_norm(j)=pep_side(j)/dist_pep_side
11945         side_calf_norm(j)=dist_side_calf
11946       enddo
11947 C now sscale fraction
11948        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11949 C       print *,buff_shield,"buff"
11950 C now sscale
11951         if (sh_frac_dist.le.0.0) cycle
11952 C        print *,ishield_list(i),i
11953 C If we reach here it means that this side chain reaches the shielding sphere
11954 C Lets add him to the list for gradient
11955         ishield_list(i)=ishield_list(i)+1
11956 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11957 C this list is essential otherwise problem would be O3
11958         shield_list(ishield_list(i),i)=k
11959 C Lets have the sscale value
11960         if (sh_frac_dist.gt.1.0) then
11961          scale_fac_dist=1.0d0
11962          do j=1,3
11963          sh_frac_dist_grad(j)=0.0d0
11964          enddo
11965         else
11966          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11967      &                   *(2.0d0*sh_frac_dist-3.0d0)
11968          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11969      &                  /dist_pep_side/buff_shield*0.5d0
11970 C remember for the final gradient multiply sh_frac_dist_grad(j)
11971 C for side_chain by factor -2 !
11972          do j=1,3
11973          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11974 C         sh_frac_dist_grad(j)=0.0d0
11975 C         scale_fac_dist=1.0d0
11976 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11977 C     &                    sh_frac_dist_grad(j)
11978          enddo
11979         endif
11980 C this is what is now we have the distance scaling now volume...
11981       short=short_r_sidechain(itype(k))
11982       long=long_r_sidechain(itype(k))
11983       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11984       sinthet=short/dist_pep_side*costhet
11985 C now costhet_grad
11986 C       costhet=0.6d0
11987 C       sinthet=0.8
11988        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11989 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11990 C     &             -short/dist_pep_side**2/costhet)
11991 C       costhet_fac=0.0d0
11992        do j=1,3
11993          costhet_grad(j)=costhet_fac*pep_side(j)
11994        enddo
11995 C remember for the final gradient multiply costhet_grad(j)
11996 C for side_chain by factor -2 !
11997 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11998 C pep_side0pept_group is vector multiplication
11999       pep_side0pept_group=0.0d0
12000       do j=1,3
12001       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12002       enddo
12003       cosalfa=(pep_side0pept_group/
12004      & (dist_pep_side*dist_side_calf))
12005       fac_alfa_sin=1.0d0-cosalfa**2
12006       fac_alfa_sin=dsqrt(fac_alfa_sin)
12007       rkprim=fac_alfa_sin*(long-short)+short
12008 C      rkprim=short
12009
12010 C now costhet_grad
12011        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12012 C       cosphi=0.6
12013        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12014        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12015      &      dist_pep_side**2)
12016 C       sinphi=0.8
12017        do j=1,3
12018          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12019      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12020      &*(long-short)/fac_alfa_sin*cosalfa/
12021      &((dist_pep_side*dist_side_calf))*
12022      &((side_calf(j))-cosalfa*
12023      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12024 C       cosphi_grad_long(j)=0.0d0
12025         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12026      &*(long-short)/fac_alfa_sin*cosalfa
12027      &/((dist_pep_side*dist_side_calf))*
12028      &(pep_side(j)-
12029      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12030 C       cosphi_grad_loc(j)=0.0d0
12031        enddo
12032 C      print *,sinphi,sinthet
12033       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12034      &                    /VSolvSphere_div
12035 C     &                    *wshield
12036 C now the gradient...
12037       do j=1,3
12038       grad_shield(j,i)=grad_shield(j,i)
12039 C gradient po skalowaniu
12040      &                +(sh_frac_dist_grad(j)*VofOverlap
12041 C  gradient po costhet
12042      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12043      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12044      &       sinphi/sinthet*costhet*costhet_grad(j)
12045      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12046      & )*wshield
12047 C grad_shield_side is Cbeta sidechain gradient
12048       grad_shield_side(j,ishield_list(i),i)=
12049      &        (sh_frac_dist_grad(j)*-2.0d0
12050      &        *VofOverlap
12051      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12052      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12053      &       sinphi/sinthet*costhet*costhet_grad(j)
12054      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12055      &       )*wshield
12056
12057        grad_shield_loc(j,ishield_list(i),i)=
12058      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12059      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12060      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12061      &        ))
12062      &        *wshield
12063       enddo
12064       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12065       enddo
12066       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12067 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12068       enddo
12069       return
12070       end
12071 C-----------------------------------------------------------------------
12072 C-----------------------------------------------------------
12073 C This subroutine is to mimic the histone like structure but as well can be
12074 C utilizet to nanostructures (infinit) small modification has to be used to
12075 C make it finite (z gradient at the ends has to be changes as well as the x,y
12076 C gradient has to be modified at the ends
12077 C The energy function is Kihara potential
12078 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12079 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12080 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12081 C simple Kihara potential
12082       subroutine calctube(Etube)
12083        implicit real*8 (a-h,o-z)
12084       include 'DIMENSIONS'
12085       include 'COMMON.GEO'
12086       include 'COMMON.VAR'
12087       include 'COMMON.LOCAL'
12088       include 'COMMON.CHAIN'
12089       include 'COMMON.DERIV'
12090       include 'COMMON.NAMES'
12091       include 'COMMON.INTERACT'
12092       include 'COMMON.IOUNITS'
12093       include 'COMMON.CALC'
12094       include 'COMMON.CONTROL'
12095       include 'COMMON.SPLITELE'
12096       include 'COMMON.SBRIDGE'
12097       double precision tub_r,vectube(3),enetube(maxres*2)
12098       Etube=0.0d0
12099       do i=1,2*nres
12100         enetube(i)=0.0d0
12101       enddo
12102 C first we calculate the distance from tube center
12103 C first sugare-phosphate group for NARES this would be peptide group
12104 C for UNRES
12105       do i=1,nres
12106 C lets ommit dummy atoms for now
12107        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12108 C now calculate distance from center of tube and direction vectors
12109       xmin=boxxsize
12110       ymin=boxysize
12111         do j=-1,1
12112          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12113          vectube(1)=vectube(1)+boxxsize*j
12114          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12115          vectube(2)=vectube(2)+boxysize*j
12116
12117          xminact=abs(vectube(1)-tubecenter(1))
12118          yminact=abs(vectube(2)-tubecenter(2))
12119            if (xmin.gt.xminact) then
12120             xmin=xminact
12121             xtemp=vectube(1)
12122            endif
12123            if (ymin.gt.yminact) then
12124              ymin=yminact
12125              ytemp=vectube(2)
12126             endif
12127          enddo
12128       vectube(1)=xtemp
12129       vectube(2)=ytemp
12130       vectube(1)=vectube(1)-tubecenter(1)
12131       vectube(2)=vectube(2)-tubecenter(2)
12132
12133 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12134 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12135
12136 C as the tube is infinity we do not calculate the Z-vector use of Z
12137 C as chosen axis
12138       vectube(3)=0.0d0
12139 C now calculte the distance
12140        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12141 C now normalize vector
12142       vectube(1)=vectube(1)/tub_r
12143       vectube(2)=vectube(2)/tub_r
12144 C calculte rdiffrence between r and r0
12145       rdiff=tub_r-tubeR0
12146 C and its 6 power
12147       rdiff6=rdiff**6.0d0
12148 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12149        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12150 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12151 C       print *,rdiff,rdiff6,pep_aa_tube
12152 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12153 C now we calculate gradient
12154        fac=(-12.0d0*pep_aa_tube/rdiff6-
12155      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12156 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12157 C     &rdiff,fac
12158
12159 C now direction of gg_tube vector
12160         do j=1,3
12161         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12162         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12163         enddo
12164         enddo
12165 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12166         do i=1,nres
12167 C Lets not jump over memory as we use many times iti
12168          iti=itype(i)
12169 C lets ommit dummy atoms for now
12170          if ((iti.eq.ntyp1)
12171 C in UNRES uncomment the line below as GLY has no side-chain...
12172 C      .or.(iti.eq.10)
12173      &   ) cycle
12174       xmin=boxxsize
12175       ymin=boxysize
12176         do j=-1,1
12177          vectube(1)=mod((c(1,i+nres)),boxxsize)
12178          vectube(1)=vectube(1)+boxxsize*j
12179          vectube(2)=mod((c(2,i+nres)),boxysize)
12180          vectube(2)=vectube(2)+boxysize*j
12181
12182          xminact=abs(vectube(1)-tubecenter(1))
12183          yminact=abs(vectube(2)-tubecenter(2))
12184            if (xmin.gt.xminact) then
12185             xmin=xminact
12186             xtemp=vectube(1)
12187            endif
12188            if (ymin.gt.yminact) then
12189              ymin=yminact
12190              ytemp=vectube(2)
12191             endif
12192          enddo
12193       vectube(1)=xtemp
12194       vectube(2)=ytemp
12195 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12196 C     &     tubecenter(2)
12197       vectube(1)=vectube(1)-tubecenter(1)
12198       vectube(2)=vectube(2)-tubecenter(2)
12199
12200 C as the tube is infinity we do not calculate the Z-vector use of Z
12201 C as chosen axis
12202       vectube(3)=0.0d0
12203 C now calculte the distance
12204        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12205 C now normalize vector
12206       vectube(1)=vectube(1)/tub_r
12207       vectube(2)=vectube(2)/tub_r
12208
12209 C calculte rdiffrence between r and r0
12210       rdiff=tub_r-tubeR0
12211 C and its 6 power
12212       rdiff6=rdiff**6.0d0
12213 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12214        sc_aa_tube=sc_aa_tube_par(iti)
12215        sc_bb_tube=sc_bb_tube_par(iti)
12216        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12217 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12218 C now we calculate gradient
12219        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12220      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12221 C now direction of gg_tube vector
12222          do j=1,3
12223           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12224           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12225          enddo
12226         enddo
12227         do i=1,2*nres
12228           Etube=Etube+enetube(i)
12229         enddo
12230 C        print *,"ETUBE", etube
12231         return
12232         end
12233 C TO DO 1) add to total energy
12234 C       2) add to gradient summation
12235 C       3) add reading parameters (AND of course oppening of PARAM file)
12236 C       4) add reading the center of tube
12237 C       5) add COMMONs
12238 C       6) add to zerograd
12239
12240 C-----------------------------------------------------------------------
12241 C-----------------------------------------------------------
12242 C This subroutine is to mimic the histone like structure but as well can be
12243 C utilizet to nanostructures (infinit) small modification has to be used to
12244 C make it finite (z gradient at the ends has to be changes as well as the x,y
12245 C gradient has to be modified at the ends
12246 C The energy function is Kihara potential
12247 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12248 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12249 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12250 C simple Kihara potential
12251       subroutine calctube2(Etube)
12252        implicit real*8 (a-h,o-z)
12253       include 'DIMENSIONS'
12254       include 'COMMON.GEO'
12255       include 'COMMON.VAR'
12256       include 'COMMON.LOCAL'
12257       include 'COMMON.CHAIN'
12258       include 'COMMON.DERIV'
12259       include 'COMMON.NAMES'
12260       include 'COMMON.INTERACT'
12261       include 'COMMON.IOUNITS'
12262       include 'COMMON.CALC'
12263       include 'COMMON.CONTROL'
12264       include 'COMMON.SPLITELE'
12265       include 'COMMON.SBRIDGE'
12266       double precision tub_r,vectube(3),enetube(maxres*2)
12267       Etube=0.0d0
12268       do i=1,2*nres
12269         enetube(i)=0.0d0
12270       enddo
12271 C first we calculate the distance from tube center
12272 C first sugare-phosphate group for NARES this would be peptide group
12273 C for UNRES
12274       do i=1,nres
12275 C lets ommit dummy atoms for now
12276
12277        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12278 C now calculate distance from center of tube and direction vectors
12279       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12280           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12281       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12282           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12283       vectube(1)=vectube(1)-tubecenter(1)
12284       vectube(2)=vectube(2)-tubecenter(2)
12285
12286 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12287 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12288
12289 C as the tube is infinity we do not calculate the Z-vector use of Z
12290 C as chosen axis
12291       vectube(3)=0.0d0
12292 C now calculte the distance
12293        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12294 C now normalize vector
12295       vectube(1)=vectube(1)/tub_r
12296       vectube(2)=vectube(2)/tub_r
12297 C calculte rdiffrence between r and r0
12298       rdiff=tub_r-tubeR0
12299 C and its 6 power
12300       rdiff6=rdiff**6.0d0
12301 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12302        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12303 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12304 C       print *,rdiff,rdiff6,pep_aa_tube
12305 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12306 C now we calculate gradient
12307        fac=(-12.0d0*pep_aa_tube/rdiff6-
12308      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12309 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12310 C     &rdiff,fac
12311
12312 C now direction of gg_tube vector
12313         do j=1,3
12314         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12315         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12316         enddo
12317         enddo
12318 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12319         do i=1,nres
12320 C Lets not jump over memory as we use many times iti
12321          iti=itype(i)
12322 C lets ommit dummy atoms for now
12323          if ((iti.eq.ntyp1)
12324 C in UNRES uncomment the line below as GLY has no side-chain...
12325      &      .or.(iti.eq.10)
12326      &   ) cycle
12327           vectube(1)=c(1,i+nres)
12328           vectube(1)=mod(vectube(1),boxxsize)
12329           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12330           vectube(2)=c(2,i+nres)
12331           vectube(2)=mod(vectube(2),boxysize)
12332           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12333
12334       vectube(1)=vectube(1)-tubecenter(1)
12335       vectube(2)=vectube(2)-tubecenter(2)
12336 C THIS FRAGMENT MAKES TUBE FINITE
12337         positi=(mod(c(3,i+nres),boxzsize))
12338         if (positi.le.0) positi=positi+boxzsize
12339 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12340 c for each residue check if it is in lipid or lipid water border area
12341 C       respos=mod(c(3,i+nres),boxzsize)
12342        print *,positi,bordtubebot,buftubebot,bordtubetop
12343        if ((positi.gt.bordtubebot)
12344      & .and.(positi.lt.bordtubetop)) then
12345 C the energy transfer exist
12346         if (positi.lt.buftubebot) then
12347          fracinbuf=1.0d0-
12348      &     ((positi-bordtubebot)/tubebufthick)
12349 C lipbufthick is thickenes of lipid buffore
12350          sstube=sscalelip(fracinbuf)
12351          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12352          print *,ssgradtube, sstube,tubetranene(itype(i))
12353          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12354 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12355 C     &+ssgradtube*tubetranene(itype(i))
12356 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12357 C     &+ssgradtube*tubetranene(itype(i))
12358 C         print *,"doing sccale for lower part"
12359         elseif (positi.gt.buftubetop) then
12360          fracinbuf=1.0d0-
12361      &((bordtubetop-positi)/tubebufthick)
12362          sstube=sscalelip(fracinbuf)
12363          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12364          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12365 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12366 C     &+ssgradtube*tubetranene(itype(i))
12367 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12368 C     &+ssgradtube*tubetranene(itype(i))
12369 C          print *, "doing sscalefor top part",sslip,fracinbuf
12370         else
12371          sstube=1.0d0
12372          ssgradtube=0.0d0
12373          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12374 C         print *,"I am in true lipid"
12375         endif
12376         else
12377 C          sstube=0.0d0
12378 C          ssgradtube=0.0d0
12379         cycle
12380         endif ! if in lipid or buffor
12381 CEND OF FINITE FRAGMENT
12382 C as the tube is infinity we do not calculate the Z-vector use of Z
12383 C as chosen axis
12384       vectube(3)=0.0d0
12385 C now calculte the distance
12386        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12387 C now normalize vector
12388       vectube(1)=vectube(1)/tub_r
12389       vectube(2)=vectube(2)/tub_r
12390 C calculte rdiffrence between r and r0
12391       rdiff=tub_r-tubeR0
12392 C and its 6 power
12393       rdiff6=rdiff**6.0d0
12394 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12395        sc_aa_tube=sc_aa_tube_par(iti)
12396        sc_bb_tube=sc_bb_tube_par(iti)
12397        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12398      &                 *sstube+enetube(i+nres)
12399 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12400 C now we calculate gradient
12401        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12402      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12403 C now direction of gg_tube vector
12404          do j=1,3
12405           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12406           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12407          enddo
12408          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12409      &+ssgradtube*enetube(i+nres)/sstube
12410          gg_tube(3,i-1)= gg_tube(3,i-1)
12411      &+ssgradtube*enetube(i+nres)/sstube
12412
12413         enddo
12414         do i=1,2*nres
12415           Etube=Etube+enetube(i)
12416         enddo
12417 C        print *,"ETUBE", etube
12418         return
12419         end
12420 C TO DO 1) add to total energy
12421 C       2) add to gradient summation
12422 C       3) add reading parameters (AND of course oppening of PARAM file)
12423 C       4) add reading the center of tube
12424 C       5) add COMMONs
12425 C       6) add to zerograd
12426