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           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3640           ymedi=mod(ymedi,boxysize)
3641           if (ymedi.lt.0) ymedi=ymedi+boxysize
3642           zmedi=mod(zmedi,boxzsize)
3643           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3644           zmedi2=mod(zmedi,boxzsize)
3645           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3646        if ((zmedi2.gt.bordlipbot)
3647      &.and.(zmedi2.lt.bordliptop)) then
3648 C the energy transfer exist
3649         if (zmedi2.lt.buflipbot) then
3650 C what fraction I am in
3651          fracinbuf=1.0d0-
3652      &        ((zmedi2-bordlipbot)/lipbufthick)
3653 C lipbufthick is thickenes of lipid buffore
3654          sslipi=sscalelip(fracinbuf)
3655          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3656         elseif (zmedi2.gt.bufliptop) then
3657          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3658          sslipi=sscalelip(fracinbuf)
3659          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3660         else
3661          sslipi=1.0d0
3662          ssgradlipi=0.0
3663         endif
3664        else
3665          sslipi=0.0d0
3666          ssgradlipi=0.0
3667        endif
3668         num_conti=num_cont_hb(i)
3669 c        write(iout,*) "JESTEM W PETLI"
3670         call eelecij(i,i+3,ees,evdw1,eel_loc)
3671         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3672      &   call eturn4(i,eello_turn4)
3673         num_cont_hb(i)=num_conti
3674       enddo   ! i
3675 C Loop over all neighbouring boxes
3676 C      do xshift=-1,1
3677 C      do yshift=-1,1
3678 C      do zshift=-1,1
3679 c
3680 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3681 c
3682 CTU KURWA
3683       do i=iatel_s,iatel_e
3684 C        do i=75,75
3685 c        if (i.le.1) cycle
3686         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3687 C changes suggested by Ana to avoid out of bounds
3688 c     & .or.((i+2).gt.nres)
3689 c     & .or.((i-1).le.0)
3690 C end of changes by Ana
3691 c     &  .or. itype(i+2).eq.ntyp1
3692 c     &  .or. itype(i-1).eq.ntyp1
3693      &                ) cycle
3694         dxi=dc(1,i)
3695         dyi=dc(2,i)
3696         dzi=dc(3,i)
3697         dx_normi=dc_norm(1,i)
3698         dy_normi=dc_norm(2,i)
3699         dz_normi=dc_norm(3,i)
3700         xmedi=c(1,i)+0.5d0*dxi
3701         ymedi=c(2,i)+0.5d0*dyi
3702         zmedi=c(3,i)+0.5d0*dzi
3703           xmedi=mod(xmedi,boxxsize)
3704           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3705           ymedi=mod(ymedi,boxysize)
3706           if (ymedi.lt.0) ymedi=ymedi+boxysize
3707           zmedi=mod(zmedi,boxzsize)
3708           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3709        if ((zmedi.gt.bordlipbot)
3710      &.and.(zmedi.lt.bordliptop)) then
3711 C the energy transfer exist
3712         if (zmedi.lt.buflipbot) then
3713 C what fraction I am in
3714          fracinbuf=1.0d0-
3715      &        ((zmedi-bordlipbot)/lipbufthick)
3716 C lipbufthick is thickenes of lipid buffore
3717          sslipi=sscalelip(fracinbuf)
3718          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3719         elseif (zmedi.gt.bufliptop) then
3720          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3721          sslipi=sscalelip(fracinbuf)
3722          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3723         else
3724          sslipi=1.0d0
3725          ssgradlipi=0.0
3726         endif
3727        else
3728          sslipi=0.0d0
3729          ssgradlipi=0.0
3730        endif
3731 C         print *,sslipi,"TU?!"
3732 C          xmedi=xmedi+xshift*boxxsize
3733 C          ymedi=ymedi+yshift*boxysize
3734 C          zmedi=zmedi+zshift*boxzsize
3735
3736 C Return tom into box, boxxsize is size of box in x dimension
3737 c  164   continue
3738 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3739 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3740 C Condition for being inside the proper box
3741 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3742 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3743 c        go to 164
3744 c        endif
3745 c  165   continue
3746 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3747 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3748 C Condition for being inside the proper box
3749 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3750 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3751 c        go to 165
3752 c        endif
3753 c  166   continue
3754 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3755 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3756 cC Condition for being inside the proper box
3757 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3758 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3759 c        go to 166
3760 c        endif
3761
3762 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3763         num_conti=num_cont_hb(i)
3764 C I TU KURWA
3765         do j=ielstart(i),ielend(i)
3766 C          do j=16,17
3767 C          write (iout,*) i,j
3768 C         if (j.le.1) cycle
3769           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3770 C changes suggested by Ana to avoid out of bounds
3771 c     & .or.((j+2).gt.nres)
3772 c     & .or.((j-1).le.0)
3773 C end of changes by Ana
3774 c     & .or.itype(j+2).eq.ntyp1
3775 c     & .or.itype(j-1).eq.ntyp1
3776      &) cycle
3777           call eelecij(i,j,ees,evdw1,eel_loc)
3778         enddo ! j
3779         num_cont_hb(i)=num_conti
3780       enddo   ! i
3781 C     enddo   ! zshift
3782 C      enddo   ! yshift
3783 C      enddo   ! xshift
3784
3785 c      write (iout,*) "Number of loop steps in EELEC:",ind
3786 cd      do i=1,nres
3787 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3788 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3789 cd      enddo
3790 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3791 ccc      eel_loc=eel_loc+eello_turn3
3792 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3793       return
3794       end
3795 C-------------------------------------------------------------------------------
3796       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3797       implicit real*8 (a-h,o-z)
3798       include 'DIMENSIONS'
3799 #ifdef MPI
3800       include "mpif.h"
3801 #endif
3802       include 'COMMON.CONTROL'
3803       include 'COMMON.IOUNITS'
3804       include 'COMMON.GEO'
3805       include 'COMMON.VAR'
3806       include 'COMMON.LOCAL'
3807       include 'COMMON.CHAIN'
3808       include 'COMMON.DERIV'
3809       include 'COMMON.INTERACT'
3810       include 'COMMON.CONTACTS'
3811       include 'COMMON.TORSION'
3812       include 'COMMON.VECTORS'
3813       include 'COMMON.FFIELD'
3814       include 'COMMON.TIME1'
3815       include 'COMMON.SPLITELE'
3816       include 'COMMON.SHIELD'
3817       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3818      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3819       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3820      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3821      &    gmuij2(4),gmuji2(4)
3822       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3823      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3824      &    num_conti,j1,j2
3825 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3826 #ifdef MOMENT
3827       double precision scal_el /1.0d0/
3828 #else
3829       double precision scal_el /0.5d0/
3830 #endif
3831 C 12/13/98
3832 C 13-go grudnia roku pamietnego...
3833       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3834      &                   0.0d0,1.0d0,0.0d0,
3835      &                   0.0d0,0.0d0,1.0d0/
3836        integer xshift,yshift,zshift
3837 c          time00=MPI_Wtime()
3838 cd      write (iout,*) "eelecij",i,j
3839 c          ind=ind+1
3840           iteli=itel(i)
3841           itelj=itel(j)
3842           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3843           aaa=app(iteli,itelj)
3844           bbb=bpp(iteli,itelj)
3845           ael6i=ael6(iteli,itelj)
3846           ael3i=ael3(iteli,itelj)
3847           dxj=dc(1,j)
3848           dyj=dc(2,j)
3849           dzj=dc(3,j)
3850           dx_normj=dc_norm(1,j)
3851           dy_normj=dc_norm(2,j)
3852           dz_normj=dc_norm(3,j)
3853 C          xj=c(1,j)+0.5D0*dxj-xmedi
3854 C          yj=c(2,j)+0.5D0*dyj-ymedi
3855 C          zj=c(3,j)+0.5D0*dzj-zmedi
3856           xj=c(1,j)+0.5D0*dxj
3857           yj=c(2,j)+0.5D0*dyj
3858           zj=c(3,j)+0.5D0*dzj
3859           xj=mod(xj,boxxsize)
3860           if (xj.lt.0) xj=xj+boxxsize
3861           yj=mod(yj,boxysize)
3862           if (yj.lt.0) yj=yj+boxysize
3863           zj=mod(zj,boxzsize)
3864           if (zj.lt.0) zj=zj+boxzsize
3865           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3866        if ((zj.gt.bordlipbot)
3867      &.and.(zj.lt.bordliptop)) then
3868 C the energy transfer exist
3869         if (zj.lt.buflipbot) then
3870 C what fraction I am in
3871          fracinbuf=1.0d0-
3872      &        ((zj-bordlipbot)/lipbufthick)
3873 C lipbufthick is thickenes of lipid buffore
3874          sslipj=sscalelip(fracinbuf)
3875          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3876         elseif (zj.gt.bufliptop) then
3877          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3878          sslipj=sscalelip(fracinbuf)
3879          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3880         else
3881          sslipj=1.0d0
3882          ssgradlipj=0.0
3883         endif
3884        else
3885          sslipj=0.0d0
3886          ssgradlipj=0.0
3887        endif
3888       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3889       xj_safe=xj
3890       yj_safe=yj
3891       zj_safe=zj
3892       isubchap=0
3893       do xshift=-1,1
3894       do yshift=-1,1
3895       do zshift=-1,1
3896           xj=xj_safe+xshift*boxxsize
3897           yj=yj_safe+yshift*boxysize
3898           zj=zj_safe+zshift*boxzsize
3899           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3900           if(dist_temp.lt.dist_init) then
3901             dist_init=dist_temp
3902             xj_temp=xj
3903             yj_temp=yj
3904             zj_temp=zj
3905             isubchap=1
3906           endif
3907        enddo
3908        enddo
3909        enddo
3910        if (isubchap.eq.1) then
3911           xj=xj_temp-xmedi
3912           yj=yj_temp-ymedi
3913           zj=zj_temp-zmedi
3914        else
3915           xj=xj_safe-xmedi
3916           yj=yj_safe-ymedi
3917           zj=zj_safe-zmedi
3918        endif
3919 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3920 c  174   continue
3921 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3922 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3923 C Condition for being inside the proper box
3924 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3925 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3926 c        go to 174
3927 c        endif
3928 c  175   continue
3929 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3930 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3931 C Condition for being inside the proper box
3932 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3933 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3934 c        go to 175
3935 c        endif
3936 c  176   continue
3937 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3938 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3939 C Condition for being inside the proper box
3940 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3941 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3942 c        go to 176
3943 c        endif
3944 C        endif !endPBC condintion
3945 C        xj=xj-xmedi
3946 C        yj=yj-ymedi
3947 C        zj=zj-zmedi
3948           rij=xj*xj+yj*yj+zj*zj
3949
3950             sss=sscale(sqrt(rij))
3951             sssgrad=sscagrad(sqrt(rij))
3952 c            if (sss.gt.0.0d0) then
3953           rrmij=1.0D0/rij
3954           rij=dsqrt(rij)
3955           rmij=1.0D0/rij
3956           r3ij=rrmij*rmij
3957           r6ij=r3ij*r3ij
3958           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3959           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3960           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3961           fac=cosa-3.0D0*cosb*cosg
3962           ev1=aaa*r6ij*r6ij
3963 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3964           if (j.eq.i+2) ev1=scal_el*ev1
3965           ev2=bbb*r6ij
3966           fac3=ael6i*r6ij
3967           fac4=ael3i*r3ij
3968           evdwij=(ev1+ev2)
3969           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3970           el2=fac4*fac
3971 C MARYSIA
3972 C          eesij=(el1+el2)
3973 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3974           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3975           if (shield_mode.gt.0) then
3976 C          fac_shield(i)=0.4
3977 C          fac_shield(j)=0.6
3978           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3979           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3980           eesij=(el1+el2)
3981           ees=ees+eesij
3982 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3983 C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3984           else
3985           fac_shield(i)=1.0
3986           fac_shield(j)=1.0
3987           eesij=(el1+el2)
3988           ees=ees+eesij
3989      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3990 C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3991           endif
3992           evdw1=evdw1+evdwij*sss
3993      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994 C          print *,sslipi,sslipj,lipscale**2,
3995 C     &     (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3996 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3997 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3998 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3999 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4000
4001           if (energy_dec) then
4002               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4003      &'evdw1',i,j,evdwij
4004      &,iteli,itelj,aaa,evdw1
4005               write (iout,*) sss
4006               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4007      &fac_shield(i),fac_shield(j)
4008           endif
4009
4010 C
4011 C Calculate contributions to the Cartesian gradient.
4012 C
4013 #ifdef SPLITELE
4014           facvdw=-6*rrmij*(ev1+evdwij)*sss
4015      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4016           facel=-3*rrmij*(el1+eesij)
4017      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4018           fac1=fac
4019           erij(1)=xj*rmij
4020           erij(2)=yj*rmij
4021           erij(3)=zj*rmij
4022
4023 *
4024 * Radial derivatives. First process both termini of the fragment (i,j)
4025 *
4026           ggg(1)=facel*xj
4027           ggg(2)=facel*yj
4028           ggg(3)=facel*zj
4029           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4030      &  (shield_mode.gt.0)) then
4031 C          print *,i,j
4032           do ilist=1,ishield_list(i)
4033            iresshield=shield_list(ilist,i)
4034            do k=1,3
4035            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4036      &      *2.0
4037            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4038      &              rlocshield
4039      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4040             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4041 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4042 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4043 C             if (iresshield.gt.i) then
4044 C               do ishi=i+1,iresshield-1
4045 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4046 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4047 C
4048 C              enddo
4049 C             else
4050 C               do ishi=iresshield,i
4051 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4052 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4053 C
4054 C               enddo
4055 C              endif
4056            enddo
4057           enddo
4058           do ilist=1,ishield_list(j)
4059            iresshield=shield_list(ilist,j)
4060            do k=1,3
4061            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4062      &     *2.0
4063            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4064      &              rlocshield
4065      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4066            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4067
4068 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4069 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4070 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4071 C             if (iresshield.gt.j) then
4072 C               do ishi=j+1,iresshield-1
4073 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4074 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4075 C
4076 C               enddo
4077 C            else
4078 C               do ishi=iresshield,j
4079 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4080 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4081 C               enddo
4082 C              endif
4083            enddo
4084           enddo
4085
4086           do k=1,3
4087             gshieldc(k,i)=gshieldc(k,i)+
4088      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4089             gshieldc(k,j)=gshieldc(k,j)+
4090      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4091             gshieldc(k,i-1)=gshieldc(k,i-1)+
4092      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4093             gshieldc(k,j-1)=gshieldc(k,j-1)+
4094      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4095
4096            enddo
4097            endif
4098 c          do k=1,3
4099 c            ghalf=0.5D0*ggg(k)
4100 c            gelc(k,i)=gelc(k,i)+ghalf
4101 c            gelc(k,j)=gelc(k,j)+ghalf
4102 c          enddo
4103 c 9/28/08 AL Gradient compotents will be summed only at the end
4104 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4105           do k=1,3
4106             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4107 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4108             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4109 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4110 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4111 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4112 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4113 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4114           enddo
4115 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4116 C Lipidic part for lipscale
4117             gelc_long(3,j)=gelc_long(3,j)+
4118      &     ssgradlipj*eesij/2.0d0*lipscale**2
4119
4120             gelc_long(3,i)=gelc_long(3,i)+
4121      &     ssgradlipi*eesij/2.0d0*lipscale**2
4122
4123 *
4124 * Loop over residues i+1 thru j-1.
4125 *
4126 cgrad          do k=i+1,j-1
4127 cgrad            do l=1,3
4128 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4129 cgrad            enddo
4130 cgrad          enddo
4131           if (sss.gt.0.0) then
4132           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4133      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4134
4135           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4136      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4137
4138           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4139      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4140           else
4141           ggg(1)=0.0
4142           ggg(2)=0.0
4143           ggg(3)=0.0
4144           endif
4145 c          do k=1,3
4146 c            ghalf=0.5D0*ggg(k)
4147 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4148 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4149 c          enddo
4150 c 9/28/08 AL Gradient compotents will be summed only at the end
4151           do k=1,3
4152             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4153             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4154           enddo
4155 C Lipidic part for scaling weight
4156            gvdwpp(3,j)=gvdwpp(3,j)+
4157      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4158            gvdwpp(3,i)=gvdwpp(3,i)+
4159      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4160
4161 *
4162 * Loop over residues i+1 thru j-1.
4163 *
4164 cgrad          do k=i+1,j-1
4165 cgrad            do l=1,3
4166 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4167 cgrad            enddo
4168 cgrad          enddo
4169 #else
4170 C MARYSIA
4171           facvdw=(ev1+evdwij)*sss
4172      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4173           facel=(el1+eesij)
4174           fac1=fac
4175           fac=-3*rrmij*(facvdw+facvdw+facel)
4176           erij(1)=xj*rmij
4177           erij(2)=yj*rmij
4178           erij(3)=zj*rmij
4179 *
4180 * Radial derivatives. First process both termini of the fragment (i,j)
4181 *
4182           ggg(1)=fac*xj
4183 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4184           ggg(2)=fac*yj
4185 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4186           ggg(3)=fac*zj
4187 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4188 c          do k=1,3
4189 c            ghalf=0.5D0*ggg(k)
4190 c            gelc(k,i)=gelc(k,i)+ghalf
4191 c            gelc(k,j)=gelc(k,j)+ghalf
4192 c          enddo
4193 c 9/28/08 AL Gradient compotents will be summed only at the end
4194           do k=1,3
4195             gelc_long(k,j)=gelc(k,j)+ggg(k)
4196             gelc_long(k,i)=gelc(k,i)-ggg(k)
4197           enddo
4198 *
4199 * Loop over residues i+1 thru j-1.
4200 *
4201 cgrad          do k=i+1,j-1
4202 cgrad            do l=1,3
4203 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4204 cgrad            enddo
4205 cgrad          enddo
4206 c 9/28/08 AL Gradient compotents will be summed only at the end
4207           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4208      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4209
4210           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4211      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4212
4213           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4214      &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4215           do k=1,3
4216             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4217             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4218           enddo
4219            gvdwpp(3,j)=gvdwpp(3,j)+
4220      &     sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4221            gvdwpp(3,i)=gvdwpp(3,i)+
4222      &     sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4223
4224 #endif
4225 *
4226 * Angular part
4227 *
4228           ecosa=2.0D0*fac3*fac1+fac4
4229           fac4=-3.0D0*fac4
4230           fac3=-6.0D0*fac3
4231           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4232           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4233           do k=1,3
4234             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4235             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4236           enddo
4237 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4238 cd   &          (dcosg(k),k=1,3)
4239           do k=1,3
4240             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4241      &      fac_shield(i)**2*fac_shield(j)**2
4242      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4243           enddo
4244 c          do k=1,3
4245 c            ghalf=0.5D0*ggg(k)
4246 c            gelc(k,i)=gelc(k,i)+ghalf
4247 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4248 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4249 c            gelc(k,j)=gelc(k,j)+ghalf
4250 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4251 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4252 c          enddo
4253 cgrad          do k=i+1,j-1
4254 cgrad            do l=1,3
4255 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4256 cgrad            enddo
4257 cgrad          enddo
4258 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4259           do k=1,3
4260             gelc(k,i)=gelc(k,i)
4261      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4262      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4263      &           *fac_shield(i)**2*fac_shield(j)**2
4264      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4265             gelc(k,j)=gelc(k,j)
4266      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4267      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4268      &           *fac_shield(i)**2*fac_shield(j)**2
4269      &      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4270             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4271             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4272           enddo
4273 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4274
4275 C MARYSIA
4276 c          endif !sscale
4277           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4278      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4279      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4280 C
4281 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4282 C   energy of a peptide unit is assumed in the form of a second-order
4283 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4284 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4285 C   are computed for EVERY pair of non-contiguous peptide groups.
4286 C
4287
4288           if (j.lt.nres-1) then
4289             j1=j+1
4290             j2=j-1
4291           else
4292             j1=j-1
4293             j2=j-2
4294           endif
4295           kkk=0
4296           lll=0
4297           do k=1,2
4298             do l=1,2
4299               kkk=kkk+1
4300               muij(kkk)=mu(k,i)*mu(l,j)
4301 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4302 #ifdef NEWCORR
4303              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4304 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4305              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4306              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4307 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4308              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4309 #endif
4310             enddo
4311           enddo
4312 cd         write (iout,*) 'EELEC: i',i,' j',j
4313 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4314 cd          write(iout,*) 'muij',muij
4315           ury=scalar(uy(1,i),erij)
4316           urz=scalar(uz(1,i),erij)
4317           vry=scalar(uy(1,j),erij)
4318           vrz=scalar(uz(1,j),erij)
4319           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4320           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4321           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4322           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4323           fac=dsqrt(-ael6i)*r3ij
4324           a22=a22*fac
4325           a23=a23*fac
4326           a32=a32*fac
4327           a33=a33*fac
4328 cd          write (iout,'(4i5,4f10.5)')
4329 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4330 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4331 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4332 cd     &      uy(:,j),uz(:,j)
4333 cd          write (iout,'(4f10.5)')
4334 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4335 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4336 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4337 cd           write (iout,'(9f10.5/)')
4338 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4339 C Derivatives of the elements of A in virtual-bond vectors
4340           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4341           do k=1,3
4342             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4343             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4344             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4345             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4346             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4347             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4348             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4349             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4350             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4351             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4352             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4353             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4354           enddo
4355 C Compute radial contributions to the gradient
4356           facr=-3.0d0*rrmij
4357           a22der=a22*facr
4358           a23der=a23*facr
4359           a32der=a32*facr
4360           a33der=a33*facr
4361           agg(1,1)=a22der*xj
4362           agg(2,1)=a22der*yj
4363           agg(3,1)=a22der*zj
4364           agg(1,2)=a23der*xj
4365           agg(2,2)=a23der*yj
4366           agg(3,2)=a23der*zj
4367           agg(1,3)=a32der*xj
4368           agg(2,3)=a32der*yj
4369           agg(3,3)=a32der*zj
4370           agg(1,4)=a33der*xj
4371           agg(2,4)=a33der*yj
4372           agg(3,4)=a33der*zj
4373 C Add the contributions coming from er
4374           fac3=-3.0d0*fac
4375           do k=1,3
4376             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4377             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4378             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4379             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4380           enddo
4381           do k=1,3
4382 C Derivatives in DC(i)
4383 cgrad            ghalf1=0.5d0*agg(k,1)
4384 cgrad            ghalf2=0.5d0*agg(k,2)
4385 cgrad            ghalf3=0.5d0*agg(k,3)
4386 cgrad            ghalf4=0.5d0*agg(k,4)
4387             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4388      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4389             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4390      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4391             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4392      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4393             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4394      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4395 C Derivatives in DC(i+1)
4396             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4397      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4398             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4399      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4400             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4401      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4402             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4403      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4404 C Derivatives in DC(j)
4405             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4406      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4407             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4408      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4409             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4410      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4411             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4412      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4413 C Derivatives in DC(j+1) or DC(nres-1)
4414             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4415      &      -3.0d0*vryg(k,3)*ury)
4416             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4417      &      -3.0d0*vrzg(k,3)*ury)
4418             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4419      &      -3.0d0*vryg(k,3)*urz)
4420             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4421      &      -3.0d0*vrzg(k,3)*urz)
4422 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4423 cgrad              do l=1,4
4424 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4425 cgrad              enddo
4426 cgrad            endif
4427           enddo
4428           acipa(1,1)=a22
4429           acipa(1,2)=a23
4430           acipa(2,1)=a32
4431           acipa(2,2)=a33
4432           a22=-a22
4433           a23=-a23
4434           do l=1,2
4435             do k=1,3
4436               agg(k,l)=-agg(k,l)
4437               aggi(k,l)=-aggi(k,l)
4438               aggi1(k,l)=-aggi1(k,l)
4439               aggj(k,l)=-aggj(k,l)
4440               aggj1(k,l)=-aggj1(k,l)
4441             enddo
4442           enddo
4443           if (j.lt.nres-1) then
4444             a22=-a22
4445             a32=-a32
4446             do l=1,3,2
4447               do k=1,3
4448                 agg(k,l)=-agg(k,l)
4449                 aggi(k,l)=-aggi(k,l)
4450                 aggi1(k,l)=-aggi1(k,l)
4451                 aggj(k,l)=-aggj(k,l)
4452                 aggj1(k,l)=-aggj1(k,l)
4453               enddo
4454             enddo
4455           else
4456             a22=-a22
4457             a23=-a23
4458             a32=-a32
4459             a33=-a33
4460             do l=1,4
4461               do k=1,3
4462                 agg(k,l)=-agg(k,l)
4463                 aggi(k,l)=-aggi(k,l)
4464                 aggi1(k,l)=-aggi1(k,l)
4465                 aggj(k,l)=-aggj(k,l)
4466                 aggj1(k,l)=-aggj1(k,l)
4467               enddo
4468             enddo
4469           endif
4470           ENDIF ! WCORR
4471           IF (wel_loc.gt.0.0d0) THEN
4472 C Contribution to the local-electrostatic energy coming from the i-j pair
4473           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4474      &     +a33*muij(4)
4475           if (shield_mode.eq.0) then
4476            fac_shield(i)=1.0
4477            fac_shield(j)=1.0
4478 C          else
4479 C           fac_shield(i)=0.4
4480 C           fac_shield(j)=0.6
4481           endif
4482           eel_loc_ij=eel_loc_ij
4483      &    *fac_shield(i)*fac_shield(j)
4484      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4485
4486 C Now derivative over eel_loc
4487           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4488      &  (shield_mode.gt.0)) then
4489 C          print *,i,j
4490
4491           do ilist=1,ishield_list(i)
4492            iresshield=shield_list(ilist,i)
4493            do k=1,3
4494            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4495      &                                          /fac_shield(i)
4496 C     &      *2.0
4497            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4498      &              rlocshield
4499      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4500             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4501      &      +rlocshield
4502            enddo
4503           enddo
4504           do ilist=1,ishield_list(j)
4505            iresshield=shield_list(ilist,j)
4506            do k=1,3
4507            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4508      &                                       /fac_shield(j)
4509 C     &     *2.0
4510            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4511      &              rlocshield
4512      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4513            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4514      &             +rlocshield
4515
4516            enddo
4517           enddo
4518
4519           do k=1,3
4520             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4521      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4522             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4523      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4524             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4525      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4526             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4527      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4528            enddo
4529            endif
4530
4531
4532 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4533 c     &                     ' eel_loc_ij',eel_loc_ij
4534 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4535 C Calculate patrial derivative for theta angle
4536 #ifdef NEWCORR
4537          geel_loc_ij=(a22*gmuij1(1)
4538      &     +a23*gmuij1(2)
4539      &     +a32*gmuij1(3)
4540      &     +a33*gmuij1(4))
4541      &    *fac_shield(i)*fac_shield(j)
4542      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4543
4544 c         write(iout,*) "derivative over thatai"
4545 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4546 c     &   a33*gmuij1(4)
4547          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4548      &      geel_loc_ij*wel_loc
4549 c         write(iout,*) "derivative over thatai-1"
4550 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4551 c     &   a33*gmuij2(4)
4552          geel_loc_ij=
4553      &     a22*gmuij2(1)
4554      &     +a23*gmuij2(2)
4555      &     +a32*gmuij2(3)
4556      &     +a33*gmuij2(4)
4557          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4558      &      geel_loc_ij*wel_loc
4559      &    *fac_shield(i)*fac_shield(j)
4560      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4561
4562
4563 c  Derivative over j residue
4564          geel_loc_ji=a22*gmuji1(1)
4565      &     +a23*gmuji1(2)
4566      &     +a32*gmuji1(3)
4567      &     +a33*gmuji1(4)
4568 c         write(iout,*) "derivative over thataj"
4569 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4570 c     &   a33*gmuji1(4)
4571
4572         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4573      &      geel_loc_ji*wel_loc
4574      &    *fac_shield(i)*fac_shield(j)
4575      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4576
4577          geel_loc_ji=
4578      &     +a22*gmuji2(1)
4579      &     +a23*gmuji2(2)
4580      &     +a32*gmuji2(3)
4581      &     +a33*gmuji2(4)
4582 c         write(iout,*) "derivative over thataj-1"
4583 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4584 c     &   a33*gmuji2(4)
4585          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4586      &      geel_loc_ji*wel_loc
4587      &    *fac_shield(i)*fac_shield(j)
4588      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4589
4590 #endif
4591 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4592
4593           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4594      &            'eelloc',i,j,eel_loc_ij
4595 c           if (eel_loc_ij.ne.0)
4596 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4597 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4598
4599           eel_loc=eel_loc+eel_loc_ij
4600 C Partial derivatives in virtual-bond dihedral angles gamma
4601           if (i.gt.1)
4602      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4603      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4604      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4605      &    *fac_shield(i)*fac_shield(j)
4606      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4607
4608           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4609      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4610      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4611      &    *fac_shield(i)*fac_shield(j)
4612      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4613
4614 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4615           do l=1,3
4616             ggg(l)=(agg(l,1)*muij(1)+
4617      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4618      &    *fac_shield(i)*fac_shield(j)
4619      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4620
4621             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4622             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4623 cgrad            ghalf=0.5d0*ggg(l)
4624 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4625 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4626           enddo
4627             gel_loc_long(3,j)=gel_loc_long(3,j)+
4628      &     ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4629      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631             gel_loc_long(3,i)=gel_loc_long(3,i)+
4632      &     ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4633      & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4634
4635 cgrad          do k=i+1,j2
4636 cgrad            do l=1,3
4637 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4638 cgrad            enddo
4639 cgrad          enddo
4640 C Remaining derivatives of eello
4641           do l=1,3
4642             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4643      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4644      &    *fac_shield(i)*fac_shield(j)
4645      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4646
4647             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4648      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4649      &    *fac_shield(i)*fac_shield(j)
4650      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4651
4652             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4653      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4654      &    *fac_shield(i)*fac_shield(j)
4655      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4656
4657             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4658      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4659      &    *fac_shield(i)*fac_shield(j)
4660      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4661
4662           enddo
4663           ENDIF
4664 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4665 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4666           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4667      &       .and. num_conti.le.maxconts) then
4668 c            write (iout,*) i,j," entered corr"
4669 C
4670 C Calculate the contact function. The ith column of the array JCONT will
4671 C contain the numbers of atoms that make contacts with the atom I (of numbers
4672 C greater than I). The arrays FACONT and GACONT will contain the values of
4673 C the contact function and its derivative.
4674 c           r0ij=1.02D0*rpp(iteli,itelj)
4675 c           r0ij=1.11D0*rpp(iteli,itelj)
4676             r0ij=2.20D0*rpp(iteli,itelj)
4677 c           r0ij=1.55D0*rpp(iteli,itelj)
4678             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4679             if (fcont.gt.0.0D0) then
4680               num_conti=num_conti+1
4681               if (num_conti.gt.maxconts) then
4682                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4683      &                         ' will skip next contacts for this conf.'
4684               else
4685                 jcont_hb(num_conti,i)=j
4686 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4687 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4688                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4689      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4690 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4691 C  terms.
4692                 d_cont(num_conti,i)=rij
4693 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4694 C     --- Electrostatic-interaction matrix ---
4695                 a_chuj(1,1,num_conti,i)=a22
4696                 a_chuj(1,2,num_conti,i)=a23
4697                 a_chuj(2,1,num_conti,i)=a32
4698                 a_chuj(2,2,num_conti,i)=a33
4699 C     --- Gradient of rij
4700                 do kkk=1,3
4701                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4702                 enddo
4703                 kkll=0
4704                 do k=1,2
4705                   do l=1,2
4706                     kkll=kkll+1
4707                     do m=1,3
4708                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4709                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4710                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4711                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4712                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4713                     enddo
4714                   enddo
4715                 enddo
4716                 ENDIF
4717                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4718 C Calculate contact energies
4719                 cosa4=4.0D0*cosa
4720                 wij=cosa-3.0D0*cosb*cosg
4721                 cosbg1=cosb+cosg
4722                 cosbg2=cosb-cosg
4723 c               fac3=dsqrt(-ael6i)/r0ij**3
4724                 fac3=dsqrt(-ael6i)*r3ij
4725 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4726                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4727                 if (ees0tmp.gt.0) then
4728                   ees0pij=dsqrt(ees0tmp)
4729                 else
4730                   ees0pij=0
4731                 endif
4732 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4733                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4734                 if (ees0tmp.gt.0) then
4735                   ees0mij=dsqrt(ees0tmp)
4736                 else
4737                   ees0mij=0
4738                 endif
4739 c               ees0mij=0.0D0
4740                 if (shield_mode.eq.0) then
4741                 fac_shield(i)=1.0d0
4742                 fac_shield(j)=1.0d0
4743                 else
4744                 ees0plist(num_conti,i)=j
4745 C                fac_shield(i)=0.4d0
4746 C                fac_shield(j)=0.6d0
4747                 endif
4748                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4749      &          *fac_shield(i)*fac_shield(j)
4750                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4751      &          *fac_shield(i)*fac_shield(j)
4752 C Diagnostics. Comment out or remove after debugging!
4753 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4754 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4755 c               ees0m(num_conti,i)=0.0D0
4756 C End diagnostics.
4757 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4758 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4759 C Angular derivatives of the contact function
4760                 ees0pij1=fac3/ees0pij
4761                 ees0mij1=fac3/ees0mij
4762                 fac3p=-3.0D0*fac3*rrmij
4763                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4764                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4765 c               ees0mij1=0.0D0
4766                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4767                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4768                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4769                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4770                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4771                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4772                 ecosap=ecosa1+ecosa2
4773                 ecosbp=ecosb1+ecosb2
4774                 ecosgp=ecosg1+ecosg2
4775                 ecosam=ecosa1-ecosa2
4776                 ecosbm=ecosb1-ecosb2
4777                 ecosgm=ecosg1-ecosg2
4778 C Diagnostics
4779 c               ecosap=ecosa1
4780 c               ecosbp=ecosb1
4781 c               ecosgp=ecosg1
4782 c               ecosam=0.0D0
4783 c               ecosbm=0.0D0
4784 c               ecosgm=0.0D0
4785 C End diagnostics
4786                 facont_hb(num_conti,i)=fcont
4787                 fprimcont=fprimcont/rij
4788 cd              facont_hb(num_conti,i)=1.0D0
4789 C Following line is for diagnostics.
4790 cd              fprimcont=0.0D0
4791                 do k=1,3
4792                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4793                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4794                 enddo
4795                 do k=1,3
4796                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4797                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4798                 enddo
4799                 gggp(1)=gggp(1)+ees0pijp*xj
4800                 gggp(2)=gggp(2)+ees0pijp*yj
4801                 gggp(3)=gggp(3)+ees0pijp*zj
4802                 gggm(1)=gggm(1)+ees0mijp*xj
4803                 gggm(2)=gggm(2)+ees0mijp*yj
4804                 gggm(3)=gggm(3)+ees0mijp*zj
4805 C Derivatives due to the contact function
4806                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4807                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4808                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4809                 do k=1,3
4810 c
4811 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4812 c          following the change of gradient-summation algorithm.
4813 c
4814 cgrad                  ghalfp=0.5D0*gggp(k)
4815 cgrad                  ghalfm=0.5D0*gggm(k)
4816                   gacontp_hb1(k,num_conti,i)=!ghalfp
4817      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4818      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4819      &          *fac_shield(i)*fac_shield(j)
4820
4821                   gacontp_hb2(k,num_conti,i)=!ghalfp
4822      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4823      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4824      &          *fac_shield(i)*fac_shield(j)
4825
4826                   gacontp_hb3(k,num_conti,i)=gggp(k)
4827      &          *fac_shield(i)*fac_shield(j)
4828
4829                   gacontm_hb1(k,num_conti,i)=!ghalfm
4830      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4831      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4832      &          *fac_shield(i)*fac_shield(j)
4833
4834                   gacontm_hb2(k,num_conti,i)=!ghalfm
4835      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4836      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4837      &          *fac_shield(i)*fac_shield(j)
4838
4839                   gacontm_hb3(k,num_conti,i)=gggm(k)
4840      &          *fac_shield(i)*fac_shield(j)
4841
4842                 enddo
4843 C Diagnostics. Comment out or remove after debugging!
4844 cdiag           do k=1,3
4845 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4846 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4847 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4848 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4849 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4850 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4851 cdiag           enddo
4852               ENDIF ! wcorr
4853               endif  ! num_conti.le.maxconts
4854             endif  ! fcont.gt.0
4855           endif    ! j.gt.i+1
4856           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4857             do k=1,4
4858               do l=1,3
4859                 ghalf=0.5d0*agg(l,k)
4860                 aggi(l,k)=aggi(l,k)+ghalf
4861                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4862                 aggj(l,k)=aggj(l,k)+ghalf
4863               enddo
4864             enddo
4865             if (j.eq.nres-1 .and. i.lt.j-2) then
4866               do k=1,4
4867                 do l=1,3
4868                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4869                 enddo
4870               enddo
4871             endif
4872           endif
4873 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4874       return
4875       end
4876 C-----------------------------------------------------------------------------
4877       subroutine eturn3(i,eello_turn3)
4878 C Third- and fourth-order contributions from turns
4879       implicit real*8 (a-h,o-z)
4880       include 'DIMENSIONS'
4881       include 'COMMON.IOUNITS'
4882       include 'COMMON.GEO'
4883       include 'COMMON.VAR'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.CHAIN'
4886       include 'COMMON.DERIV'
4887       include 'COMMON.INTERACT'
4888       include 'COMMON.CONTACTS'
4889       include 'COMMON.TORSION'
4890       include 'COMMON.VECTORS'
4891       include 'COMMON.FFIELD'
4892       include 'COMMON.CONTROL'
4893       include 'COMMON.SHIELD'
4894       dimension ggg(3)
4895       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4896      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4897      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4898      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4899      &  auxgmat2(2,2),auxgmatt2(2,2)
4900       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4901      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4902       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4903      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4904      &    num_conti,j1,j2
4905       j=i+2
4906 C          xj=(c(1,j)+c(1,j+1))/2.0d0
4907 C          yj=(c(2,j)+c(2,j+1))/2.0d0
4908           zj=(c(3,j)+c(3,j+1))/2.0d0
4909 C          xj=mod(xj,boxxsize)
4910 C          if (xj.lt.0) xj=xj+boxxsize
4911 C          yj=mod(yj,boxysize)
4912 C          if (yj.lt.0) yj=yj+boxysize
4913           zj=mod(zj,boxzsize)
4914           if (zj.lt.0) zj=zj+boxzsize
4915           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4916        if ((zj.gt.bordlipbot)
4917      &.and.(zj.lt.bordliptop)) then
4918 C the energy transfer exist
4919         if (zj.lt.buflipbot) then
4920 C what fraction I am in
4921          fracinbuf=1.0d0-
4922      &        ((zj-bordlipbot)/lipbufthick)
4923 C lipbufthick is thickenes of lipid buffore
4924          sslipj=sscalelip(fracinbuf)
4925          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4926         elseif (zj.gt.bufliptop) then
4927          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4928          sslipj=sscalelip(fracinbuf)
4929          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4930         else
4931          sslipj=1.0d0
4932          ssgradlipj=0.0
4933         endif
4934        else
4935          sslipj=0.0d0
4936          ssgradlipj=0.0
4937        endif
4938 C      sslipj=0.0
4939 C      ssgradlipj=0.0d0
4940
4941 C      write (iout,*) "eturn3",i,j,j1,j2
4942       a_temp(1,1)=a22
4943       a_temp(1,2)=a23
4944       a_temp(2,1)=a32
4945       a_temp(2,2)=a33
4946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4947 C
4948 C               Third-order contributions
4949 C
4950 C                 (i+2)o----(i+3)
4951 C                      | |
4952 C                      | |
4953 C                 (i+1)o----i
4954 C
4955 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4956 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4957         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4958 c auxalary matices for theta gradient
4959 c auxalary matrix for i+1 and constant i+2
4960         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4961 c auxalary matrix for i+2 and constant i+1
4962         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4963         call transpose2(auxmat(1,1),auxmat1(1,1))
4964         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4965         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4966         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4967         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4968         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4969         if (shield_mode.eq.0) then
4970         fac_shield(i)=1.0d0
4971         fac_shield(j)=1.0d0
4972 C        else
4973 C        fac_shield(i)=0.4
4974 C        fac_shield(j)=0.6
4975         endif
4976 C         if (j.eq.78)
4977 C     &   write(iout,*) i,j,fac_shield(i),fac_shield(j)
4978         eello_turn3=eello_turn3+
4979 C     &  1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4980      &0.5d0*(pizda(1,1)+pizda(2,2))
4981      &  *fac_shield(i)*fac_shield(j)
4982      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4983         eello_t3=
4984      &0.5d0*(pizda(1,1)+pizda(2,2))
4985      &  *fac_shield(i)*fac_shield(j)
4986 #ifdef NEWCORR
4987 C Derivatives in theta
4988         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4989      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4990      &   *fac_shield(i)*fac_shield(j)
4991      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4992
4993         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4994      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4995      &   *fac_shield(i)*fac_shield(j)
4996      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4997
4998 #endif
4999
5000 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5001 C Derivatives in shield mode
5002           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5003      &  (shield_mode.gt.0)) then
5004 C          print *,i,j
5005
5006           do ilist=1,ishield_list(i)
5007            iresshield=shield_list(ilist,i)
5008            do k=1,3
5009            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5010 C     &      *2.0
5011            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5012      &              rlocshield
5013      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5014             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5015      &      +rlocshield
5016            enddo
5017           enddo
5018           do ilist=1,ishield_list(j)
5019            iresshield=shield_list(ilist,j)
5020            do k=1,3
5021            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5022 C     &     *2.0
5023            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5024      &              rlocshield
5025      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5026            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5027      &             +rlocshield
5028
5029            enddo
5030           enddo
5031
5032           do k=1,3
5033             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5034      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5035             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5036      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5037             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5038      &              grad_shield(k,i)*eello_t3/fac_shield(i)
5039             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5040      &              grad_shield(k,j)*eello_t3/fac_shield(j)
5041            enddo
5042            endif
5043
5044 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5045 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
5046 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
5047 cd     &    ' eello_turn3_num',4*eello_turn3_num
5048 C Derivatives in gamma(i)
5049         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5050         call transpose2(auxmat2(1,1),auxmat3(1,1))
5051         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5052         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5053      &   *fac_shield(i)*fac_shield(j)
5054      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5055
5056 C Derivatives in gamma(i+1)
5057         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5058         call transpose2(auxmat2(1,1),auxmat3(1,1))
5059         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5060         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5061      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5062      &   *fac_shield(i)*fac_shield(j)
5063      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5064
5065 C Cartesian derivatives
5066         do l=1,3
5067 c            ghalf1=0.5d0*agg(l,1)
5068 c            ghalf2=0.5d0*agg(l,2)
5069 c            ghalf3=0.5d0*agg(l,3)
5070 c            ghalf4=0.5d0*agg(l,4)
5071           a_temp(1,1)=aggi(l,1)!+ghalf1
5072           a_temp(1,2)=aggi(l,2)!+ghalf2
5073           a_temp(2,1)=aggi(l,3)!+ghalf3
5074           a_temp(2,2)=aggi(l,4)!+ghalf4
5075           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5076           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5077      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5078      &   *fac_shield(i)*fac_shield(j)
5079      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5080
5081           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5082           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5083           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5084           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5085           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5086           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5087      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5088      &   *fac_shield(i)*fac_shield(j)
5089      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5090           a_temp(1,1)=aggj(l,1)!+ghalf1
5091           a_temp(1,2)=aggj(l,2)!+ghalf2
5092           a_temp(2,1)=aggj(l,3)!+ghalf3
5093           a_temp(2,2)=aggj(l,4)!+ghalf4
5094           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5095           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5096      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5097      &   *fac_shield(i)*fac_shield(j)
5098      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5099
5100           a_temp(1,1)=aggj1(l,1)
5101           a_temp(1,2)=aggj1(l,2)
5102           a_temp(2,1)=aggj1(l,3)
5103           a_temp(2,2)=aggj1(l,4)
5104           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5105           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5106      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5107      &   *fac_shield(i)*fac_shield(j)
5108      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5109         enddo
5110          gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5111      &     ssgradlipi*eello_t3/4.0d0*lipscale
5112          gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5113      &     ssgradlipj*eello_t3/4.0d0*lipscale
5114          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5115      &     ssgradlipi*eello_t3/4.0d0*lipscale
5116          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5117      &     ssgradlipj*eello_t3/4.0d0*lipscale
5118
5119 C         print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5120       return
5121       end
5122 C-------------------------------------------------------------------------------
5123       subroutine eturn4(i,eello_turn4)
5124 C Third- and fourth-order contributions from turns
5125       implicit real*8 (a-h,o-z)
5126       include 'DIMENSIONS'
5127       include 'COMMON.IOUNITS'
5128       include 'COMMON.GEO'
5129       include 'COMMON.VAR'
5130       include 'COMMON.LOCAL'
5131       include 'COMMON.CHAIN'
5132       include 'COMMON.DERIV'
5133       include 'COMMON.INTERACT'
5134       include 'COMMON.CONTACTS'
5135       include 'COMMON.TORSION'
5136       include 'COMMON.VECTORS'
5137       include 'COMMON.FFIELD'
5138       include 'COMMON.CONTROL'
5139       include 'COMMON.SHIELD'
5140       dimension ggg(3)
5141       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5142      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5143      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5144      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5145      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5146      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5147      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5148       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5149      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5150       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5151      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5152      &    num_conti,j1,j2
5153       j=i+3
5154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5155 C
5156 C               Fourth-order contributions
5157 C
5158 C                 (i+3)o----(i+4)
5159 C                     /  |
5160 C               (i+2)o   |
5161 C                     \  |
5162 C                 (i+1)o----i
5163 C
5164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5165 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5166 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5167 c        write(iout,*)"WCHODZE W PROGRAM"
5168           zj=(c(3,j)+c(3,j+1))/2.0d0
5169 C          xj=mod(xj,boxxsize)
5170 C          if (xj.lt.0) xj=xj+boxxsize
5171 C          yj=mod(yj,boxysize)
5172 C          if (yj.lt.0) yj=yj+boxysize
5173           zj=mod(zj,boxzsize)
5174           if (zj.lt.0) zj=zj+boxzsize
5175 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5176        if ((zj.gt.bordlipbot)
5177      &.and.(zj.lt.bordliptop)) then
5178 C the energy transfer exist
5179         if (zj.lt.buflipbot) then
5180 C what fraction I am in
5181          fracinbuf=1.0d0-
5182      &        ((zj-bordlipbot)/lipbufthick)
5183 C lipbufthick is thickenes of lipid buffore
5184          sslipj=sscalelip(fracinbuf)
5185          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5186         elseif (zj.gt.bufliptop) then
5187          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5188          sslipj=sscalelip(fracinbuf)
5189          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5190         else
5191          sslipj=1.0d0
5192          ssgradlipj=0.0
5193         endif
5194        else
5195          sslipj=0.0d0
5196          ssgradlipj=0.0
5197        endif
5198
5199         a_temp(1,1)=a22
5200         a_temp(1,2)=a23
5201         a_temp(2,1)=a32
5202         a_temp(2,2)=a33
5203         iti1=itype2loc(itype(i+1))
5204         iti2=itype2loc(itype(i+2))
5205         iti3=itype2loc(itype(i+3))
5206 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5207         call transpose2(EUg(1,1,i+1),e1t(1,1))
5208         call transpose2(Eug(1,1,i+2),e2t(1,1))
5209         call transpose2(Eug(1,1,i+3),e3t(1,1))
5210 C Ematrix derivative in theta
5211         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5212         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5213         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5214         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5215 c       eta1 in derivative theta
5216         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5217         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5218 c       auxgvec is derivative of Ub2 so i+3 theta
5219         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5220 c       auxalary matrix of E i+1
5221         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5222 c        s1=0.0
5223 c        gs1=0.0
5224         s1=scalar2(b1(1,i+2),auxvec(1))
5225 c derivative of theta i+2 with constant i+3
5226         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5227 c derivative of theta i+2 with constant i+2
5228         gs32=scalar2(b1(1,i+2),auxgvec(1))
5229 c derivative of E matix in theta of i+1
5230         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5231
5232         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5233 c       ea31 in derivative theta
5234         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5235         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5236 c auxilary matrix auxgvec of Ub2 with constant E matirx
5237         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5238 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5239         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5240
5241 c        s2=0.0
5242 c        gs2=0.0
5243         s2=scalar2(b1(1,i+1),auxvec(1))
5244 c derivative of theta i+1 with constant i+3
5245         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5246 c derivative of theta i+2 with constant i+1
5247         gs21=scalar2(b1(1,i+1),auxgvec(1))
5248 c derivative of theta i+3 with constant i+1
5249         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5250 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5251 c     &  gtb1(1,i+1)
5252         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5253 c two derivatives over diffetent matrices
5254 c gtae3e2 is derivative over i+3
5255         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5256 c ae3gte2 is derivative over i+2
5257         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5258         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5259 c three possible derivative over theta E matices
5260 c i+1
5261         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5262 c i+2
5263         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5264 c i+3
5265         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5266         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5267
5268         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5269         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5270         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5271         if (shield_mode.eq.0) then
5272         fac_shield(i)=1.0
5273         fac_shield(j)=1.0
5274 C        else
5275 C        fac_shield(i)=0.6
5276 C        fac_shield(j)=0.4
5277         endif
5278         eello_turn4=eello_turn4-(s1+s2+s3)
5279      &  *fac_shield(i)*fac_shield(j)
5280      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5281
5282         eello_t4=-(s1+s2+s3)
5283      &  *fac_shield(i)*fac_shield(j)
5284 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5285         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5286      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5287 C Now derivative over shield:
5288           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5289      &  (shield_mode.gt.0)) then
5290 C          print *,i,j
5291
5292           do ilist=1,ishield_list(i)
5293            iresshield=shield_list(ilist,i)
5294            do k=1,3
5295            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5296 C     &      *2.0
5297            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5298      &              rlocshield
5299      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5300             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5301      &      +rlocshield
5302            enddo
5303           enddo
5304           do ilist=1,ishield_list(j)
5305            iresshield=shield_list(ilist,j)
5306            do k=1,3
5307            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5308 C     &     *2.0
5309            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5310      &              rlocshield
5311      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5312            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5313      &             +rlocshield
5314
5315            enddo
5316           enddo
5317
5318           do k=1,3
5319             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5320      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5321             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5322      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5323             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5324      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5325             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5326      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5327            enddo
5328            endif
5329
5330
5331
5332
5333
5334
5335 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5336 cd     &    ' eello_turn4_num',8*eello_turn4_num
5337 #ifdef NEWCORR
5338         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5339      &                  -(gs13+gsE13+gsEE1)*wturn4
5340      &  *fac_shield(i)*fac_shield(j)
5341      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5342
5343         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5344      &                    -(gs23+gs21+gsEE2)*wturn4
5345      &  *fac_shield(i)*fac_shield(j)
5346      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5347
5348         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5349      &                    -(gs32+gsE31+gsEE3)*wturn4
5350      &  *fac_shield(i)*fac_shield(j)
5351      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5352
5353 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5354 c     &   gs2
5355 #endif
5356         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5357      &      'eturn4',i,j,-(s1+s2+s3)
5358 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5359 c     &    ' eello_turn4_num',8*eello_turn4_num
5360 C Derivatives in gamma(i)
5361         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5362         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5363         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5364         s1=scalar2(b1(1,i+2),auxvec(1))
5365         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5366         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5367         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5368      &  *fac_shield(i)*fac_shield(j)
5369      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5370
5371 C Derivatives in gamma(i+1)
5372         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5373         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5374         s2=scalar2(b1(1,i+1),auxvec(1))
5375         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5376         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5377         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5378         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5379      &  *fac_shield(i)*fac_shield(j)
5380      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5381
5382 C Derivatives in gamma(i+2)
5383         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5384         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5385         s1=scalar2(b1(1,i+2),auxvec(1))
5386         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5387         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5388         s2=scalar2(b1(1,i+1),auxvec(1))
5389         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5390         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5391         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5392         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5393      &  *fac_shield(i)*fac_shield(j)
5394      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5395
5396 C Cartesian derivatives
5397 C Derivatives of this turn contributions in DC(i+2)
5398         if (j.lt.nres-1) then
5399           do l=1,3
5400             a_temp(1,1)=agg(l,1)
5401             a_temp(1,2)=agg(l,2)
5402             a_temp(2,1)=agg(l,3)
5403             a_temp(2,2)=agg(l,4)
5404             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5405             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5406             s1=scalar2(b1(1,i+2),auxvec(1))
5407             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5408             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5409             s2=scalar2(b1(1,i+1),auxvec(1))
5410             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5411             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5412             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5413             ggg(l)=-(s1+s2+s3)
5414             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5415      &  *fac_shield(i)*fac_shield(j)
5416      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5417
5418           enddo
5419         endif
5420 C Remaining derivatives of this turn contribution
5421         do l=1,3
5422           a_temp(1,1)=aggi(l,1)
5423           a_temp(1,2)=aggi(l,2)
5424           a_temp(2,1)=aggi(l,3)
5425           a_temp(2,2)=aggi(l,4)
5426           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5427           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5428           s1=scalar2(b1(1,i+2),auxvec(1))
5429           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5430           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5431           s2=scalar2(b1(1,i+1),auxvec(1))
5432           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5433           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5434           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5436      &  *fac_shield(i)*fac_shield(j)
5437      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5438
5439           a_temp(1,1)=aggi1(l,1)
5440           a_temp(1,2)=aggi1(l,2)
5441           a_temp(2,1)=aggi1(l,3)
5442           a_temp(2,2)=aggi1(l,4)
5443           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5444           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5445           s1=scalar2(b1(1,i+2),auxvec(1))
5446           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5447           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5448           s2=scalar2(b1(1,i+1),auxvec(1))
5449           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5450           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5451           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5452           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5453      &  *fac_shield(i)*fac_shield(j)
5454      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5455
5456           a_temp(1,1)=aggj(l,1)
5457           a_temp(1,2)=aggj(l,2)
5458           a_temp(2,1)=aggj(l,3)
5459           a_temp(2,2)=aggj(l,4)
5460           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5461           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5462           s1=scalar2(b1(1,i+2),auxvec(1))
5463           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5464           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5465           s2=scalar2(b1(1,i+1),auxvec(1))
5466           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5467           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5468           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5469           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5470      &  *fac_shield(i)*fac_shield(j)
5471      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5472
5473           a_temp(1,1)=aggj1(l,1)
5474           a_temp(1,2)=aggj1(l,2)
5475           a_temp(2,1)=aggj1(l,3)
5476           a_temp(2,2)=aggj1(l,4)
5477           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5478           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5479           s1=scalar2(b1(1,i+2),auxvec(1))
5480           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5481           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5482           s2=scalar2(b1(1,i+1),auxvec(1))
5483           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5484           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5485           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5486 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5487           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5488      &  *fac_shield(i)*fac_shield(j)
5489      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5490         enddo
5491          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5492      &     ssgradlipi*eello_t4/4.0d0*lipscale
5493          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5494      &     ssgradlipj*eello_t4/4.0d0*lipscale
5495          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5496      &     ssgradlipi*eello_t4/4.0d0*lipscale
5497          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5498      &     ssgradlipj*eello_t4/4.0d0*lipscale
5499       return
5500       end
5501 C-----------------------------------------------------------------------------
5502       subroutine vecpr(u,v,w)
5503       implicit real*8(a-h,o-z)
5504       dimension u(3),v(3),w(3)
5505       w(1)=u(2)*v(3)-u(3)*v(2)
5506       w(2)=-u(1)*v(3)+u(3)*v(1)
5507       w(3)=u(1)*v(2)-u(2)*v(1)
5508       return
5509       end
5510 C-----------------------------------------------------------------------------
5511       subroutine unormderiv(u,ugrad,unorm,ungrad)
5512 C This subroutine computes the derivatives of a normalized vector u, given
5513 C the derivatives computed without normalization conditions, ugrad. Returns
5514 C ungrad.
5515       implicit none
5516       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5517       double precision vec(3)
5518       double precision scalar
5519       integer i,j
5520 c      write (2,*) 'ugrad',ugrad
5521 c      write (2,*) 'u',u
5522       do i=1,3
5523         vec(i)=scalar(ugrad(1,i),u(1))
5524       enddo
5525 c      write (2,*) 'vec',vec
5526       do i=1,3
5527         do j=1,3
5528           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5529         enddo
5530       enddo
5531 c      write (2,*) 'ungrad',ungrad
5532       return
5533       end
5534 C-----------------------------------------------------------------------------
5535       subroutine escp_soft_sphere(evdw2,evdw2_14)
5536 C
5537 C This subroutine calculates the excluded-volume interaction energy between
5538 C peptide-group centers and side chains and its gradient in virtual-bond and
5539 C side-chain vectors.
5540 C
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'COMMON.GEO'
5544       include 'COMMON.VAR'
5545       include 'COMMON.LOCAL'
5546       include 'COMMON.CHAIN'
5547       include 'COMMON.DERIV'
5548       include 'COMMON.INTERACT'
5549       include 'COMMON.FFIELD'
5550       include 'COMMON.IOUNITS'
5551       include 'COMMON.CONTROL'
5552       dimension ggg(3)
5553       evdw2=0.0D0
5554       evdw2_14=0.0d0
5555       r0_scp=4.5d0
5556 cd    print '(a)','Enter ESCP'
5557 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5558 C      do xshift=-1,1
5559 C      do yshift=-1,1
5560 C      do zshift=-1,1
5561       do i=iatscp_s,iatscp_e
5562         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5563         iteli=itel(i)
5564         xi=0.5D0*(c(1,i)+c(1,i+1))
5565         yi=0.5D0*(c(2,i)+c(2,i+1))
5566         zi=0.5D0*(c(3,i)+c(3,i+1))
5567 C Return atom into box, boxxsize is size of box in x dimension
5568 c  134   continue
5569 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5570 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5571 C Condition for being inside the proper box
5572 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5573 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5574 c        go to 134
5575 c        endif
5576 c  135   continue
5577 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5578 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5579 C Condition for being inside the proper box
5580 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5581 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5582 c        go to 135
5583 c c       endif
5584 c  136   continue
5585 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5586 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5587 cC Condition for being inside the proper box
5588 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5589 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5590 c        go to 136
5591 c        endif
5592           xi=mod(xi,boxxsize)
5593           if (xi.lt.0) xi=xi+boxxsize
5594           yi=mod(yi,boxysize)
5595           if (yi.lt.0) yi=yi+boxysize
5596           zi=mod(zi,boxzsize)
5597           if (zi.lt.0) zi=zi+boxzsize
5598 C          xi=xi+xshift*boxxsize
5599 C          yi=yi+yshift*boxysize
5600 C          zi=zi+zshift*boxzsize
5601         do iint=1,nscp_gr(i)
5602
5603         do j=iscpstart(i,iint),iscpend(i,iint)
5604           if (itype(j).eq.ntyp1) cycle
5605           itypj=iabs(itype(j))
5606 C Uncomment following three lines for SC-p interactions
5607 c         xj=c(1,nres+j)-xi
5608 c         yj=c(2,nres+j)-yi
5609 c         zj=c(3,nres+j)-zi
5610 C Uncomment following three lines for Ca-p interactions
5611           xj=c(1,j)
5612           yj=c(2,j)
5613           zj=c(3,j)
5614 c  174   continue
5615 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5616 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5617 C Condition for being inside the proper box
5618 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5619 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5620 c        go to 174
5621 c        endif
5622 c  175   continue
5623 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5624 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5625 cC Condition for being inside the proper box
5626 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5627 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5628 c        go to 175
5629 c        endif
5630 c  176   continue
5631 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5632 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5633 C Condition for being inside the proper box
5634 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5635 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5636 c        go to 176
5637           xj=mod(xj,boxxsize)
5638           if (xj.lt.0) xj=xj+boxxsize
5639           yj=mod(yj,boxysize)
5640           if (yj.lt.0) yj=yj+boxysize
5641           zj=mod(zj,boxzsize)
5642           if (zj.lt.0) zj=zj+boxzsize
5643       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5644       xj_safe=xj
5645       yj_safe=yj
5646       zj_safe=zj
5647       subchap=0
5648       do xshift=-1,1
5649       do yshift=-1,1
5650       do zshift=-1,1
5651           xj=xj_safe+xshift*boxxsize
5652           yj=yj_safe+yshift*boxysize
5653           zj=zj_safe+zshift*boxzsize
5654           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5655           if(dist_temp.lt.dist_init) then
5656             dist_init=dist_temp
5657             xj_temp=xj
5658             yj_temp=yj
5659             zj_temp=zj
5660             subchap=1
5661           endif
5662        enddo
5663        enddo
5664        enddo
5665        if (subchap.eq.1) then
5666           xj=xj_temp-xi
5667           yj=yj_temp-yi
5668           zj=zj_temp-zi
5669        else
5670           xj=xj_safe-xi
5671           yj=yj_safe-yi
5672           zj=zj_safe-zi
5673        endif
5674 c c       endif
5675 C          xj=xj-xi
5676 C          yj=yj-yi
5677 C          zj=zj-zi
5678           rij=xj*xj+yj*yj+zj*zj
5679
5680           r0ij=r0_scp
5681           r0ijsq=r0ij*r0ij
5682           if (rij.lt.r0ijsq) then
5683             evdwij=0.25d0*(rij-r0ijsq)**2
5684             fac=rij-r0ijsq
5685           else
5686             evdwij=0.0d0
5687             fac=0.0d0
5688           endif
5689           evdw2=evdw2+evdwij
5690 C
5691 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5692 C
5693           ggg(1)=xj*fac
5694           ggg(2)=yj*fac
5695           ggg(3)=zj*fac
5696 cgrad          if (j.lt.i) then
5697 cd          write (iout,*) 'j<i'
5698 C Uncomment following three lines for SC-p interactions
5699 c           do k=1,3
5700 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5701 c           enddo
5702 cgrad          else
5703 cd          write (iout,*) 'j>i'
5704 cgrad            do k=1,3
5705 cgrad              ggg(k)=-ggg(k)
5706 C Uncomment following line for SC-p interactions
5707 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5708 cgrad            enddo
5709 cgrad          endif
5710 cgrad          do k=1,3
5711 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5712 cgrad          enddo
5713 cgrad          kstart=min0(i+1,j)
5714 cgrad          kend=max0(i-1,j-1)
5715 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5716 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5717 cgrad          do k=kstart,kend
5718 cgrad            do l=1,3
5719 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5720 cgrad            enddo
5721 cgrad          enddo
5722           do k=1,3
5723             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5724             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5725           enddo
5726         enddo
5727
5728         enddo ! iint
5729       enddo ! i
5730 C      enddo !zshift
5731 C      enddo !yshift
5732 C      enddo !xshift
5733       return
5734       end
5735 C-----------------------------------------------------------------------------
5736       subroutine escp(evdw2,evdw2_14)
5737 C
5738 C This subroutine calculates the excluded-volume interaction energy between
5739 C peptide-group centers and side chains and its gradient in virtual-bond and
5740 C side-chain vectors.
5741 C
5742       implicit real*8 (a-h,o-z)
5743       include 'DIMENSIONS'
5744       include 'COMMON.GEO'
5745       include 'COMMON.VAR'
5746       include 'COMMON.LOCAL'
5747       include 'COMMON.CHAIN'
5748       include 'COMMON.DERIV'
5749       include 'COMMON.INTERACT'
5750       include 'COMMON.FFIELD'
5751       include 'COMMON.IOUNITS'
5752       include 'COMMON.CONTROL'
5753       include 'COMMON.SPLITELE'
5754       dimension ggg(3)
5755       evdw2=0.0D0
5756       evdw2_14=0.0d0
5757 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5758 cd    print '(a)','Enter ESCP'
5759 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5760 C      do xshift=-1,1
5761 C      do yshift=-1,1
5762 C      do zshift=-1,1
5763       do i=iatscp_s,iatscp_e
5764         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5765         iteli=itel(i)
5766         xi=0.5D0*(c(1,i)+c(1,i+1))
5767         yi=0.5D0*(c(2,i)+c(2,i+1))
5768         zi=0.5D0*(c(3,i)+c(3,i+1))
5769           xi=mod(xi,boxxsize)
5770           if (xi.lt.0) xi=xi+boxxsize
5771           yi=mod(yi,boxysize)
5772           if (yi.lt.0) yi=yi+boxysize
5773           zi=mod(zi,boxzsize)
5774           if (zi.lt.0) zi=zi+boxzsize
5775 c          xi=xi+xshift*boxxsize
5776 c          yi=yi+yshift*boxysize
5777 c          zi=zi+zshift*boxzsize
5778 c        print *,xi,yi,zi,'polozenie i'
5779 C Return atom into box, boxxsize is size of box in x dimension
5780 c  134   continue
5781 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5782 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5783 C Condition for being inside the proper box
5784 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5785 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5786 c        go to 134
5787 c        endif
5788 c  135   continue
5789 c          print *,xi,boxxsize,"pierwszy"
5790
5791 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5792 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5793 C Condition for being inside the proper box
5794 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5795 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5796 c        go to 135
5797 c        endif
5798 c  136   continue
5799 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5800 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5801 C Condition for being inside the proper box
5802 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5803 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5804 c        go to 136
5805 c        endif
5806         do iint=1,nscp_gr(i)
5807
5808         do j=iscpstart(i,iint),iscpend(i,iint)
5809           itypj=iabs(itype(j))
5810           if (itypj.eq.ntyp1) cycle
5811 C Uncomment following three lines for SC-p interactions
5812 c         xj=c(1,nres+j)-xi
5813 c         yj=c(2,nres+j)-yi
5814 c         zj=c(3,nres+j)-zi
5815 C Uncomment following three lines for Ca-p interactions
5816           xj=c(1,j)
5817           yj=c(2,j)
5818           zj=c(3,j)
5819           xj=mod(xj,boxxsize)
5820           if (xj.lt.0) xj=xj+boxxsize
5821           yj=mod(yj,boxysize)
5822           if (yj.lt.0) yj=yj+boxysize
5823           zj=mod(zj,boxzsize)
5824           if (zj.lt.0) zj=zj+boxzsize
5825 c  174   continue
5826 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5827 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5828 C Condition for being inside the proper box
5829 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5830 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5831 c        go to 174
5832 c        endif
5833 c  175   continue
5834 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5835 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5836 cC Condition for being inside the proper box
5837 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5838 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5839 c        go to 175
5840 c        endif
5841 c  176   continue
5842 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5843 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5844 C Condition for being inside the proper box
5845 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5846 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5847 c        go to 176
5848 c        endif
5849 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5850       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5851       xj_safe=xj
5852       yj_safe=yj
5853       zj_safe=zj
5854       subchap=0
5855       do xshift=-1,1
5856       do yshift=-1,1
5857       do zshift=-1,1
5858           xj=xj_safe+xshift*boxxsize
5859           yj=yj_safe+yshift*boxysize
5860           zj=zj_safe+zshift*boxzsize
5861           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5862           if(dist_temp.lt.dist_init) then
5863             dist_init=dist_temp
5864             xj_temp=xj
5865             yj_temp=yj
5866             zj_temp=zj
5867             subchap=1
5868           endif
5869        enddo
5870        enddo
5871        enddo
5872        if (subchap.eq.1) then
5873           xj=xj_temp-xi
5874           yj=yj_temp-yi
5875           zj=zj_temp-zi
5876        else
5877           xj=xj_safe-xi
5878           yj=yj_safe-yi
5879           zj=zj_safe-zi
5880        endif
5881 c          print *,xj,yj,zj,'polozenie j'
5882           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5883 c          print *,rrij
5884           sss=sscale(1.0d0/(dsqrt(rrij)))
5885 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5886 c          if (sss.eq.0) print *,'czasem jest OK'
5887           if (sss.le.0.0d0) cycle
5888           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5889           fac=rrij**expon2
5890           e1=fac*fac*aad(itypj,iteli)
5891           e2=fac*bad(itypj,iteli)
5892           if (iabs(j-i) .le. 2) then
5893             e1=scal14*e1
5894             e2=scal14*e2
5895             evdw2_14=evdw2_14+(e1+e2)*sss
5896           endif
5897           evdwij=e1+e2
5898           evdw2=evdw2+evdwij*sss
5899           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5900      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5901      &       bad(itypj,iteli)
5902 C
5903 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5904 C
5905           fac=-(evdwij+e1)*rrij*sss
5906           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5907           ggg(1)=xj*fac
5908           ggg(2)=yj*fac
5909           ggg(3)=zj*fac
5910 cgrad          if (j.lt.i) then
5911 cd          write (iout,*) 'j<i'
5912 C Uncomment following three lines for SC-p interactions
5913 c           do k=1,3
5914 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5915 c           enddo
5916 cgrad          else
5917 cd          write (iout,*) 'j>i'
5918 cgrad            do k=1,3
5919 cgrad              ggg(k)=-ggg(k)
5920 C Uncomment following line for SC-p interactions
5921 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5922 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5923 cgrad            enddo
5924 cgrad          endif
5925 cgrad          do k=1,3
5926 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5927 cgrad          enddo
5928 cgrad          kstart=min0(i+1,j)
5929 cgrad          kend=max0(i-1,j-1)
5930 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5931 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5932 cgrad          do k=kstart,kend
5933 cgrad            do l=1,3
5934 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5935 cgrad            enddo
5936 cgrad          enddo
5937           do k=1,3
5938             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5939             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5940           enddo
5941 c        endif !endif for sscale cutoff
5942         enddo ! j
5943
5944         enddo ! iint
5945       enddo ! i
5946 c      enddo !zshift
5947 c      enddo !yshift
5948 c      enddo !xshift
5949       do i=1,nct
5950         do j=1,3
5951           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5952           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5953           gradx_scp(j,i)=expon*gradx_scp(j,i)
5954         enddo
5955       enddo
5956 C******************************************************************************
5957 C
5958 C                              N O T E !!!
5959 C
5960 C To save time the factor EXPON has been extracted from ALL components
5961 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5962 C use!
5963 C
5964 C******************************************************************************
5965       return
5966       end
5967 C--------------------------------------------------------------------------
5968       subroutine edis(ehpb)
5969 C
5970 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5971 C
5972       implicit real*8 (a-h,o-z)
5973       include 'DIMENSIONS'
5974       include 'COMMON.SBRIDGE'
5975       include 'COMMON.CHAIN'
5976       include 'COMMON.DERIV'
5977       include 'COMMON.VAR'
5978       include 'COMMON.INTERACT'
5979       include 'COMMON.IOUNITS'
5980       include 'COMMON.CONTROL'
5981       dimension ggg(3)
5982       ehpb=0.0D0
5983       do i=1,3
5984        ggg(i)=0.0d0
5985       enddo
5986 C      write (iout,*) ,"link_end",link_end,constr_dist
5987 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5988 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5989       if (link_end.eq.0) return
5990       do i=link_start,link_end
5991 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5992 C CA-CA distance used in regularization of structure.
5993         ii=ihpb(i)
5994         jj=jhpb(i)
5995 C iii and jjj point to the residues for which the distance is assigned.
5996         if (ii.gt.nres) then
5997           iii=ii-nres
5998           jjj=jj-nres
5999         else
6000           iii=ii
6001           jjj=jj
6002         endif
6003 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6004 c     &    dhpb(i),dhpb1(i),forcon(i)
6005 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6006 C    distance and angle dependent SS bond potential.
6007 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6008 C     & iabs(itype(jjj)).eq.1) then
6009 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6010 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6011         if (.not.dyn_ss .and. i.le.nss) then
6012 C 15/02/13 CC dynamic SSbond - additional check
6013          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6014      & iabs(itype(jjj)).eq.1) then
6015           call ssbond_ene(iii,jjj,eij)
6016           ehpb=ehpb+2*eij
6017          endif
6018 cd          write (iout,*) "eij",eij
6019 cd   &   ' waga=',waga,' fac=',fac
6020         else if (ii.gt.nres .and. jj.gt.nres) then
6021 c Restraints from contact prediction
6022           dd=dist(ii,jj)
6023           if (constr_dist.eq.11) then
6024             ehpb=ehpb+fordepth(i)**4.0d0
6025      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6026             fac=fordepth(i)**4.0d0
6027      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6028           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6029      &    ehpb,fordepth(i),dd
6030            else
6031           if (dhpb1(i).gt.0.0d0) then
6032             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6033             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6034 c            write (iout,*) "beta nmr",
6035 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6036           else
6037             dd=dist(ii,jj)
6038             rdis=dd-dhpb(i)
6039 C Get the force constant corresponding to this distance.
6040             waga=forcon(i)
6041 C Calculate the contribution to energy.
6042             ehpb=ehpb+waga*rdis*rdis
6043 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
6044 C
6045 C Evaluate gradient.
6046 C
6047             fac=waga*rdis/dd
6048           endif
6049           endif
6050           do j=1,3
6051             ggg(j)=fac*(c(j,jj)-c(j,ii))
6052           enddo
6053           do j=1,3
6054             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6055             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6056           enddo
6057           do k=1,3
6058             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6059             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6060           enddo
6061         else
6062 C Calculate the distance between the two points and its difference from the
6063 C target distance.
6064           dd=dist(ii,jj)
6065           if (constr_dist.eq.11) then
6066             ehpb=ehpb+fordepth(i)**4.0d0
6067      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6068             fac=fordepth(i)**4.0d0
6069      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6070           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6071      &    ehpb,fordepth(i),dd
6072            else
6073           if (dhpb1(i).gt.0.0d0) then
6074             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6075             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6076 c            write (iout,*) "alph nmr",
6077 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6078           else
6079             rdis=dd-dhpb(i)
6080 C Get the force constant corresponding to this distance.
6081             waga=forcon(i)
6082 C Calculate the contribution to energy.
6083             ehpb=ehpb+waga*rdis*rdis
6084 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
6085 C
6086 C Evaluate gradient.
6087 C
6088             fac=waga*rdis/dd
6089           endif
6090           endif
6091             do j=1,3
6092               ggg(j)=fac*(c(j,jj)-c(j,ii))
6093             enddo
6094 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6095 C If this is a SC-SC distance, we need to calculate the contributions to the
6096 C Cartesian gradient in the SC vectors (ghpbx).
6097           if (iii.lt.ii) then
6098           do j=1,3
6099             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6100             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6101           enddo
6102           endif
6103 cgrad        do j=iii,jjj-1
6104 cgrad          do k=1,3
6105 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6106 cgrad          enddo
6107 cgrad        enddo
6108           do k=1,3
6109             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6110             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6111           enddo
6112         endif
6113       enddo
6114       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6115       return
6116       end
6117 C--------------------------------------------------------------------------
6118       subroutine ssbond_ene(i,j,eij)
6119 C
6120 C Calculate the distance and angle dependent SS-bond potential energy
6121 C using a free-energy function derived based on RHF/6-31G** ab initio
6122 C calculations of diethyl disulfide.
6123 C
6124 C A. Liwo and U. Kozlowska, 11/24/03
6125 C
6126       implicit real*8 (a-h,o-z)
6127       include 'DIMENSIONS'
6128       include 'COMMON.SBRIDGE'
6129       include 'COMMON.CHAIN'
6130       include 'COMMON.DERIV'
6131       include 'COMMON.LOCAL'
6132       include 'COMMON.INTERACT'
6133       include 'COMMON.VAR'
6134       include 'COMMON.IOUNITS'
6135       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6136       itypi=iabs(itype(i))
6137       xi=c(1,nres+i)
6138       yi=c(2,nres+i)
6139       zi=c(3,nres+i)
6140       dxi=dc_norm(1,nres+i)
6141       dyi=dc_norm(2,nres+i)
6142       dzi=dc_norm(3,nres+i)
6143 c      dsci_inv=dsc_inv(itypi)
6144       dsci_inv=vbld_inv(nres+i)
6145       itypj=iabs(itype(j))
6146 c      dscj_inv=dsc_inv(itypj)
6147       dscj_inv=vbld_inv(nres+j)
6148       xj=c(1,nres+j)-xi
6149       yj=c(2,nres+j)-yi
6150       zj=c(3,nres+j)-zi
6151       dxj=dc_norm(1,nres+j)
6152       dyj=dc_norm(2,nres+j)
6153       dzj=dc_norm(3,nres+j)
6154       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6155       rij=dsqrt(rrij)
6156       erij(1)=xj*rij
6157       erij(2)=yj*rij
6158       erij(3)=zj*rij
6159       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6160       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6161       om12=dxi*dxj+dyi*dyj+dzi*dzj
6162       do k=1,3
6163         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6164         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6165       enddo
6166       rij=1.0d0/rij
6167       deltad=rij-d0cm
6168       deltat1=1.0d0-om1
6169       deltat2=1.0d0+om2
6170       deltat12=om2-om1+2.0d0
6171       cosphi=om12-om1*om2
6172       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6173      &  +akct*deltad*deltat12
6174      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6175 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6176 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6177 c     &  " deltat12",deltat12," eij",eij
6178       ed=2*akcm*deltad+akct*deltat12
6179       pom1=akct*deltad
6180       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6181       eom1=-2*akth*deltat1-pom1-om2*pom2
6182       eom2= 2*akth*deltat2+pom1-om1*pom2
6183       eom12=pom2
6184       do k=1,3
6185         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6186         ghpbx(k,i)=ghpbx(k,i)-ggk
6187      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6188      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6189         ghpbx(k,j)=ghpbx(k,j)+ggk
6190      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6191      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6192         ghpbc(k,i)=ghpbc(k,i)-ggk
6193         ghpbc(k,j)=ghpbc(k,j)+ggk
6194       enddo
6195 C
6196 C Calculate the components of the gradient in DC and X
6197 C
6198 cgrad      do k=i,j-1
6199 cgrad        do l=1,3
6200 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6201 cgrad        enddo
6202 cgrad      enddo
6203       return
6204       end
6205 C--------------------------------------------------------------------------
6206       subroutine ebond(estr)
6207 c
6208 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6209 c
6210       implicit real*8 (a-h,o-z)
6211       include 'DIMENSIONS'
6212       include 'COMMON.LOCAL'
6213       include 'COMMON.GEO'
6214       include 'COMMON.INTERACT'
6215       include 'COMMON.DERIV'
6216       include 'COMMON.VAR'
6217       include 'COMMON.CHAIN'
6218       include 'COMMON.IOUNITS'
6219       include 'COMMON.NAMES'
6220       include 'COMMON.FFIELD'
6221       include 'COMMON.CONTROL'
6222       include 'COMMON.SETUP'
6223       double precision u(3),ud(3)
6224       estr=0.0d0
6225       estr1=0.0d0
6226       do i=ibondp_start,ibondp_end
6227         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6228 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6229 c          do j=1,3
6230 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6231 c     &      *dc(j,i-1)/vbld(i)
6232 c          enddo
6233 c          if (energy_dec) write(iout,*)
6234 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6235 c        else
6236 C       Checking if it involves dummy (NH3+ or COO-) group
6237          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6238 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6239         diff = vbld(i)-vbldpDUM
6240         if (energy_dec) write(iout,*) "dum_bond",i,diff
6241          else
6242 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6243         diff = vbld(i)-vbldp0
6244          endif
6245         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6246      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6247         estr=estr+diff*diff
6248         do j=1,3
6249           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6250         enddo
6251 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6252 c        endif
6253       enddo
6254
6255       estr=0.5d0*AKP*estr+estr1
6256 c
6257 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6258 c
6259       do i=ibond_start,ibond_end
6260         iti=iabs(itype(i))
6261         if (iti.ne.10 .and. iti.ne.ntyp1) then
6262           nbi=nbondterm(iti)
6263           if (nbi.eq.1) then
6264             diff=vbld(i+nres)-vbldsc0(1,iti)
6265             if (energy_dec)  write (iout,*)
6266      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6267      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6268             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6269             do j=1,3
6270               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6271             enddo
6272           else
6273             do j=1,nbi
6274               diff=vbld(i+nres)-vbldsc0(j,iti)
6275               ud(j)=aksc(j,iti)*diff
6276               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6277             enddo
6278             uprod=u(1)
6279             do j=2,nbi
6280               uprod=uprod*u(j)
6281             enddo
6282             usum=0.0d0
6283             usumsqder=0.0d0
6284             do j=1,nbi
6285               uprod1=1.0d0
6286               uprod2=1.0d0
6287               do k=1,nbi
6288                 if (k.ne.j) then
6289                   uprod1=uprod1*u(k)
6290                   uprod2=uprod2*u(k)*u(k)
6291                 endif
6292               enddo
6293               usum=usum+uprod1
6294               usumsqder=usumsqder+ud(j)*uprod2
6295             enddo
6296             estr=estr+uprod/usum
6297             do j=1,3
6298              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6299             enddo
6300           endif
6301         endif
6302       enddo
6303       return
6304       end
6305 #ifdef CRYST_THETA
6306 C--------------------------------------------------------------------------
6307       subroutine ebend(etheta,ethetacnstr)
6308 C
6309 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6310 C angles gamma and its derivatives in consecutive thetas and gammas.
6311 C
6312       implicit real*8 (a-h,o-z)
6313       include 'DIMENSIONS'
6314       include 'COMMON.LOCAL'
6315       include 'COMMON.GEO'
6316       include 'COMMON.INTERACT'
6317       include 'COMMON.DERIV'
6318       include 'COMMON.VAR'
6319       include 'COMMON.CHAIN'
6320       include 'COMMON.IOUNITS'
6321       include 'COMMON.NAMES'
6322       include 'COMMON.FFIELD'
6323       include 'COMMON.CONTROL'
6324       include 'COMMON.TORCNSTR'
6325       common /calcthet/ term1,term2,termm,diffak,ratak,
6326      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6327      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6328       double precision y(2),z(2)
6329       delta=0.02d0*pi
6330 c      time11=dexp(-2*time)
6331 c      time12=1.0d0
6332       etheta=0.0D0
6333 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6334       do i=ithet_start,ithet_end
6335         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6336      &  .or.itype(i).eq.ntyp1) cycle
6337 C Zero the energy function and its derivative at 0 or pi.
6338         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6339         it=itype(i-1)
6340         ichir1=isign(1,itype(i-2))
6341         ichir2=isign(1,itype(i))
6342          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6343          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6344          if (itype(i-1).eq.10) then
6345           itype1=isign(10,itype(i-2))
6346           ichir11=isign(1,itype(i-2))
6347           ichir12=isign(1,itype(i-2))
6348           itype2=isign(10,itype(i))
6349           ichir21=isign(1,itype(i))
6350           ichir22=isign(1,itype(i))
6351          endif
6352
6353         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6354 #ifdef OSF
6355           phii=phi(i)
6356           if (phii.ne.phii) phii=150.0
6357 #else
6358           phii=phi(i)
6359 #endif
6360           y(1)=dcos(phii)
6361           y(2)=dsin(phii)
6362         else
6363           y(1)=0.0D0
6364           y(2)=0.0D0
6365         endif
6366         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6367 #ifdef OSF
6368           phii1=phi(i+1)
6369           if (phii1.ne.phii1) phii1=150.0
6370           phii1=pinorm(phii1)
6371           z(1)=cos(phii1)
6372 #else
6373           phii1=phi(i+1)
6374 #endif
6375           z(1)=dcos(phii1)
6376           z(2)=dsin(phii1)
6377         else
6378           z(1)=0.0D0
6379           z(2)=0.0D0
6380         endif
6381 C Calculate the "mean" value of theta from the part of the distribution
6382 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6383 C In following comments this theta will be referred to as t_c.
6384         thet_pred_mean=0.0d0
6385         do k=1,2
6386             athetk=athet(k,it,ichir1,ichir2)
6387             bthetk=bthet(k,it,ichir1,ichir2)
6388           if (it.eq.10) then
6389              athetk=athet(k,itype1,ichir11,ichir12)
6390              bthetk=bthet(k,itype2,ichir21,ichir22)
6391           endif
6392          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6393 c         write(iout,*) 'chuj tu', y(k),z(k)
6394         enddo
6395         dthett=thet_pred_mean*ssd
6396         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6397 C Derivatives of the "mean" values in gamma1 and gamma2.
6398         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6399      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6400          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6401      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6402          if (it.eq.10) then
6403       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6404      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6405         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6406      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6407          endif
6408         if (theta(i).gt.pi-delta) then
6409           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6410      &         E_tc0)
6411           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6412           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6413           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6414      &        E_theta)
6415           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6416      &        E_tc)
6417         else if (theta(i).lt.delta) then
6418           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6419           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6420           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6421      &        E_theta)
6422           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6423           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6424      &        E_tc)
6425         else
6426           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6427      &        E_theta,E_tc)
6428         endif
6429         etheta=etheta+ethetai
6430         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6431      &      'ebend',i,ethetai,theta(i),itype(i)
6432         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6433         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6434         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6435       enddo
6436       ethetacnstr=0.0d0
6437 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6438       do i=ithetaconstr_start,ithetaconstr_end
6439         itheta=itheta_constr(i)
6440         thetiii=theta(itheta)
6441         difi=pinorm(thetiii-theta_constr0(i))
6442         if (difi.gt.theta_drange(i)) then
6443           difi=difi-theta_drange(i)
6444           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6445           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6446      &    +for_thet_constr(i)*difi**3
6447         else if (difi.lt.-drange(i)) then
6448           difi=difi+drange(i)
6449           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6450           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6451      &    +for_thet_constr(i)*difi**3
6452         else
6453           difi=0.0
6454         endif
6455        if (energy_dec) then
6456         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6457      &    i,itheta,rad2deg*thetiii,
6458      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6459      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6460      &    gloc(itheta+nphi-2,icg)
6461         endif
6462       enddo
6463
6464 C Ufff.... We've done all this!!!
6465       return
6466       end
6467 C---------------------------------------------------------------------------
6468       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6469      &     E_tc)
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'COMMON.LOCAL'
6473       include 'COMMON.IOUNITS'
6474       common /calcthet/ term1,term2,termm,diffak,ratak,
6475      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6476      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6477 C Calculate the contributions to both Gaussian lobes.
6478 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6479 C The "polynomial part" of the "standard deviation" of this part of
6480 C the distributioni.
6481 ccc        write (iout,*) thetai,thet_pred_mean
6482         sig=polthet(3,it)
6483         do j=2,0,-1
6484           sig=sig*thet_pred_mean+polthet(j,it)
6485         enddo
6486 C Derivative of the "interior part" of the "standard deviation of the"
6487 C gamma-dependent Gaussian lobe in t_c.
6488         sigtc=3*polthet(3,it)
6489         do j=2,1,-1
6490           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6491         enddo
6492         sigtc=sig*sigtc
6493 C Set the parameters of both Gaussian lobes of the distribution.
6494 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6495         fac=sig*sig+sigc0(it)
6496         sigcsq=fac+fac
6497         sigc=1.0D0/sigcsq
6498 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6499         sigsqtc=-4.0D0*sigcsq*sigtc
6500 c       print *,i,sig,sigtc,sigsqtc
6501 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6502         sigtc=-sigtc/(fac*fac)
6503 C Following variable is sigma(t_c)**(-2)
6504         sigcsq=sigcsq*sigcsq
6505         sig0i=sig0(it)
6506         sig0inv=1.0D0/sig0i**2
6507         delthec=thetai-thet_pred_mean
6508         delthe0=thetai-theta0i
6509         term1=-0.5D0*sigcsq*delthec*delthec
6510         term2=-0.5D0*sig0inv*delthe0*delthe0
6511 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6512 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6513 C NaNs in taking the logarithm. We extract the largest exponent which is added
6514 C to the energy (this being the log of the distribution) at the end of energy
6515 C term evaluation for this virtual-bond angle.
6516         if (term1.gt.term2) then
6517           termm=term1
6518           term2=dexp(term2-termm)
6519           term1=1.0d0
6520         else
6521           termm=term2
6522           term1=dexp(term1-termm)
6523           term2=1.0d0
6524         endif
6525 C The ratio between the gamma-independent and gamma-dependent lobes of
6526 C the distribution is a Gaussian function of thet_pred_mean too.
6527         diffak=gthet(2,it)-thet_pred_mean
6528         ratak=diffak/gthet(3,it)**2
6529         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6530 C Let's differentiate it in thet_pred_mean NOW.
6531         aktc=ak*ratak
6532 C Now put together the distribution terms to make complete distribution.
6533         termexp=term1+ak*term2
6534         termpre=sigc+ak*sig0i
6535 C Contribution of the bending energy from this theta is just the -log of
6536 C the sum of the contributions from the two lobes and the pre-exponential
6537 C factor. Simple enough, isn't it?
6538         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6539 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6540 C NOW the derivatives!!!
6541 C 6/6/97 Take into account the deformation.
6542         E_theta=(delthec*sigcsq*term1
6543      &       +ak*delthe0*sig0inv*term2)/termexp
6544         E_tc=((sigtc+aktc*sig0i)/termpre
6545      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6546      &       aktc*term2)/termexp)
6547       return
6548       end
6549 c-----------------------------------------------------------------------------
6550       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6551       implicit real*8 (a-h,o-z)
6552       include 'DIMENSIONS'
6553       include 'COMMON.LOCAL'
6554       include 'COMMON.IOUNITS'
6555       common /calcthet/ term1,term2,termm,diffak,ratak,
6556      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6557      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6558       delthec=thetai-thet_pred_mean
6559       delthe0=thetai-theta0i
6560 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6561       t3 = thetai-thet_pred_mean
6562       t6 = t3**2
6563       t9 = term1
6564       t12 = t3*sigcsq
6565       t14 = t12+t6*sigsqtc
6566       t16 = 1.0d0
6567       t21 = thetai-theta0i
6568       t23 = t21**2
6569       t26 = term2
6570       t27 = t21*t26
6571       t32 = termexp
6572       t40 = t32**2
6573       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6574      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6575      & *(-t12*t9-ak*sig0inv*t27)
6576       return
6577       end
6578 #else
6579 C--------------------------------------------------------------------------
6580       subroutine ebend(etheta,ethetacnstr)
6581 C
6582 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6583 C angles gamma and its derivatives in consecutive thetas and gammas.
6584 C ab initio-derived potentials from
6585 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6586 C
6587       implicit real*8 (a-h,o-z)
6588       include 'DIMENSIONS'
6589       include 'COMMON.LOCAL'
6590       include 'COMMON.GEO'
6591       include 'COMMON.INTERACT'
6592       include 'COMMON.DERIV'
6593       include 'COMMON.VAR'
6594       include 'COMMON.CHAIN'
6595       include 'COMMON.IOUNITS'
6596       include 'COMMON.NAMES'
6597       include 'COMMON.FFIELD'
6598       include 'COMMON.CONTROL'
6599       include 'COMMON.TORCNSTR'
6600       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6601      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6602      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6603      & sinph1ph2(maxdouble,maxdouble)
6604       logical lprn /.false./, lprn1 /.false./
6605       etheta=0.0D0
6606       do i=ithet_start,ithet_end
6607 c        print *,i,itype(i-1),itype(i),itype(i-2)
6608         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6609      &  .or.itype(i).eq.ntyp1) cycle
6610 C        print *,i,theta(i)
6611         if (iabs(itype(i+1)).eq.20) iblock=2
6612         if (iabs(itype(i+1)).ne.20) iblock=1
6613         dethetai=0.0d0
6614         dephii=0.0d0
6615         dephii1=0.0d0
6616         theti2=0.5d0*theta(i)
6617         ityp2=ithetyp((itype(i-1)))
6618         do k=1,nntheterm
6619           coskt(k)=dcos(k*theti2)
6620           sinkt(k)=dsin(k*theti2)
6621         enddo
6622 C        print *,ethetai
6623         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6624 #ifdef OSF
6625           phii=phi(i)
6626           if (phii.ne.phii) phii=150.0
6627 #else
6628           phii=phi(i)
6629 #endif
6630           ityp1=ithetyp((itype(i-2)))
6631 C propagation of chirality for glycine type
6632           do k=1,nsingle
6633             cosph1(k)=dcos(k*phii)
6634             sinph1(k)=dsin(k*phii)
6635           enddo
6636         else
6637           phii=0.0d0
6638           do k=1,nsingle
6639           ityp1=ithetyp((itype(i-2)))
6640             cosph1(k)=0.0d0
6641             sinph1(k)=0.0d0
6642           enddo
6643         endif
6644         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6645 #ifdef OSF
6646           phii1=phi(i+1)
6647           if (phii1.ne.phii1) phii1=150.0
6648           phii1=pinorm(phii1)
6649 #else
6650           phii1=phi(i+1)
6651 #endif
6652           ityp3=ithetyp((itype(i)))
6653           do k=1,nsingle
6654             cosph2(k)=dcos(k*phii1)
6655             sinph2(k)=dsin(k*phii1)
6656           enddo
6657         else
6658           phii1=0.0d0
6659           ityp3=ithetyp((itype(i)))
6660           do k=1,nsingle
6661             cosph2(k)=0.0d0
6662             sinph2(k)=0.0d0
6663           enddo
6664         endif
6665         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6666         do k=1,ndouble
6667           do l=1,k-1
6668             ccl=cosph1(l)*cosph2(k-l)
6669             ssl=sinph1(l)*sinph2(k-l)
6670             scl=sinph1(l)*cosph2(k-l)
6671             csl=cosph1(l)*sinph2(k-l)
6672             cosph1ph2(l,k)=ccl-ssl
6673             cosph1ph2(k,l)=ccl+ssl
6674             sinph1ph2(l,k)=scl+csl
6675             sinph1ph2(k,l)=scl-csl
6676           enddo
6677         enddo
6678         if (lprn) then
6679         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6680      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6681         write (iout,*) "coskt and sinkt"
6682         do k=1,nntheterm
6683           write (iout,*) k,coskt(k),sinkt(k)
6684         enddo
6685         endif
6686         do k=1,ntheterm
6687           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6688           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6689      &      *coskt(k)
6690           if (lprn)
6691      &    write (iout,*) "k",k,"
6692      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6693      &     " ethetai",ethetai
6694         enddo
6695         if (lprn) then
6696         write (iout,*) "cosph and sinph"
6697         do k=1,nsingle
6698           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6699         enddo
6700         write (iout,*) "cosph1ph2 and sinph2ph2"
6701         do k=2,ndouble
6702           do l=1,k-1
6703             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6704      &         sinph1ph2(l,k),sinph1ph2(k,l)
6705           enddo
6706         enddo
6707         write(iout,*) "ethetai",ethetai
6708         endif
6709 C       print *,ethetai
6710         do m=1,ntheterm2
6711           do k=1,nsingle
6712             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6713      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6714      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6715      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6716             ethetai=ethetai+sinkt(m)*aux
6717             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6718             dephii=dephii+k*sinkt(m)*(
6719      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6720      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6721             dephii1=dephii1+k*sinkt(m)*(
6722      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6723      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6724             if (lprn)
6725      &      write (iout,*) "m",m," k",k," bbthet",
6726      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6727      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6728      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6729      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6730 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6731           enddo
6732         enddo
6733 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6734 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6735 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6736 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6737         if (lprn)
6738      &  write(iout,*) "ethetai",ethetai
6739 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6740         do m=1,ntheterm3
6741           do k=2,ndouble
6742             do l=1,k-1
6743               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6744      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6745      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6746      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6747               ethetai=ethetai+sinkt(m)*aux
6748               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6749               dephii=dephii+l*sinkt(m)*(
6750      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6751      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6752      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6753      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6754               dephii1=dephii1+(k-l)*sinkt(m)*(
6755      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6756      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6757      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6758      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6759               if (lprn) then
6760               write (iout,*) "m",m," k",k," l",l," ffthet",
6761      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6762      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6763      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6764      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6765      &            " ethetai",ethetai
6766               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6767      &            cosph1ph2(k,l)*sinkt(m),
6768      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6769               endif
6770             enddo
6771           enddo
6772         enddo
6773 10      continue
6774 c        lprn1=.true.
6775 C        print *,ethetai
6776         if (lprn1)
6777      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6778      &   i,theta(i)*rad2deg,phii*rad2deg,
6779      &   phii1*rad2deg,ethetai
6780 c        lprn1=.false.
6781         etheta=etheta+ethetai
6782         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6783         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6784         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6785       enddo
6786 C now constrains
6787       ethetacnstr=0.0d0
6788 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6789       do i=ithetaconstr_start,ithetaconstr_end
6790         itheta=itheta_constr(i)
6791         thetiii=theta(itheta)
6792         difi=pinorm(thetiii-theta_constr0(i))
6793         if (difi.gt.theta_drange(i)) then
6794           difi=difi-theta_drange(i)
6795           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6796           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6797      &    +for_thet_constr(i)*difi**3
6798         else if (difi.lt.-drange(i)) then
6799           difi=difi+drange(i)
6800           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6801           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6802      &    +for_thet_constr(i)*difi**3
6803         else
6804           difi=0.0
6805         endif
6806        if (energy_dec) then
6807         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6808      &    i,itheta,rad2deg*thetiii,
6809      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6810      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6811      &    gloc(itheta+nphi-2,icg)
6812         endif
6813       enddo
6814
6815       return
6816       end
6817 #endif
6818 #ifdef CRYST_SC
6819 c-----------------------------------------------------------------------------
6820       subroutine esc(escloc)
6821 C Calculate the local energy of a side chain and its derivatives in the
6822 C corresponding virtual-bond valence angles THETA and the spherical angles
6823 C ALPHA and OMEGA.
6824       implicit real*8 (a-h,o-z)
6825       include 'DIMENSIONS'
6826       include 'COMMON.GEO'
6827       include 'COMMON.LOCAL'
6828       include 'COMMON.VAR'
6829       include 'COMMON.INTERACT'
6830       include 'COMMON.DERIV'
6831       include 'COMMON.CHAIN'
6832       include 'COMMON.IOUNITS'
6833       include 'COMMON.NAMES'
6834       include 'COMMON.FFIELD'
6835       include 'COMMON.CONTROL'
6836       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6837      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6838       common /sccalc/ time11,time12,time112,theti,it,nlobit
6839       delta=0.02d0*pi
6840       escloc=0.0D0
6841 c     write (iout,'(a)') 'ESC'
6842       do i=loc_start,loc_end
6843         it=itype(i)
6844         if (it.eq.ntyp1) cycle
6845         if (it.eq.10) goto 1
6846         nlobit=nlob(iabs(it))
6847 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6848 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6849         theti=theta(i+1)-pipol
6850         x(1)=dtan(theti)
6851         x(2)=alph(i)
6852         x(3)=omeg(i)
6853
6854         if (x(2).gt.pi-delta) then
6855           xtemp(1)=x(1)
6856           xtemp(2)=pi-delta
6857           xtemp(3)=x(3)
6858           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6859           xtemp(2)=pi
6860           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6861           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6862      &        escloci,dersc(2))
6863           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6864      &        ddersc0(1),dersc(1))
6865           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6866      &        ddersc0(3),dersc(3))
6867           xtemp(2)=pi-delta
6868           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6869           xtemp(2)=pi
6870           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6871           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6872      &            dersc0(2),esclocbi,dersc02)
6873           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6874      &            dersc12,dersc01)
6875           call splinthet(x(2),0.5d0*delta,ss,ssd)
6876           dersc0(1)=dersc01
6877           dersc0(2)=dersc02
6878           dersc0(3)=0.0d0
6879           do k=1,3
6880             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6881           enddo
6882           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6883 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6884 c    &             esclocbi,ss,ssd
6885           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6886 c         escloci=esclocbi
6887 c         write (iout,*) escloci
6888         else if (x(2).lt.delta) then
6889           xtemp(1)=x(1)
6890           xtemp(2)=delta
6891           xtemp(3)=x(3)
6892           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6893           xtemp(2)=0.0d0
6894           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6895           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6896      &        escloci,dersc(2))
6897           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6898      &        ddersc0(1),dersc(1))
6899           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6900      &        ddersc0(3),dersc(3))
6901           xtemp(2)=delta
6902           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6903           xtemp(2)=0.0d0
6904           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6905           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6906      &            dersc0(2),esclocbi,dersc02)
6907           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6908      &            dersc12,dersc01)
6909           dersc0(1)=dersc01
6910           dersc0(2)=dersc02
6911           dersc0(3)=0.0d0
6912           call splinthet(x(2),0.5d0*delta,ss,ssd)
6913           do k=1,3
6914             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6915           enddo
6916           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6917 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6918 c    &             esclocbi,ss,ssd
6919           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6920 c         write (iout,*) escloci
6921         else
6922           call enesc(x,escloci,dersc,ddummy,.false.)
6923         endif
6924
6925         escloc=escloc+escloci
6926         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6927      &     'escloc',i,escloci
6928 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6929
6930         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6931      &   wscloc*dersc(1)
6932         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6933         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6934     1   continue
6935       enddo
6936       return
6937       end
6938 C---------------------------------------------------------------------------
6939       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6940       implicit real*8 (a-h,o-z)
6941       include 'DIMENSIONS'
6942       include 'COMMON.GEO'
6943       include 'COMMON.LOCAL'
6944       include 'COMMON.IOUNITS'
6945       common /sccalc/ time11,time12,time112,theti,it,nlobit
6946       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6947       double precision contr(maxlob,-1:1)
6948       logical mixed
6949 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6950         escloc_i=0.0D0
6951         do j=1,3
6952           dersc(j)=0.0D0
6953           if (mixed) ddersc(j)=0.0d0
6954         enddo
6955         x3=x(3)
6956
6957 C Because of periodicity of the dependence of the SC energy in omega we have
6958 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6959 C To avoid underflows, first compute & store the exponents.
6960
6961         do iii=-1,1
6962
6963           x(3)=x3+iii*dwapi
6964
6965           do j=1,nlobit
6966             do k=1,3
6967               z(k)=x(k)-censc(k,j,it)
6968             enddo
6969             do k=1,3
6970               Axk=0.0D0
6971               do l=1,3
6972                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6973               enddo
6974               Ax(k,j,iii)=Axk
6975             enddo
6976             expfac=0.0D0
6977             do k=1,3
6978               expfac=expfac+Ax(k,j,iii)*z(k)
6979             enddo
6980             contr(j,iii)=expfac
6981           enddo ! j
6982
6983         enddo ! iii
6984
6985         x(3)=x3
6986 C As in the case of ebend, we want to avoid underflows in exponentiation and
6987 C subsequent NaNs and INFs in energy calculation.
6988 C Find the largest exponent
6989         emin=contr(1,-1)
6990         do iii=-1,1
6991           do j=1,nlobit
6992             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6993           enddo
6994         enddo
6995         emin=0.5D0*emin
6996 cd      print *,'it=',it,' emin=',emin
6997
6998 C Compute the contribution to SC energy and derivatives
6999         do iii=-1,1
7000
7001           do j=1,nlobit
7002 #ifdef OSF
7003             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7004             if(adexp.ne.adexp) adexp=1.0
7005             expfac=dexp(adexp)
7006 #else
7007             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7008 #endif
7009 cd          print *,'j=',j,' expfac=',expfac
7010             escloc_i=escloc_i+expfac
7011             do k=1,3
7012               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7013             enddo
7014             if (mixed) then
7015               do k=1,3,2
7016                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7017      &            +gaussc(k,2,j,it))*expfac
7018               enddo
7019             endif
7020           enddo
7021
7022         enddo ! iii
7023
7024         dersc(1)=dersc(1)/cos(theti)**2
7025         ddersc(1)=ddersc(1)/cos(theti)**2
7026         ddersc(3)=ddersc(3)
7027
7028         escloci=-(dlog(escloc_i)-emin)
7029         do j=1,3
7030           dersc(j)=dersc(j)/escloc_i
7031         enddo
7032         if (mixed) then
7033           do j=1,3,2
7034             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7035           enddo
7036         endif
7037       return
7038       end
7039 C------------------------------------------------------------------------------
7040       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7041       implicit real*8 (a-h,o-z)
7042       include 'DIMENSIONS'
7043       include 'COMMON.GEO'
7044       include 'COMMON.LOCAL'
7045       include 'COMMON.IOUNITS'
7046       common /sccalc/ time11,time12,time112,theti,it,nlobit
7047       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7048       double precision contr(maxlob)
7049       logical mixed
7050
7051       escloc_i=0.0D0
7052
7053       do j=1,3
7054         dersc(j)=0.0D0
7055       enddo
7056
7057       do j=1,nlobit
7058         do k=1,2
7059           z(k)=x(k)-censc(k,j,it)
7060         enddo
7061         z(3)=dwapi
7062         do k=1,3
7063           Axk=0.0D0
7064           do l=1,3
7065             Axk=Axk+gaussc(l,k,j,it)*z(l)
7066           enddo
7067           Ax(k,j)=Axk
7068         enddo
7069         expfac=0.0D0
7070         do k=1,3
7071           expfac=expfac+Ax(k,j)*z(k)
7072         enddo
7073         contr(j)=expfac
7074       enddo ! j
7075
7076 C As in the case of ebend, we want to avoid underflows in exponentiation and
7077 C subsequent NaNs and INFs in energy calculation.
7078 C Find the largest exponent
7079       emin=contr(1)
7080       do j=1,nlobit
7081         if (emin.gt.contr(j)) emin=contr(j)
7082       enddo
7083       emin=0.5D0*emin
7084
7085 C Compute the contribution to SC energy and derivatives
7086
7087       dersc12=0.0d0
7088       do j=1,nlobit
7089         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7090         escloc_i=escloc_i+expfac
7091         do k=1,2
7092           dersc(k)=dersc(k)+Ax(k,j)*expfac
7093         enddo
7094         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7095      &            +gaussc(1,2,j,it))*expfac
7096         dersc(3)=0.0d0
7097       enddo
7098
7099       dersc(1)=dersc(1)/cos(theti)**2
7100       dersc12=dersc12/cos(theti)**2
7101       escloci=-(dlog(escloc_i)-emin)
7102       do j=1,2
7103         dersc(j)=dersc(j)/escloc_i
7104       enddo
7105       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7106       return
7107       end
7108 #else
7109 c----------------------------------------------------------------------------------
7110       subroutine esc(escloc)
7111 C Calculate the local energy of a side chain and its derivatives in the
7112 C corresponding virtual-bond valence angles THETA and the spherical angles
7113 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7114 C added by Urszula Kozlowska. 07/11/2007
7115 C
7116       implicit real*8 (a-h,o-z)
7117       include 'DIMENSIONS'
7118       include 'COMMON.GEO'
7119       include 'COMMON.LOCAL'
7120       include 'COMMON.VAR'
7121       include 'COMMON.SCROT'
7122       include 'COMMON.INTERACT'
7123       include 'COMMON.DERIV'
7124       include 'COMMON.CHAIN'
7125       include 'COMMON.IOUNITS'
7126       include 'COMMON.NAMES'
7127       include 'COMMON.FFIELD'
7128       include 'COMMON.CONTROL'
7129       include 'COMMON.VECTORS'
7130       double precision x_prime(3),y_prime(3),z_prime(3)
7131      &    , sumene,dsc_i,dp2_i,x(65),
7132      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7133      &    de_dxx,de_dyy,de_dzz,de_dt
7134       double precision s1_t,s1_6_t,s2_t,s2_6_t
7135       double precision
7136      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7137      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7138      & dt_dCi(3),dt_dCi1(3)
7139       common /sccalc/ time11,time12,time112,theti,it,nlobit
7140       delta=0.02d0*pi
7141       escloc=0.0D0
7142       do i=loc_start,loc_end
7143         if (itype(i).eq.ntyp1) cycle
7144         costtab(i+1) =dcos(theta(i+1))
7145         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7146         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7147         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7148         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7149         cosfac=dsqrt(cosfac2)
7150         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7151         sinfac=dsqrt(sinfac2)
7152         it=iabs(itype(i))
7153         if (it.eq.10) goto 1
7154 c
7155 C  Compute the axes of tghe local cartesian coordinates system; store in
7156 c   x_prime, y_prime and z_prime
7157 c
7158         do j=1,3
7159           x_prime(j) = 0.00
7160           y_prime(j) = 0.00
7161           z_prime(j) = 0.00
7162         enddo
7163 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7164 C     &   dc_norm(3,i+nres)
7165         do j = 1,3
7166           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7167           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7168         enddo
7169         do j = 1,3
7170           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7171         enddo
7172 c       write (2,*) "i",i
7173 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7174 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7175 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7176 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7177 c      & " xy",scalar(x_prime(1),y_prime(1)),
7178 c      & " xz",scalar(x_prime(1),z_prime(1)),
7179 c      & " yy",scalar(y_prime(1),y_prime(1)),
7180 c      & " yz",scalar(y_prime(1),z_prime(1)),
7181 c      & " zz",scalar(z_prime(1),z_prime(1))
7182 c
7183 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7184 C to local coordinate system. Store in xx, yy, zz.
7185 c
7186         xx=0.0d0
7187         yy=0.0d0
7188         zz=0.0d0
7189         do j = 1,3
7190           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7191           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7192           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7193         enddo
7194
7195         xxtab(i)=xx
7196         yytab(i)=yy
7197         zztab(i)=zz
7198 C
7199 C Compute the energy of the ith side cbain
7200 C
7201 c        write (2,*) "xx",xx," yy",yy," zz",zz
7202         it=iabs(itype(i))
7203         do j = 1,65
7204           x(j) = sc_parmin(j,it)
7205         enddo
7206 #ifdef CHECK_COORD
7207 Cc diagnostics - remove later
7208         xx1 = dcos(alph(2))
7209         yy1 = dsin(alph(2))*dcos(omeg(2))
7210         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7211         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7212      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7213      &    xx1,yy1,zz1
7214 C,"  --- ", xx_w,yy_w,zz_w
7215 c end diagnostics
7216 #endif
7217         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7218      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7219      &   + x(10)*yy*zz
7220         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7221      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7222      & + x(20)*yy*zz
7223         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7224      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7225      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7226      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7227      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7228      &  +x(40)*xx*yy*zz
7229         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7230      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7231      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7232      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7233      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7234      &  +x(60)*xx*yy*zz
7235         dsc_i   = 0.743d0+x(61)
7236         dp2_i   = 1.9d0+x(62)
7237         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7238      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7239         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7240      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7241         s1=(1+x(63))/(0.1d0 + dscp1)
7242         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7243         s2=(1+x(65))/(0.1d0 + dscp2)
7244         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7245         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7246      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7247 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7248 c     &   sumene4,
7249 c     &   dscp1,dscp2,sumene
7250 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7251         escloc = escloc + sumene
7252 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7253 c     & ,zz,xx,yy
7254 c#define DEBUG
7255 #ifdef DEBUG
7256 C
7257 C This section to check the numerical derivatives of the energy of ith side
7258 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7259 C #define DEBUG in the code to turn it on.
7260 C
7261         write (2,*) "sumene               =",sumene
7262         aincr=1.0d-7
7263         xxsave=xx
7264         xx=xx+aincr
7265         write (2,*) xx,yy,zz
7266         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7267         de_dxx_num=(sumenep-sumene)/aincr
7268         xx=xxsave
7269         write (2,*) "xx+ sumene from enesc=",sumenep
7270         yysave=yy
7271         yy=yy+aincr
7272         write (2,*) xx,yy,zz
7273         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7274         de_dyy_num=(sumenep-sumene)/aincr
7275         yy=yysave
7276         write (2,*) "yy+ sumene from enesc=",sumenep
7277         zzsave=zz
7278         zz=zz+aincr
7279         write (2,*) xx,yy,zz
7280         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7281         de_dzz_num=(sumenep-sumene)/aincr
7282         zz=zzsave
7283         write (2,*) "zz+ sumene from enesc=",sumenep
7284         costsave=cost2tab(i+1)
7285         sintsave=sint2tab(i+1)
7286         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7287         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7288         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7289         de_dt_num=(sumenep-sumene)/aincr
7290         write (2,*) " t+ sumene from enesc=",sumenep
7291         cost2tab(i+1)=costsave
7292         sint2tab(i+1)=sintsave
7293 C End of diagnostics section.
7294 #endif
7295 C
7296 C Compute the gradient of esc
7297 C
7298 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7299         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7300         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7301         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7302         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7303         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7304         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7305         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7306         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7307         pom1=(sumene3*sint2tab(i+1)+sumene1)
7308      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7309         pom2=(sumene4*cost2tab(i+1)+sumene2)
7310      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7311         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7312         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7313      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7314      &  +x(40)*yy*zz
7315         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7316         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7317      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7318      &  +x(60)*yy*zz
7319         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7320      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7321      &        +(pom1+pom2)*pom_dx
7322 #ifdef DEBUG
7323         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7324 #endif
7325 C
7326         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7327         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7328      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7329      &  +x(40)*xx*zz
7330         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7331         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7332      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7333      &  +x(59)*zz**2 +x(60)*xx*zz
7334         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7335      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7336      &        +(pom1-pom2)*pom_dy
7337 #ifdef DEBUG
7338         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7339 #endif
7340 C
7341         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7342      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7343      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7344      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7345      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7346      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7347      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7348      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7349 #ifdef DEBUG
7350         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7351 #endif
7352 C
7353         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7354      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7355      &  +pom1*pom_dt1+pom2*pom_dt2
7356 #ifdef DEBUG
7357         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7358 #endif
7359 c#undef DEBUG
7360 c
7361 C
7362        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7363        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7364        cosfac2xx=cosfac2*xx
7365        sinfac2yy=sinfac2*yy
7366        do k = 1,3
7367          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7368      &      vbld_inv(i+1)
7369          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7370      &      vbld_inv(i)
7371          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7372          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7373 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7374 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7375 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7376 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7377          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7378          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7379          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7380          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7381          dZZ_Ci1(k)=0.0d0
7382          dZZ_Ci(k)=0.0d0
7383          do j=1,3
7384            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7385      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7386            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7387      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7388          enddo
7389
7390          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7391          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7392          dZZ_XYZ(k)=vbld_inv(i+nres)*
7393      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7394 c
7395          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7396          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7397        enddo
7398
7399        do k=1,3
7400          dXX_Ctab(k,i)=dXX_Ci(k)
7401          dXX_C1tab(k,i)=dXX_Ci1(k)
7402          dYY_Ctab(k,i)=dYY_Ci(k)
7403          dYY_C1tab(k,i)=dYY_Ci1(k)
7404          dZZ_Ctab(k,i)=dZZ_Ci(k)
7405          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7406          dXX_XYZtab(k,i)=dXX_XYZ(k)
7407          dYY_XYZtab(k,i)=dYY_XYZ(k)
7408          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7409        enddo
7410
7411        do k = 1,3
7412 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7413 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7414 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7415 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7416 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7417 c     &    dt_dci(k)
7418 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7419 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7420          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7421      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7422          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7423      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7424          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7425      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7426        enddo
7427 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7428 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7429
7430 C to check gradient call subroutine check_grad
7431
7432     1 continue
7433       enddo
7434       return
7435       end
7436 c------------------------------------------------------------------------------
7437       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7438       implicit none
7439       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7440      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7441       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7442      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7443      &   + x(10)*yy*zz
7444       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7445      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7446      & + x(20)*yy*zz
7447       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7448      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7449      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7450      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7451      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7452      &  +x(40)*xx*yy*zz
7453       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7454      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7455      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7456      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7457      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7458      &  +x(60)*xx*yy*zz
7459       dsc_i   = 0.743d0+x(61)
7460       dp2_i   = 1.9d0+x(62)
7461       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7462      &          *(xx*cost2+yy*sint2))
7463       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7464      &          *(xx*cost2-yy*sint2))
7465       s1=(1+x(63))/(0.1d0 + dscp1)
7466       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7467       s2=(1+x(65))/(0.1d0 + dscp2)
7468       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7469       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7470      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7471       enesc=sumene
7472       return
7473       end
7474 #endif
7475 c------------------------------------------------------------------------------
7476       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7477 C
7478 C This procedure calculates two-body contact function g(rij) and its derivative:
7479 C
7480 C           eps0ij                                     !       x < -1
7481 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7482 C            0                                         !       x > 1
7483 C
7484 C where x=(rij-r0ij)/delta
7485 C
7486 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7487 C
7488       implicit none
7489       double precision rij,r0ij,eps0ij,fcont,fprimcont
7490       double precision x,x2,x4,delta
7491 c     delta=0.02D0*r0ij
7492 c      delta=0.2D0*r0ij
7493       x=(rij-r0ij)/delta
7494       if (x.lt.-1.0D0) then
7495         fcont=eps0ij
7496         fprimcont=0.0D0
7497       else if (x.le.1.0D0) then
7498         x2=x*x
7499         x4=x2*x2
7500         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7501         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7502       else
7503         fcont=0.0D0
7504         fprimcont=0.0D0
7505       endif
7506       return
7507       end
7508 c------------------------------------------------------------------------------
7509       subroutine splinthet(theti,delta,ss,ssder)
7510       implicit real*8 (a-h,o-z)
7511       include 'DIMENSIONS'
7512       include 'COMMON.VAR'
7513       include 'COMMON.GEO'
7514       thetup=pi-delta
7515       thetlow=delta
7516       if (theti.gt.pipol) then
7517         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7518       else
7519         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7520         ssder=-ssder
7521       endif
7522       return
7523       end
7524 c------------------------------------------------------------------------------
7525       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7526       implicit none
7527       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7528       double precision ksi,ksi2,ksi3,a1,a2,a3
7529       a1=fprim0*delta/(f1-f0)
7530       a2=3.0d0-2.0d0*a1
7531       a3=a1-2.0d0
7532       ksi=(x-x0)/delta
7533       ksi2=ksi*ksi
7534       ksi3=ksi2*ksi
7535       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7536       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7537       return
7538       end
7539 c------------------------------------------------------------------------------
7540       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7541       implicit none
7542       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7543       double precision ksi,ksi2,ksi3,a1,a2,a3
7544       ksi=(x-x0)/delta
7545       ksi2=ksi*ksi
7546       ksi3=ksi2*ksi
7547       a1=fprim0x*delta
7548       a2=3*(f1x-f0x)-2*fprim0x*delta
7549       a3=fprim0x*delta-2*(f1x-f0x)
7550       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7551       return
7552       end
7553 C-----------------------------------------------------------------------------
7554 #ifdef CRYST_TOR
7555 C-----------------------------------------------------------------------------
7556       subroutine etor(etors,edihcnstr)
7557       implicit real*8 (a-h,o-z)
7558       include 'DIMENSIONS'
7559       include 'COMMON.VAR'
7560       include 'COMMON.GEO'
7561       include 'COMMON.LOCAL'
7562       include 'COMMON.TORSION'
7563       include 'COMMON.INTERACT'
7564       include 'COMMON.DERIV'
7565       include 'COMMON.CHAIN'
7566       include 'COMMON.NAMES'
7567       include 'COMMON.IOUNITS'
7568       include 'COMMON.FFIELD'
7569       include 'COMMON.TORCNSTR'
7570       include 'COMMON.CONTROL'
7571       logical lprn
7572 C Set lprn=.true. for debugging
7573       lprn=.false.
7574 c      lprn=.true.
7575       etors=0.0D0
7576       do i=iphi_start,iphi_end
7577       etors_ii=0.0D0
7578         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7579      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7580         itori=itortyp(itype(i-2))
7581         itori1=itortyp(itype(i-1))
7582         phii=phi(i)
7583         gloci=0.0D0
7584 C Proline-Proline pair is a special case...
7585         if (itori.eq.3 .and. itori1.eq.3) then
7586           if (phii.gt.-dwapi3) then
7587             cosphi=dcos(3*phii)
7588             fac=1.0D0/(1.0D0-cosphi)
7589             etorsi=v1(1,3,3)*fac
7590             etorsi=etorsi+etorsi
7591             etors=etors+etorsi-v1(1,3,3)
7592             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7593             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7594           endif
7595           do j=1,3
7596             v1ij=v1(j+1,itori,itori1)
7597             v2ij=v2(j+1,itori,itori1)
7598             cosphi=dcos(j*phii)
7599             sinphi=dsin(j*phii)
7600             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7601             if (energy_dec) etors_ii=etors_ii+
7602      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7603             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7604           enddo
7605         else
7606           do j=1,nterm_old
7607             v1ij=v1(j,itori,itori1)
7608             v2ij=v2(j,itori,itori1)
7609             cosphi=dcos(j*phii)
7610             sinphi=dsin(j*phii)
7611             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7612             if (energy_dec) etors_ii=etors_ii+
7613      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7614             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7615           enddo
7616         endif
7617         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7618              'etor',i,etors_ii
7619         if (lprn)
7620      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7621      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7622      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7623         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7624 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7625       enddo
7626 ! 6/20/98 - dihedral angle constraints
7627       edihcnstr=0.0d0
7628       do i=1,ndih_constr
7629         itori=idih_constr(i)
7630         phii=phi(itori)
7631         difi=phii-phi0(i)
7632         if (difi.gt.drange(i)) then
7633           difi=difi-drange(i)
7634           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7635           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7636         else if (difi.lt.-drange(i)) then
7637           difi=difi+drange(i)
7638           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7639           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7640         endif
7641 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7642 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7643       enddo
7644 !      write (iout,*) 'edihcnstr',edihcnstr
7645       return
7646       end
7647 c------------------------------------------------------------------------------
7648       subroutine etor_d(etors_d)
7649       etors_d=0.0d0
7650       return
7651       end
7652 c----------------------------------------------------------------------------
7653 #else
7654       subroutine etor(etors,edihcnstr)
7655       implicit real*8 (a-h,o-z)
7656       include 'DIMENSIONS'
7657       include 'COMMON.VAR'
7658       include 'COMMON.GEO'
7659       include 'COMMON.LOCAL'
7660       include 'COMMON.TORSION'
7661       include 'COMMON.INTERACT'
7662       include 'COMMON.DERIV'
7663       include 'COMMON.CHAIN'
7664       include 'COMMON.NAMES'
7665       include 'COMMON.IOUNITS'
7666       include 'COMMON.FFIELD'
7667       include 'COMMON.TORCNSTR'
7668       include 'COMMON.CONTROL'
7669       logical lprn
7670 C Set lprn=.true. for debugging
7671       lprn=.false.
7672 c     lprn=.true.
7673       etors=0.0D0
7674       do i=iphi_start,iphi_end
7675 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7676 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7677 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7678 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7679         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7680      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7681 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7682 C For introducing the NH3+ and COO- group please check the etor_d for reference
7683 C and guidance
7684         etors_ii=0.0D0
7685          if (iabs(itype(i)).eq.20) then
7686          iblock=2
7687          else
7688          iblock=1
7689          endif
7690         itori=itortyp(itype(i-2))
7691         itori1=itortyp(itype(i-1))
7692         phii=phi(i)
7693         gloci=0.0D0
7694 C Regular cosine and sine terms
7695         do j=1,nterm(itori,itori1,iblock)
7696           v1ij=v1(j,itori,itori1,iblock)
7697           v2ij=v2(j,itori,itori1,iblock)
7698           cosphi=dcos(j*phii)
7699           sinphi=dsin(j*phii)
7700           etors=etors+v1ij*cosphi+v2ij*sinphi
7701           if (energy_dec) etors_ii=etors_ii+
7702      &                v1ij*cosphi+v2ij*sinphi
7703           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7704         enddo
7705 C Lorentz terms
7706 C                         v1
7707 C  E = SUM ----------------------------------- - v1
7708 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7709 C
7710         cosphi=dcos(0.5d0*phii)
7711         sinphi=dsin(0.5d0*phii)
7712         do j=1,nlor(itori,itori1,iblock)
7713           vl1ij=vlor1(j,itori,itori1)
7714           vl2ij=vlor2(j,itori,itori1)
7715           vl3ij=vlor3(j,itori,itori1)
7716           pom=vl2ij*cosphi+vl3ij*sinphi
7717           pom1=1.0d0/(pom*pom+1.0d0)
7718           etors=etors+vl1ij*pom1
7719           if (energy_dec) etors_ii=etors_ii+
7720      &                vl1ij*pom1
7721           pom=-pom*pom1*pom1
7722           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7723         enddo
7724 C Subtract the constant term
7725         etors=etors-v0(itori,itori1,iblock)
7726           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7727      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7728         if (lprn)
7729      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7730      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7731      &  (v1(j,itori,itori1,iblock),j=1,6),
7732      &  (v2(j,itori,itori1,iblock),j=1,6)
7733         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7734 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7735       enddo
7736 ! 6/20/98 - dihedral angle constraints
7737       edihcnstr=0.0d0
7738 c      do i=1,ndih_constr
7739       do i=idihconstr_start,idihconstr_end
7740         itori=idih_constr(i)
7741         phii=phi(itori)
7742         difi=pinorm(phii-phi0(i))
7743         if (difi.gt.drange(i)) then
7744           difi=difi-drange(i)
7745           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7746           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7747         else if (difi.lt.-drange(i)) then
7748           difi=difi+drange(i)
7749           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7750           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7751         else
7752           difi=0.0
7753         endif
7754        if (energy_dec) then
7755         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7756      &    i,itori,rad2deg*phii,
7757      &    rad2deg*phi0(i),  rad2deg*drange(i),
7758      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7759         endif
7760       enddo
7761 cd       write (iout,*) 'edihcnstr',edihcnstr
7762       return
7763       end
7764 c----------------------------------------------------------------------------
7765       subroutine etor_d(etors_d)
7766 C 6/23/01 Compute double torsional energy
7767       implicit real*8 (a-h,o-z)
7768       include 'DIMENSIONS'
7769       include 'COMMON.VAR'
7770       include 'COMMON.GEO'
7771       include 'COMMON.LOCAL'
7772       include 'COMMON.TORSION'
7773       include 'COMMON.INTERACT'
7774       include 'COMMON.DERIV'
7775       include 'COMMON.CHAIN'
7776       include 'COMMON.NAMES'
7777       include 'COMMON.IOUNITS'
7778       include 'COMMON.FFIELD'
7779       include 'COMMON.TORCNSTR'
7780       logical lprn
7781 C Set lprn=.true. for debugging
7782       lprn=.false.
7783 c     lprn=.true.
7784       etors_d=0.0D0
7785 c      write(iout,*) "a tu??"
7786       do i=iphid_start,iphid_end
7787 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7788 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7789 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7790 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7791 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7792          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7793      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7794      &  (itype(i+1).eq.ntyp1)) cycle
7795 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7796         itori=itortyp(itype(i-2))
7797         itori1=itortyp(itype(i-1))
7798         itori2=itortyp(itype(i))
7799         phii=phi(i)
7800         phii1=phi(i+1)
7801         gloci1=0.0D0
7802         gloci2=0.0D0
7803         iblock=1
7804         if (iabs(itype(i+1)).eq.20) iblock=2
7805 C Iblock=2 Proline type
7806 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7807 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7808 C        if (itype(i+1).eq.ntyp1) iblock=3
7809 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7810 C IS or IS NOT need for this
7811 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7812 C        is (itype(i-3).eq.ntyp1) ntblock=2
7813 C        ntblock is N-terminal blocking group
7814
7815 C Regular cosine and sine terms
7816         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7817 C Example of changes for NH3+ blocking group
7818 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7819 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7820           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7821           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7822           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7823           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7824           cosphi1=dcos(j*phii)
7825           sinphi1=dsin(j*phii)
7826           cosphi2=dcos(j*phii1)
7827           sinphi2=dsin(j*phii1)
7828           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7829      &     v2cij*cosphi2+v2sij*sinphi2
7830           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7831           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7832         enddo
7833         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7834           do l=1,k-1
7835             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7836             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7837             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7838             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7839             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7840             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7841             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7842             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7843             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7844      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7845             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7846      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7847             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7848      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7849           enddo
7850         enddo
7851         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7852         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7853       enddo
7854       return
7855       end
7856 #endif
7857 C----------------------------------------------------------------------------------
7858 C The rigorous attempt to derive energy function
7859       subroutine etor_kcc(etors,edihcnstr)
7860       implicit real*8 (a-h,o-z)
7861       include 'DIMENSIONS'
7862       include 'COMMON.VAR'
7863       include 'COMMON.GEO'
7864       include 'COMMON.LOCAL'
7865       include 'COMMON.TORSION'
7866       include 'COMMON.INTERACT'
7867       include 'COMMON.DERIV'
7868       include 'COMMON.CHAIN'
7869       include 'COMMON.NAMES'
7870       include 'COMMON.IOUNITS'
7871       include 'COMMON.FFIELD'
7872       include 'COMMON.TORCNSTR'
7873       include 'COMMON.CONTROL'
7874       logical lprn
7875 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7876 C Set lprn=.true. for debugging
7877       lprn=.false.
7878 c     lprn=.true.
7879 C      print *,"wchodze kcc"
7880       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7881       if (tor_mode.ne.2) then
7882       etors=0.0D0
7883       endif
7884       do i=iphi_start,iphi_end
7885 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7886 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7887 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7888 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7889         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7890      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7891         itori=itortyp_kcc(itype(i-2))
7892         itori1=itortyp_kcc(itype(i-1))
7893         phii=phi(i)
7894         glocig=0.0D0
7895         glocit1=0.0d0
7896         glocit2=0.0d0
7897         sumnonchebyshev=0.0d0
7898         sumchebyshev=0.0d0
7899 C to avoid multiple devision by 2
7900 c        theti22=0.5d0*theta(i)
7901 C theta 12 is the theta_1 /2
7902 C theta 22 is theta_2 /2
7903 c        theti12=0.5d0*theta(i-1)
7904 C and appropriate sinus function
7905         sinthet1=dsin(theta(i-1))
7906         sinthet2=dsin(theta(i))
7907         costhet1=dcos(theta(i-1))
7908         costhet2=dcos(theta(i))
7909 c Cosines of halves thetas
7910         costheti12=0.5d0*(1.0d0+costhet1)
7911         costheti22=0.5d0*(1.0d0+costhet2)
7912 C to speed up lets store its mutliplication
7913         sint1t2=sinthet2*sinthet1
7914         sint1t2n=1.0d0
7915 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7916 C +d_n*sin(n*gamma)) *
7917 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7918 C we have two sum 1) Non-Chebyshev which is with n and gamma
7919         etori=0.0d0
7920         do j=1,nterm_kcc(itori,itori1)
7921
7922           nval=nterm_kcc_Tb(itori,itori1)
7923           v1ij=v1_kcc(j,itori,itori1)
7924           v2ij=v2_kcc(j,itori,itori1)
7925 c          write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7926 C v1ij is c_n and d_n in euation above
7927           cosphi=dcos(j*phii)
7928           sinphi=dsin(j*phii)
7929           sint1t2n1=sint1t2n
7930           sint1t2n=sint1t2n*sint1t2
7931           sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7932      &        costheti12)
7933           gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7934      &        v11_chyb(1,j,itori,itori1),costheti12)
7935 c          write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7936 c     &      " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7937           sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7938      &        costheti22)
7939           gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7940      &        v21_chyb(1,j,itori,itori1),costheti22)
7941 c          write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7942 c     &      " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7943           sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7944      &        costheti12)
7945           gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7946      &        v12_chyb(1,j,itori,itori1),costheti12)
7947 c          write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7948 c     &      " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7949           sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7950      &        costheti22)
7951           gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7952      &        v22_chyb(1,j,itori,itori1),costheti22)
7953 c          write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7954 c     &      " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7955 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7956 C          if (energy_dec) etors_ii=etors_ii+
7957 C     &                v1ij*cosphi+v2ij*sinphi
7958 C glocig is the gradient local i site in gamma
7959           actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7960           actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7961           etori=etori+sint1t2n*(actval1+actval2)
7962           glocig=glocig+
7963      &        j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7964      &        -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7965 C now gradient over theta_1
7966           glocit1=glocit1+
7967      &       j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7968      &       sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7969           glocit2=glocit2+
7970      &       j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7971      &       sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7972
7973 C now the Czebyshev polinominal sum
7974 c        do k=1,nterm_kcc_Tb(itori,itori1)
7975 c         thybt1(k)=v1_chyb(k,j,itori,itori1)
7976 c         thybt2(k)=v2_chyb(k,j,itori,itori1)
7977 C         thybt1(k)=0.0
7978 C         thybt2(k)=0.0
7979 c        enddo
7980 C        print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7981 C     &         gradtschebyshev
7982 C     &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7983 C     &         dcos(theti22)**2),
7984 C     &         dsin(theti22)
7985
7986 C now overal sumation
7987 C         print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7988         enddo ! j
7989         etors=etors+etori
7990 C derivative over gamma
7991         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7992 C derivative over theta1
7993         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7994 C now derivative over theta2
7995         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7996         if (lprn)
7997      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7998      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7999       enddo
8000 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8001 ! 6/20/98 - dihedral angle constraints
8002       if (tor_mode.ne.2) then
8003       edihcnstr=0.0d0
8004 c      do i=1,ndih_constr
8005       do i=idihconstr_start,idihconstr_end
8006         itori=idih_constr(i)
8007         phii=phi(itori)
8008         difi=pinorm(phii-phi0(i))
8009         if (difi.gt.drange(i)) then
8010           difi=difi-drange(i)
8011           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8012           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8013         else if (difi.lt.-drange(i)) then
8014           difi=difi+drange(i)
8015           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8016           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8017         else
8018           difi=0.0
8019         endif
8020        enddo
8021        endif
8022       return
8023       end
8024
8025 C The rigorous attempt to derive energy function
8026       subroutine ebend_kcc(etheta,ethetacnstr)
8027
8028       implicit real*8 (a-h,o-z)
8029       include 'DIMENSIONS'
8030       include 'COMMON.VAR'
8031       include 'COMMON.GEO'
8032       include 'COMMON.LOCAL'
8033       include 'COMMON.TORSION'
8034       include 'COMMON.INTERACT'
8035       include 'COMMON.DERIV'
8036       include 'COMMON.CHAIN'
8037       include 'COMMON.NAMES'
8038       include 'COMMON.IOUNITS'
8039       include 'COMMON.FFIELD'
8040       include 'COMMON.TORCNSTR'
8041       include 'COMMON.CONTROL'
8042       logical lprn
8043       double precision thybt1(maxtermkcc)
8044 C Set lprn=.true. for debugging
8045       lprn=.false.
8046 c     lprn=.true.
8047 C      print *,"wchodze kcc"
8048       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8049       if (tor_mode.ne.2) etheta=0.0D0
8050       do i=ithet_start,ithet_end
8051 c        print *,i,itype(i-1),itype(i),itype(i-2)
8052         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8053      &  .or.itype(i).eq.ntyp1) cycle
8054          iti=itortyp_kcc(itype(i-1))
8055         sinthet=dsin(theta(i)/2.0d0)
8056         costhet=dcos(theta(i)/2.0d0)
8057          do j=1,nbend_kcc_Tb(iti)
8058           thybt1(j)=v1bend_chyb(j,iti)
8059          enddo
8060          sumth1thyb=tschebyshev
8061      &         (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8062         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8063      &    sumth1thyb
8064         ihelp=nbend_kcc_Tb(iti)-1
8065         gradthybt1=gradtschebyshev
8066      &         (0,ihelp,thybt1(1),costhet)
8067         etheta=etheta+sumth1thyb
8068 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8069         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8070      &   gradthybt1*sinthet*(-0.5d0)
8071       enddo
8072       if (tor_mode.ne.2) then
8073       ethetacnstr=0.0d0
8074 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8075       do i=ithetaconstr_start,ithetaconstr_end
8076         itheta=itheta_constr(i)
8077         thetiii=theta(itheta)
8078         difi=pinorm(thetiii-theta_constr0(i))
8079         if (difi.gt.theta_drange(i)) then
8080           difi=difi-theta_drange(i)
8081           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8082           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8083      &    +for_thet_constr(i)*difi**3
8084         else if (difi.lt.-drange(i)) then
8085           difi=difi+drange(i)
8086           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8087           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8088      &    +for_thet_constr(i)*difi**3
8089         else
8090           difi=0.0
8091         endif
8092        if (energy_dec) then
8093         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8094      &    i,itheta,rad2deg*thetiii,
8095      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8096      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8097      &    gloc(itheta+nphi-2,icg)
8098         endif
8099       enddo
8100       endif
8101       return
8102       end
8103 c------------------------------------------------------------------------------
8104       subroutine eback_sc_corr(esccor)
8105 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8106 c        conformational states; temporarily implemented as differences
8107 c        between UNRES torsional potentials (dependent on three types of
8108 c        residues) and the torsional potentials dependent on all 20 types
8109 c        of residues computed from AM1  energy surfaces of terminally-blocked
8110 c        amino-acid residues.
8111       implicit real*8 (a-h,o-z)
8112       include 'DIMENSIONS'
8113       include 'COMMON.VAR'
8114       include 'COMMON.GEO'
8115       include 'COMMON.LOCAL'
8116       include 'COMMON.TORSION'
8117       include 'COMMON.SCCOR'
8118       include 'COMMON.INTERACT'
8119       include 'COMMON.DERIV'
8120       include 'COMMON.CHAIN'
8121       include 'COMMON.NAMES'
8122       include 'COMMON.IOUNITS'
8123       include 'COMMON.FFIELD'
8124       include 'COMMON.CONTROL'
8125       logical lprn
8126 C Set lprn=.true. for debugging
8127       lprn=.false.
8128 c      lprn=.true.
8129 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8130       esccor=0.0D0
8131       do i=itau_start,itau_end
8132         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8133         esccor_ii=0.0D0
8134         isccori=isccortyp(itype(i-2))
8135         isccori1=isccortyp(itype(i-1))
8136 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8137         phii=phi(i)
8138         do intertyp=1,3 !intertyp
8139 cc Added 09 May 2012 (Adasko)
8140 cc  Intertyp means interaction type of backbone mainchain correlation:
8141 c   1 = SC...Ca...Ca...Ca
8142 c   2 = Ca...Ca...Ca...SC
8143 c   3 = SC...Ca...Ca...SCi
8144         gloci=0.0D0
8145         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8146      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8147      &      (itype(i-1).eq.ntyp1)))
8148      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8149      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8150      &     .or.(itype(i).eq.ntyp1)))
8151      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8152      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8153      &      (itype(i-3).eq.ntyp1)))) cycle
8154         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8155         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8156      & cycle
8157        do j=1,nterm_sccor(isccori,isccori1)
8158           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8159           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8160           cosphi=dcos(j*tauangle(intertyp,i))
8161           sinphi=dsin(j*tauangle(intertyp,i))
8162           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8163           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8164         enddo
8165 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8166         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8167         if (lprn)
8168      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8169      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8170      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8171      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8172         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8173        enddo !intertyp
8174       enddo
8175
8176       return
8177       end
8178 c----------------------------------------------------------------------------
8179       subroutine multibody(ecorr)
8180 C This subroutine calculates multi-body contributions to energy following
8181 C the idea of Skolnick et al. If side chains I and J make a contact and
8182 C at the same time side chains I+1 and J+1 make a contact, an extra
8183 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8184       implicit real*8 (a-h,o-z)
8185       include 'DIMENSIONS'
8186       include 'COMMON.IOUNITS'
8187       include 'COMMON.DERIV'
8188       include 'COMMON.INTERACT'
8189       include 'COMMON.CONTACTS'
8190       double precision gx(3),gx1(3)
8191       logical lprn
8192
8193 C Set lprn=.true. for debugging
8194       lprn=.false.
8195
8196       if (lprn) then
8197         write (iout,'(a)') 'Contact function values:'
8198         do i=nnt,nct-2
8199           write (iout,'(i2,20(1x,i2,f10.5))')
8200      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8201         enddo
8202       endif
8203       ecorr=0.0D0
8204       do i=nnt,nct
8205         do j=1,3
8206           gradcorr(j,i)=0.0D0
8207           gradxorr(j,i)=0.0D0
8208         enddo
8209       enddo
8210       do i=nnt,nct-2
8211
8212         DO ISHIFT = 3,4
8213
8214         i1=i+ishift
8215         num_conti=num_cont(i)
8216         num_conti1=num_cont(i1)
8217         do jj=1,num_conti
8218           j=jcont(jj,i)
8219           do kk=1,num_conti1
8220             j1=jcont(kk,i1)
8221             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8222 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8223 cd   &                   ' ishift=',ishift
8224 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8225 C The system gains extra energy.
8226               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8227             endif   ! j1==j+-ishift
8228           enddo     ! kk
8229         enddo       ! jj
8230
8231         ENDDO ! ISHIFT
8232
8233       enddo         ! i
8234       return
8235       end
8236 c------------------------------------------------------------------------------
8237       double precision function esccorr(i,j,k,l,jj,kk)
8238       implicit real*8 (a-h,o-z)
8239       include 'DIMENSIONS'
8240       include 'COMMON.IOUNITS'
8241       include 'COMMON.DERIV'
8242       include 'COMMON.INTERACT'
8243       include 'COMMON.CONTACTS'
8244       include 'COMMON.SHIELD'
8245       double precision gx(3),gx1(3)
8246       logical lprn
8247       lprn=.false.
8248       eij=facont(jj,i)
8249       ekl=facont(kk,k)
8250 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8251 C Calculate the multi-body contribution to energy.
8252 C Calculate multi-body contributions to the gradient.
8253 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8254 cd   & k,l,(gacont(m,kk,k),m=1,3)
8255       do m=1,3
8256         gx(m) =ekl*gacont(m,jj,i)
8257         gx1(m)=eij*gacont(m,kk,k)
8258         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8259         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8260         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8261         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8262       enddo
8263       do m=i,j-1
8264         do ll=1,3
8265           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8266         enddo
8267       enddo
8268       do m=k,l-1
8269         do ll=1,3
8270           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8271         enddo
8272       enddo
8273       esccorr=-eij*ekl
8274       return
8275       end
8276 c------------------------------------------------------------------------------
8277       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8278 C This subroutine calculates multi-body contributions to hydrogen-bonding
8279       implicit real*8 (a-h,o-z)
8280       include 'DIMENSIONS'
8281       include 'COMMON.IOUNITS'
8282 #ifdef MPI
8283       include "mpif.h"
8284       parameter (max_cont=maxconts)
8285       parameter (max_dim=26)
8286       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8287       double precision zapas(max_dim,maxconts,max_fg_procs),
8288      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8289       common /przechowalnia/ zapas
8290       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8291      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8292 #endif
8293       include 'COMMON.SETUP'
8294       include 'COMMON.FFIELD'
8295       include 'COMMON.DERIV'
8296       include 'COMMON.INTERACT'
8297       include 'COMMON.CONTACTS'
8298       include 'COMMON.CONTROL'
8299       include 'COMMON.LOCAL'
8300       double precision gx(3),gx1(3),time00
8301       logical lprn,ldone
8302
8303 C Set lprn=.true. for debugging
8304       lprn=.false.
8305 #ifdef MPI
8306       n_corr=0
8307       n_corr1=0
8308       if (nfgtasks.le.1) goto 30
8309       if (lprn) then
8310         write (iout,'(a)') 'Contact function values before RECEIVE:'
8311         do i=nnt,nct-2
8312           write (iout,'(2i3,50(1x,i2,f5.2))')
8313      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8314      &    j=1,num_cont_hb(i))
8315         enddo
8316       endif
8317       call flush(iout)
8318       do i=1,ntask_cont_from
8319         ncont_recv(i)=0
8320       enddo
8321       do i=1,ntask_cont_to
8322         ncont_sent(i)=0
8323       enddo
8324 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8325 c     & ntask_cont_to
8326 C Make the list of contacts to send to send to other procesors
8327 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8328 c      call flush(iout)
8329       do i=iturn3_start,iturn3_end
8330 c        write (iout,*) "make contact list turn3",i," num_cont",
8331 c     &    num_cont_hb(i)
8332         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8333       enddo
8334       do i=iturn4_start,iturn4_end
8335 c        write (iout,*) "make contact list turn4",i," num_cont",
8336 c     &   num_cont_hb(i)
8337         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8338       enddo
8339       do ii=1,nat_sent
8340         i=iat_sent(ii)
8341 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8342 c     &    num_cont_hb(i)
8343         do j=1,num_cont_hb(i)
8344         do k=1,4
8345           jjc=jcont_hb(j,i)
8346           iproc=iint_sent_local(k,jjc,ii)
8347 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8348           if (iproc.gt.0) then
8349             ncont_sent(iproc)=ncont_sent(iproc)+1
8350             nn=ncont_sent(iproc)
8351             zapas(1,nn,iproc)=i
8352             zapas(2,nn,iproc)=jjc
8353             zapas(3,nn,iproc)=facont_hb(j,i)
8354             zapas(4,nn,iproc)=ees0p(j,i)
8355             zapas(5,nn,iproc)=ees0m(j,i)
8356             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8357             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8358             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8359             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8360             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8361             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8362             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8363             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8364             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8365             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8366             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8367             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8368             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8369             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8370             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8371             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8372             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8373             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8374             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8375             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8376             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8377           endif
8378         enddo
8379         enddo
8380       enddo
8381       if (lprn) then
8382       write (iout,*)
8383      &  "Numbers of contacts to be sent to other processors",
8384      &  (ncont_sent(i),i=1,ntask_cont_to)
8385       write (iout,*) "Contacts sent"
8386       do ii=1,ntask_cont_to
8387         nn=ncont_sent(ii)
8388         iproc=itask_cont_to(ii)
8389         write (iout,*) nn," contacts to processor",iproc,
8390      &   " of CONT_TO_COMM group"
8391         do i=1,nn
8392           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8393         enddo
8394       enddo
8395       call flush(iout)
8396       endif
8397       CorrelType=477
8398       CorrelID=fg_rank+1
8399       CorrelType1=478
8400       CorrelID1=nfgtasks+fg_rank+1
8401       ireq=0
8402 C Receive the numbers of needed contacts from other processors
8403       do ii=1,ntask_cont_from
8404         iproc=itask_cont_from(ii)
8405         ireq=ireq+1
8406         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8407      &    FG_COMM,req(ireq),IERR)
8408       enddo
8409 c      write (iout,*) "IRECV ended"
8410 c      call flush(iout)
8411 C Send the number of contacts needed by other processors
8412       do ii=1,ntask_cont_to
8413         iproc=itask_cont_to(ii)
8414         ireq=ireq+1
8415         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8416      &    FG_COMM,req(ireq),IERR)
8417       enddo
8418 c      write (iout,*) "ISEND ended"
8419 c      write (iout,*) "number of requests (nn)",ireq
8420       call flush(iout)
8421       if (ireq.gt.0)
8422      &  call MPI_Waitall(ireq,req,status_array,ierr)
8423 c      write (iout,*)
8424 c     &  "Numbers of contacts to be received from other processors",
8425 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8426 c      call flush(iout)
8427 C Receive contacts
8428       ireq=0
8429       do ii=1,ntask_cont_from
8430         iproc=itask_cont_from(ii)
8431         nn=ncont_recv(ii)
8432 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8433 c     &   " of CONT_TO_COMM group"
8434         call flush(iout)
8435         if (nn.gt.0) then
8436           ireq=ireq+1
8437           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8438      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8439 c          write (iout,*) "ireq,req",ireq,req(ireq)
8440         endif
8441       enddo
8442 C Send the contacts to processors that need them
8443       do ii=1,ntask_cont_to
8444         iproc=itask_cont_to(ii)
8445         nn=ncont_sent(ii)
8446 c        write (iout,*) nn," contacts to processor",iproc,
8447 c     &   " of CONT_TO_COMM group"
8448         if (nn.gt.0) then
8449           ireq=ireq+1
8450           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8451      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8452 c          write (iout,*) "ireq,req",ireq,req(ireq)
8453 c          do i=1,nn
8454 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8455 c          enddo
8456         endif
8457       enddo
8458 c      write (iout,*) "number of requests (contacts)",ireq
8459 c      write (iout,*) "req",(req(i),i=1,4)
8460 c      call flush(iout)
8461       if (ireq.gt.0)
8462      & call MPI_Waitall(ireq,req,status_array,ierr)
8463       do iii=1,ntask_cont_from
8464         iproc=itask_cont_from(iii)
8465         nn=ncont_recv(iii)
8466         if (lprn) then
8467         write (iout,*) "Received",nn," contacts from processor",iproc,
8468      &   " of CONT_FROM_COMM group"
8469         call flush(iout)
8470         do i=1,nn
8471           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8472         enddo
8473         call flush(iout)
8474         endif
8475         do i=1,nn
8476           ii=zapas_recv(1,i,iii)
8477 c Flag the received contacts to prevent double-counting
8478           jj=-zapas_recv(2,i,iii)
8479 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8480 c          call flush(iout)
8481           nnn=num_cont_hb(ii)+1
8482           num_cont_hb(ii)=nnn
8483           jcont_hb(nnn,ii)=jj
8484           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8485           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8486           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8487           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8488           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8489           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8490           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8491           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8492           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8493           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8494           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8495           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8496           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8497           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8498           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8499           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8500           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8501           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8502           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8503           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8504           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8505           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8506           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8507           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8508         enddo
8509       enddo
8510       call flush(iout)
8511       if (lprn) then
8512         write (iout,'(a)') 'Contact function values after receive:'
8513         do i=nnt,nct-2
8514           write (iout,'(2i3,50(1x,i3,f5.2))')
8515      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8516      &    j=1,num_cont_hb(i))
8517         enddo
8518         call flush(iout)
8519       endif
8520    30 continue
8521 #endif
8522       if (lprn) then
8523         write (iout,'(a)') 'Contact function values:'
8524         do i=nnt,nct-2
8525           write (iout,'(2i3,50(1x,i3,f5.2))')
8526      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8527      &    j=1,num_cont_hb(i))
8528         enddo
8529       endif
8530       ecorr=0.0D0
8531 C Remove the loop below after debugging !!!
8532       do i=nnt,nct
8533         do j=1,3
8534           gradcorr(j,i)=0.0D0
8535           gradxorr(j,i)=0.0D0
8536         enddo
8537       enddo
8538 C Calculate the local-electrostatic correlation terms
8539       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8540         i1=i+1
8541         num_conti=num_cont_hb(i)
8542         num_conti1=num_cont_hb(i+1)
8543         do jj=1,num_conti
8544           j=jcont_hb(jj,i)
8545           jp=iabs(j)
8546           do kk=1,num_conti1
8547             j1=jcont_hb(kk,i1)
8548             jp1=iabs(j1)
8549 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8550 c     &         ' jj=',jj,' kk=',kk
8551             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8552      &          .or. j.lt.0 .and. j1.gt.0) .and.
8553      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8554 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8555 C The system gains extra energy.
8556               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8557               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8558      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8559               n_corr=n_corr+1
8560             else if (j1.eq.j) then
8561 C Contacts I-J and I-(J+1) occur simultaneously.
8562 C The system loses extra energy.
8563 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8564             endif
8565           enddo ! kk
8566           do kk=1,num_conti
8567             j1=jcont_hb(kk,i)
8568 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8569 c    &         ' jj=',jj,' kk=',kk
8570             if (j1.eq.j+1) then
8571 C Contacts I-J and (I+1)-J occur simultaneously.
8572 C The system loses extra energy.
8573 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8574             endif ! j1==j+1
8575           enddo ! kk
8576         enddo ! jj
8577       enddo ! i
8578       return
8579       end
8580 c------------------------------------------------------------------------------
8581       subroutine add_hb_contact(ii,jj,itask)
8582       implicit real*8 (a-h,o-z)
8583       include "DIMENSIONS"
8584       include "COMMON.IOUNITS"
8585       integer max_cont
8586       integer max_dim
8587       parameter (max_cont=maxconts)
8588       parameter (max_dim=26)
8589       include "COMMON.CONTACTS"
8590       double precision zapas(max_dim,maxconts,max_fg_procs),
8591      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8592       common /przechowalnia/ zapas
8593       integer i,j,ii,jj,iproc,itask(4),nn
8594 c      write (iout,*) "itask",itask
8595       do i=1,2
8596         iproc=itask(i)
8597         if (iproc.gt.0) then
8598           do j=1,num_cont_hb(ii)
8599             jjc=jcont_hb(j,ii)
8600 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8601             if (jjc.eq.jj) then
8602               ncont_sent(iproc)=ncont_sent(iproc)+1
8603               nn=ncont_sent(iproc)
8604               zapas(1,nn,iproc)=ii
8605               zapas(2,nn,iproc)=jjc
8606               zapas(3,nn,iproc)=facont_hb(j,ii)
8607               zapas(4,nn,iproc)=ees0p(j,ii)
8608               zapas(5,nn,iproc)=ees0m(j,ii)
8609               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8610               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8611               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8612               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8613               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8614               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8615               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8616               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8617               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8618               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8619               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8620               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8621               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8622               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8623               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8624               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8625               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8626               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8627               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8628               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8629               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8630               exit
8631             endif
8632           enddo
8633         endif
8634       enddo
8635       return
8636       end
8637 c------------------------------------------------------------------------------
8638       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8639      &  n_corr1)
8640 C This subroutine calculates multi-body contributions to hydrogen-bonding
8641       implicit real*8 (a-h,o-z)
8642       include 'DIMENSIONS'
8643       include 'COMMON.IOUNITS'
8644 #ifdef MPI
8645       include "mpif.h"
8646       parameter (max_cont=maxconts)
8647       parameter (max_dim=70)
8648       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8649       double precision zapas(max_dim,maxconts,max_fg_procs),
8650      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8651       common /przechowalnia/ zapas
8652       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8653      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8654 #endif
8655       include 'COMMON.SETUP'
8656       include 'COMMON.FFIELD'
8657       include 'COMMON.DERIV'
8658       include 'COMMON.LOCAL'
8659       include 'COMMON.INTERACT'
8660       include 'COMMON.CONTACTS'
8661       include 'COMMON.CHAIN'
8662       include 'COMMON.CONTROL'
8663       include 'COMMON.SHIELD'
8664       double precision gx(3),gx1(3)
8665       integer num_cont_hb_old(maxres)
8666       logical lprn,ldone
8667       double precision eello4,eello5,eelo6,eello_turn6
8668       external eello4,eello5,eello6,eello_turn6
8669 C Set lprn=.true. for debugging
8670       lprn=.false.
8671       eturn6=0.0d0
8672 #ifdef MPI
8673       do i=1,nres
8674         num_cont_hb_old(i)=num_cont_hb(i)
8675       enddo
8676       n_corr=0
8677       n_corr1=0
8678       if (nfgtasks.le.1) goto 30
8679       if (lprn) then
8680         write (iout,'(a)') 'Contact function values before RECEIVE:'
8681         do i=nnt,nct-2
8682           write (iout,'(2i3,50(1x,i2,f5.2))')
8683      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8684      &    j=1,num_cont_hb(i))
8685         enddo
8686       endif
8687       call flush(iout)
8688       do i=1,ntask_cont_from
8689         ncont_recv(i)=0
8690       enddo
8691       do i=1,ntask_cont_to
8692         ncont_sent(i)=0
8693       enddo
8694 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8695 c     & ntask_cont_to
8696 C Make the list of contacts to send to send to other procesors
8697       do i=iturn3_start,iturn3_end
8698 c        write (iout,*) "make contact list turn3",i," num_cont",
8699 c     &    num_cont_hb(i)
8700         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8701       enddo
8702       do i=iturn4_start,iturn4_end
8703 c        write (iout,*) "make contact list turn4",i," num_cont",
8704 c     &   num_cont_hb(i)
8705         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8706       enddo
8707       do ii=1,nat_sent
8708         i=iat_sent(ii)
8709 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8710 c     &    num_cont_hb(i)
8711         do j=1,num_cont_hb(i)
8712         do k=1,4
8713           jjc=jcont_hb(j,i)
8714           iproc=iint_sent_local(k,jjc,ii)
8715 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8716           if (iproc.ne.0) then
8717             ncont_sent(iproc)=ncont_sent(iproc)+1
8718             nn=ncont_sent(iproc)
8719             zapas(1,nn,iproc)=i
8720             zapas(2,nn,iproc)=jjc
8721             zapas(3,nn,iproc)=d_cont(j,i)
8722             ind=3
8723             do kk=1,3
8724               ind=ind+1
8725               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8726             enddo
8727             do kk=1,2
8728               do ll=1,2
8729                 ind=ind+1
8730                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8731               enddo
8732             enddo
8733             do jj=1,5
8734               do kk=1,3
8735                 do ll=1,2
8736                   do mm=1,2
8737                     ind=ind+1
8738                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8739                   enddo
8740                 enddo
8741               enddo
8742             enddo
8743           endif
8744         enddo
8745         enddo
8746       enddo
8747       if (lprn) then
8748       write (iout,*)
8749      &  "Numbers of contacts to be sent to other processors",
8750      &  (ncont_sent(i),i=1,ntask_cont_to)
8751       write (iout,*) "Contacts sent"
8752       do ii=1,ntask_cont_to
8753         nn=ncont_sent(ii)
8754         iproc=itask_cont_to(ii)
8755         write (iout,*) nn," contacts to processor",iproc,
8756      &   " of CONT_TO_COMM group"
8757         do i=1,nn
8758           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8759         enddo
8760       enddo
8761       call flush(iout)
8762       endif
8763       CorrelType=477
8764       CorrelID=fg_rank+1
8765       CorrelType1=478
8766       CorrelID1=nfgtasks+fg_rank+1
8767       ireq=0
8768 C Receive the numbers of needed contacts from other processors
8769       do ii=1,ntask_cont_from
8770         iproc=itask_cont_from(ii)
8771         ireq=ireq+1
8772         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8773      &    FG_COMM,req(ireq),IERR)
8774       enddo
8775 c      write (iout,*) "IRECV ended"
8776 c      call flush(iout)
8777 C Send the number of contacts needed by other processors
8778       do ii=1,ntask_cont_to
8779         iproc=itask_cont_to(ii)
8780         ireq=ireq+1
8781         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8782      &    FG_COMM,req(ireq),IERR)
8783       enddo
8784 c      write (iout,*) "ISEND ended"
8785 c      write (iout,*) "number of requests (nn)",ireq
8786       call flush(iout)
8787       if (ireq.gt.0)
8788      &  call MPI_Waitall(ireq,req,status_array,ierr)
8789 c      write (iout,*)
8790 c     &  "Numbers of contacts to be received from other processors",
8791 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8792 c      call flush(iout)
8793 C Receive contacts
8794       ireq=0
8795       do ii=1,ntask_cont_from
8796         iproc=itask_cont_from(ii)
8797         nn=ncont_recv(ii)
8798 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8799 c     &   " of CONT_TO_COMM group"
8800         call flush(iout)
8801         if (nn.gt.0) then
8802           ireq=ireq+1
8803           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8804      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8805 c          write (iout,*) "ireq,req",ireq,req(ireq)
8806         endif
8807       enddo
8808 C Send the contacts to processors that need them
8809       do ii=1,ntask_cont_to
8810         iproc=itask_cont_to(ii)
8811         nn=ncont_sent(ii)
8812 c        write (iout,*) nn," contacts to processor",iproc,
8813 c     &   " of CONT_TO_COMM group"
8814         if (nn.gt.0) then
8815           ireq=ireq+1
8816           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8817      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8818 c          write (iout,*) "ireq,req",ireq,req(ireq)
8819 c          do i=1,nn
8820 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8821 c          enddo
8822         endif
8823       enddo
8824 c      write (iout,*) "number of requests (contacts)",ireq
8825 c      write (iout,*) "req",(req(i),i=1,4)
8826 c      call flush(iout)
8827       if (ireq.gt.0)
8828      & call MPI_Waitall(ireq,req,status_array,ierr)
8829       do iii=1,ntask_cont_from
8830         iproc=itask_cont_from(iii)
8831         nn=ncont_recv(iii)
8832         if (lprn) then
8833         write (iout,*) "Received",nn," contacts from processor",iproc,
8834      &   " of CONT_FROM_COMM group"
8835         call flush(iout)
8836         do i=1,nn
8837           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8838         enddo
8839         call flush(iout)
8840         endif
8841         do i=1,nn
8842           ii=zapas_recv(1,i,iii)
8843 c Flag the received contacts to prevent double-counting
8844           jj=-zapas_recv(2,i,iii)
8845 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8846 c          call flush(iout)
8847           nnn=num_cont_hb(ii)+1
8848           num_cont_hb(ii)=nnn
8849           jcont_hb(nnn,ii)=jj
8850           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8851           ind=3
8852           do kk=1,3
8853             ind=ind+1
8854             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8855           enddo
8856           do kk=1,2
8857             do ll=1,2
8858               ind=ind+1
8859               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8860             enddo
8861           enddo
8862           do jj=1,5
8863             do kk=1,3
8864               do ll=1,2
8865                 do mm=1,2
8866                   ind=ind+1
8867                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8868                 enddo
8869               enddo
8870             enddo
8871           enddo
8872         enddo
8873       enddo
8874       call flush(iout)
8875       if (lprn) then
8876         write (iout,'(a)') 'Contact function values after receive:'
8877         do i=nnt,nct-2
8878           write (iout,'(2i3,50(1x,i3,5f6.3))')
8879      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8880      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8881         enddo
8882         call flush(iout)
8883       endif
8884    30 continue
8885 #endif
8886       if (lprn) then
8887         write (iout,'(a)') 'Contact function values:'
8888         do i=nnt,nct-2
8889           write (iout,'(2i3,50(1x,i2,5f6.3))')
8890      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8891      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8892         enddo
8893       endif
8894       ecorr=0.0D0
8895       ecorr5=0.0d0
8896       ecorr6=0.0d0
8897 C Remove the loop below after debugging !!!
8898       do i=nnt,nct
8899         do j=1,3
8900           gradcorr(j,i)=0.0D0
8901           gradxorr(j,i)=0.0D0
8902         enddo
8903       enddo
8904 C Calculate the dipole-dipole interaction energies
8905       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8906       do i=iatel_s,iatel_e+1
8907         num_conti=num_cont_hb(i)
8908         do jj=1,num_conti
8909           j=jcont_hb(jj,i)
8910 #ifdef MOMENT
8911           call dipole(i,j,jj)
8912 #endif
8913         enddo
8914       enddo
8915       endif
8916 C Calculate the local-electrostatic correlation terms
8917 c                write (iout,*) "gradcorr5 in eello5 before loop"
8918 c                do iii=1,nres
8919 c                  write (iout,'(i5,3f10.5)')
8920 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8921 c                enddo
8922       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8923 c        write (iout,*) "corr loop i",i
8924         i1=i+1
8925         num_conti=num_cont_hb(i)
8926         num_conti1=num_cont_hb(i+1)
8927         do jj=1,num_conti
8928           j=jcont_hb(jj,i)
8929           jp=iabs(j)
8930           do kk=1,num_conti1
8931             j1=jcont_hb(kk,i1)
8932             jp1=iabs(j1)
8933 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8934 c     &         ' jj=',jj,' kk=',kk
8935 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8936             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8937      &          .or. j.lt.0 .and. j1.gt.0) .and.
8938      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8939 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8940 C The system gains extra energy.
8941               n_corr=n_corr+1
8942               sqd1=dsqrt(d_cont(jj,i))
8943               sqd2=dsqrt(d_cont(kk,i1))
8944               sred_geom = sqd1*sqd2
8945               IF (sred_geom.lt.cutoff_corr) THEN
8946                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8947      &            ekont,fprimcont)
8948 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8949 cd     &         ' jj=',jj,' kk=',kk
8950                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8951                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8952                 do l=1,3
8953                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8954                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8955                 enddo
8956                 n_corr1=n_corr1+1
8957 cd               write (iout,*) 'sred_geom=',sred_geom,
8958 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8959 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8960 cd               write (iout,*) "g_contij",g_contij
8961 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8962 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8963                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8964                 if (wcorr4.gt.0.0d0)
8965      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8966 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8967                   if (energy_dec.and.wcorr4.gt.0.0d0)
8968      1                 write (iout,'(a6,4i5,0pf7.3)')
8969      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8970 c                write (iout,*) "gradcorr5 before eello5"
8971 c                do iii=1,nres
8972 c                  write (iout,'(i5,3f10.5)')
8973 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8974 c                enddo
8975                 if (wcorr5.gt.0.0d0)
8976      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8977 c                write (iout,*) "gradcorr5 after eello5"
8978 c                do iii=1,nres
8979 c                  write (iout,'(i5,3f10.5)')
8980 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8981 c                enddo
8982                   if (energy_dec.and.wcorr5.gt.0.0d0)
8983      1                 write (iout,'(a6,4i5,0pf7.3)')
8984      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8985 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8986 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8987                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8988      &               .or. wturn6.eq.0.0d0))then
8989 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8990                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8991                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8992      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8993 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8994 cd     &            'ecorr6=',ecorr6
8995 cd                write (iout,'(4e15.5)') sred_geom,
8996 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8997 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8998 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8999                 else if (wturn6.gt.0.0d0
9000      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9001 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9002                   eturn6=eturn6+eello_turn6(i,jj,kk)
9003                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9004      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9005 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9006                 endif
9007               ENDIF
9008 1111          continue
9009             endif
9010           enddo ! kk
9011         enddo ! jj
9012       enddo ! i
9013       do i=1,nres
9014         num_cont_hb(i)=num_cont_hb_old(i)
9015       enddo
9016 c                write (iout,*) "gradcorr5 in eello5"
9017 c                do iii=1,nres
9018 c                  write (iout,'(i5,3f10.5)')
9019 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9020 c                enddo
9021       return
9022       end
9023 c------------------------------------------------------------------------------
9024       subroutine add_hb_contact_eello(ii,jj,itask)
9025       implicit real*8 (a-h,o-z)
9026       include "DIMENSIONS"
9027       include "COMMON.IOUNITS"
9028       integer max_cont
9029       integer max_dim
9030       parameter (max_cont=maxconts)
9031       parameter (max_dim=70)
9032       include "COMMON.CONTACTS"
9033       double precision zapas(max_dim,maxconts,max_fg_procs),
9034      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9035       common /przechowalnia/ zapas
9036       integer i,j,ii,jj,iproc,itask(4),nn
9037 c      write (iout,*) "itask",itask
9038       do i=1,2
9039         iproc=itask(i)
9040         if (iproc.gt.0) then
9041           do j=1,num_cont_hb(ii)
9042             jjc=jcont_hb(j,ii)
9043 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9044             if (jjc.eq.jj) then
9045               ncont_sent(iproc)=ncont_sent(iproc)+1
9046               nn=ncont_sent(iproc)
9047               zapas(1,nn,iproc)=ii
9048               zapas(2,nn,iproc)=jjc
9049               zapas(3,nn,iproc)=d_cont(j,ii)
9050               ind=3
9051               do kk=1,3
9052                 ind=ind+1
9053                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9054               enddo
9055               do kk=1,2
9056                 do ll=1,2
9057                   ind=ind+1
9058                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9059                 enddo
9060               enddo
9061               do jj=1,5
9062                 do kk=1,3
9063                   do ll=1,2
9064                     do mm=1,2
9065                       ind=ind+1
9066                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9067                     enddo
9068                   enddo
9069                 enddo
9070               enddo
9071               exit
9072             endif
9073           enddo
9074         endif
9075       enddo
9076       return
9077       end
9078 c------------------------------------------------------------------------------
9079       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9080       implicit real*8 (a-h,o-z)
9081       include 'DIMENSIONS'
9082       include 'COMMON.IOUNITS'
9083       include 'COMMON.DERIV'
9084       include 'COMMON.INTERACT'
9085       include 'COMMON.CONTACTS'
9086       include 'COMMON.SHIELD'
9087       include 'COMMON.CONTROL'
9088       double precision gx(3),gx1(3)
9089       logical lprn
9090       lprn=.false.
9091 C      print *,"wchodze",fac_shield(i),shield_mode
9092       eij=facont_hb(jj,i)
9093       ekl=facont_hb(kk,k)
9094       ees0pij=ees0p(jj,i)
9095       ees0pkl=ees0p(kk,k)
9096       ees0mij=ees0m(jj,i)
9097       ees0mkl=ees0m(kk,k)
9098       ekont=eij*ekl
9099       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9100 C*
9101 C     & fac_shield(i)**2*fac_shield(j)**2
9102 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9103 C Following 4 lines for diagnostics.
9104 cd    ees0pkl=0.0D0
9105 cd    ees0pij=1.0D0
9106 cd    ees0mkl=0.0D0
9107 cd    ees0mij=1.0D0
9108 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9109 c     & 'Contacts ',i,j,
9110 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9111 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9112 c     & 'gradcorr_long'
9113 C Calculate the multi-body contribution to energy.
9114 C      ecorr=ecorr+ekont*ees
9115 C Calculate multi-body contributions to the gradient.
9116       coeffpees0pij=coeffp*ees0pij
9117       coeffmees0mij=coeffm*ees0mij
9118       coeffpees0pkl=coeffp*ees0pkl
9119       coeffmees0mkl=coeffm*ees0mkl
9120       do ll=1,3
9121 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9122         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9123      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9124      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9125         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9126      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9127      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9128 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9129         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9130      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9131      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9132         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9133      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9134      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9135         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9136      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9137      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9138         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9139         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9140         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9141      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9142      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9143         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9144         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9145 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9146       enddo
9147 c      write (iout,*)
9148 cgrad      do m=i+1,j-1
9149 cgrad        do ll=1,3
9150 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9151 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9152 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9153 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9154 cgrad        enddo
9155 cgrad      enddo
9156 cgrad      do m=k+1,l-1
9157 cgrad        do ll=1,3
9158 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9159 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9160 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9161 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9162 cgrad        enddo
9163 cgrad      enddo
9164 c      write (iout,*) "ehbcorr",ekont*ees
9165 C      print *,ekont,ees,i,k
9166       ehbcorr=ekont*ees
9167 C now gradient over shielding
9168 C      return
9169       if (shield_mode.gt.0) then
9170        j=ees0plist(jj,i)
9171        l=ees0plist(kk,k)
9172 C        print *,i,j,fac_shield(i),fac_shield(j),
9173 C     &fac_shield(k),fac_shield(l)
9174         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9175      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9176           do ilist=1,ishield_list(i)
9177            iresshield=shield_list(ilist,i)
9178            do m=1,3
9179            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9180 C     &      *2.0
9181            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9182      &              rlocshield
9183      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9184             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9185      &+rlocshield
9186            enddo
9187           enddo
9188           do ilist=1,ishield_list(j)
9189            iresshield=shield_list(ilist,j)
9190            do m=1,3
9191            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9192 C     &     *2.0
9193            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9194      &              rlocshield
9195      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9196            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9197      &     +rlocshield
9198            enddo
9199           enddo
9200
9201           do ilist=1,ishield_list(k)
9202            iresshield=shield_list(ilist,k)
9203            do m=1,3
9204            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9205 C     &     *2.0
9206            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9207      &              rlocshield
9208      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9209            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9210      &     +rlocshield
9211            enddo
9212           enddo
9213           do ilist=1,ishield_list(l)
9214            iresshield=shield_list(ilist,l)
9215            do m=1,3
9216            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9217 C     &     *2.0
9218            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9219      &              rlocshield
9220      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9221            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9222      &     +rlocshield
9223            enddo
9224           enddo
9225 C          print *,gshieldx(m,iresshield)
9226           do m=1,3
9227             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9228      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9229             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9230      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9231             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9232      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9233             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9234      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9235
9236             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9237      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9238             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9239      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9240             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9241      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9242             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9243      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9244
9245            enddo
9246       endif
9247       endif
9248       return
9249       end
9250 #ifdef MOMENT
9251 C---------------------------------------------------------------------------
9252       subroutine dipole(i,j,jj)
9253       implicit real*8 (a-h,o-z)
9254       include 'DIMENSIONS'
9255       include 'COMMON.IOUNITS'
9256       include 'COMMON.CHAIN'
9257       include 'COMMON.FFIELD'
9258       include 'COMMON.DERIV'
9259       include 'COMMON.INTERACT'
9260       include 'COMMON.CONTACTS'
9261       include 'COMMON.TORSION'
9262       include 'COMMON.VAR'
9263       include 'COMMON.GEO'
9264       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9265      &  auxmat(2,2)
9266       iti1 = itortyp(itype(i+1))
9267       if (j.lt.nres-1) then
9268         itj1 = itype2loc(itype(j+1))
9269       else
9270         itj1=nloctyp
9271       endif
9272       do iii=1,2
9273         dipi(iii,1)=Ub2(iii,i)
9274         dipderi(iii)=Ub2der(iii,i)
9275         dipi(iii,2)=b1(iii,i+1)
9276         dipj(iii,1)=Ub2(iii,j)
9277         dipderj(iii)=Ub2der(iii,j)
9278         dipj(iii,2)=b1(iii,j+1)
9279       enddo
9280       kkk=0
9281       do iii=1,2
9282         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9283         do jjj=1,2
9284           kkk=kkk+1
9285           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9286         enddo
9287       enddo
9288       do kkk=1,5
9289         do lll=1,3
9290           mmm=0
9291           do iii=1,2
9292             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9293      &        auxvec(1))
9294             do jjj=1,2
9295               mmm=mmm+1
9296               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9297             enddo
9298           enddo
9299         enddo
9300       enddo
9301       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9302       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9303       do iii=1,2
9304         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9305       enddo
9306       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9307       do iii=1,2
9308         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9309       enddo
9310       return
9311       end
9312 #endif
9313 C---------------------------------------------------------------------------
9314       subroutine calc_eello(i,j,k,l,jj,kk)
9315 C
9316 C This subroutine computes matrices and vectors needed to calculate
9317 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9318 C
9319       implicit real*8 (a-h,o-z)
9320       include 'DIMENSIONS'
9321       include 'COMMON.IOUNITS'
9322       include 'COMMON.CHAIN'
9323       include 'COMMON.DERIV'
9324       include 'COMMON.INTERACT'
9325       include 'COMMON.CONTACTS'
9326       include 'COMMON.TORSION'
9327       include 'COMMON.VAR'
9328       include 'COMMON.GEO'
9329       include 'COMMON.FFIELD'
9330       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9331      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9332       logical lprn
9333       common /kutas/ lprn
9334 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9335 cd     & ' jj=',jj,' kk=',kk
9336 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9337 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9338 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9339       do iii=1,2
9340         do jjj=1,2
9341           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9342           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9343         enddo
9344       enddo
9345       call transpose2(aa1(1,1),aa1t(1,1))
9346       call transpose2(aa2(1,1),aa2t(1,1))
9347       do kkk=1,5
9348         do lll=1,3
9349           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9350      &      aa1tder(1,1,lll,kkk))
9351           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9352      &      aa2tder(1,1,lll,kkk))
9353         enddo
9354       enddo
9355       if (l.eq.j+1) then
9356 C parallel orientation of the two CA-CA-CA frames.
9357         if (i.gt.1) then
9358           iti=itype2loc(itype(i))
9359         else
9360           iti=nloctyp
9361         endif
9362         itk1=itype2loc(itype(k+1))
9363         itj=itype2loc(itype(j))
9364         if (l.lt.nres-1) then
9365           itl1=itype2loc(itype(l+1))
9366         else
9367           itl1=nloctyp
9368         endif
9369 C A1 kernel(j+1) A2T
9370 cd        do iii=1,2
9371 cd          write (iout,'(3f10.5,5x,3f10.5)')
9372 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9373 cd        enddo
9374         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9375      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9376      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9377 C Following matrices are needed only for 6-th order cumulants
9378         IF (wcorr6.gt.0.0d0) THEN
9379         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9380      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9381      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9382         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9383      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9384      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9385      &   ADtEAderx(1,1,1,1,1,1))
9386         lprn=.false.
9387         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9388      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9389      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9390      &   ADtEA1derx(1,1,1,1,1,1))
9391         ENDIF
9392 C End 6-th order cumulants
9393 cd        lprn=.false.
9394 cd        if (lprn) then
9395 cd        write (2,*) 'In calc_eello6'
9396 cd        do iii=1,2
9397 cd          write (2,*) 'iii=',iii
9398 cd          do kkk=1,5
9399 cd            write (2,*) 'kkk=',kkk
9400 cd            do jjj=1,2
9401 cd              write (2,'(3(2f10.5),5x)')
9402 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9403 cd            enddo
9404 cd          enddo
9405 cd        enddo
9406 cd        endif
9407         call transpose2(EUgder(1,1,k),auxmat(1,1))
9408         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9409         call transpose2(EUg(1,1,k),auxmat(1,1))
9410         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9411         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9412         do iii=1,2
9413           do kkk=1,5
9414             do lll=1,3
9415               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9416      &          EAEAderx(1,1,lll,kkk,iii,1))
9417             enddo
9418           enddo
9419         enddo
9420 C A1T kernel(i+1) A2
9421         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9422      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9423      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9424 C Following matrices are needed only for 6-th order cumulants
9425         IF (wcorr6.gt.0.0d0) THEN
9426         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9427      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9428      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9429         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9430      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9431      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9432      &   ADtEAderx(1,1,1,1,1,2))
9433         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9434      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9435      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9436      &   ADtEA1derx(1,1,1,1,1,2))
9437         ENDIF
9438 C End 6-th order cumulants
9439         call transpose2(EUgder(1,1,l),auxmat(1,1))
9440         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9441         call transpose2(EUg(1,1,l),auxmat(1,1))
9442         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9443         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9444         do iii=1,2
9445           do kkk=1,5
9446             do lll=1,3
9447               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9448      &          EAEAderx(1,1,lll,kkk,iii,2))
9449             enddo
9450           enddo
9451         enddo
9452 C AEAb1 and AEAb2
9453 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9454 C They are needed only when the fifth- or the sixth-order cumulants are
9455 C indluded.
9456         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9457         call transpose2(AEA(1,1,1),auxmat(1,1))
9458         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9459         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9460         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9461         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9462         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9463         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9464         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9465         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9466         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9467         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9468         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9469         call transpose2(AEA(1,1,2),auxmat(1,1))
9470         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9471         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9472         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9473         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9474         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9475         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9476         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9477         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9478         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9479         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9480         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9481 C Calculate the Cartesian derivatives of the vectors.
9482         do iii=1,2
9483           do kkk=1,5
9484             do lll=1,3
9485               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9486               call matvec2(auxmat(1,1),b1(1,i),
9487      &          AEAb1derx(1,lll,kkk,iii,1,1))
9488               call matvec2(auxmat(1,1),Ub2(1,i),
9489      &          AEAb2derx(1,lll,kkk,iii,1,1))
9490               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9491      &          AEAb1derx(1,lll,kkk,iii,2,1))
9492               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9493      &          AEAb2derx(1,lll,kkk,iii,2,1))
9494               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9495               call matvec2(auxmat(1,1),b1(1,j),
9496      &          AEAb1derx(1,lll,kkk,iii,1,2))
9497               call matvec2(auxmat(1,1),Ub2(1,j),
9498      &          AEAb2derx(1,lll,kkk,iii,1,2))
9499               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9500      &          AEAb1derx(1,lll,kkk,iii,2,2))
9501               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9502      &          AEAb2derx(1,lll,kkk,iii,2,2))
9503             enddo
9504           enddo
9505         enddo
9506         ENDIF
9507 C End vectors
9508       else
9509 C Antiparallel orientation of the two CA-CA-CA frames.
9510         if (i.gt.1) then
9511           iti=itype2loc(itype(i))
9512         else
9513           iti=nloctyp
9514         endif
9515         itk1=itype2loc(itype(k+1))
9516         itl=itype2loc(itype(l))
9517         itj=itype2loc(itype(j))
9518         if (j.lt.nres-1) then
9519           itj1=itype2loc(itype(j+1))
9520         else
9521           itj1=nloctyp
9522         endif
9523 C A2 kernel(j-1)T A1T
9524         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9525      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9526      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9527 C Following matrices are needed only for 6-th order cumulants
9528         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9529      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9530         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9531      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9532      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9533         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9534      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9535      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9536      &   ADtEAderx(1,1,1,1,1,1))
9537         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9538      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9539      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9540      &   ADtEA1derx(1,1,1,1,1,1))
9541         ENDIF
9542 C End 6-th order cumulants
9543         call transpose2(EUgder(1,1,k),auxmat(1,1))
9544         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9545         call transpose2(EUg(1,1,k),auxmat(1,1))
9546         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9547         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9548         do iii=1,2
9549           do kkk=1,5
9550             do lll=1,3
9551               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9552      &          EAEAderx(1,1,lll,kkk,iii,1))
9553             enddo
9554           enddo
9555         enddo
9556 C A2T kernel(i+1)T A1
9557         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9558      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9559      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9560 C Following matrices are needed only for 6-th order cumulants
9561         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9562      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9563         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9564      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9565      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9566         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9567      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9568      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9569      &   ADtEAderx(1,1,1,1,1,2))
9570         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9571      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9572      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9573      &   ADtEA1derx(1,1,1,1,1,2))
9574         ENDIF
9575 C End 6-th order cumulants
9576         call transpose2(EUgder(1,1,j),auxmat(1,1))
9577         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9578         call transpose2(EUg(1,1,j),auxmat(1,1))
9579         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9580         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9581         do iii=1,2
9582           do kkk=1,5
9583             do lll=1,3
9584               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9585      &          EAEAderx(1,1,lll,kkk,iii,2))
9586             enddo
9587           enddo
9588         enddo
9589 C AEAb1 and AEAb2
9590 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9591 C They are needed only when the fifth- or the sixth-order cumulants are
9592 C indluded.
9593         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9594      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9595         call transpose2(AEA(1,1,1),auxmat(1,1))
9596         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9597         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9598         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9599         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9600         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9601         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9602         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9603         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9604         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9605         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9606         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9607         call transpose2(AEA(1,1,2),auxmat(1,1))
9608         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9609         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9610         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9611         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9612         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9613         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9614         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9615         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9616         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9617         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9618         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9619 C Calculate the Cartesian derivatives of the vectors.
9620         do iii=1,2
9621           do kkk=1,5
9622             do lll=1,3
9623               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9624               call matvec2(auxmat(1,1),b1(1,i),
9625      &          AEAb1derx(1,lll,kkk,iii,1,1))
9626               call matvec2(auxmat(1,1),Ub2(1,i),
9627      &          AEAb2derx(1,lll,kkk,iii,1,1))
9628               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9629      &          AEAb1derx(1,lll,kkk,iii,2,1))
9630               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9631      &          AEAb2derx(1,lll,kkk,iii,2,1))
9632               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9633               call matvec2(auxmat(1,1),b1(1,l),
9634      &          AEAb1derx(1,lll,kkk,iii,1,2))
9635               call matvec2(auxmat(1,1),Ub2(1,l),
9636      &          AEAb2derx(1,lll,kkk,iii,1,2))
9637               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9638      &          AEAb1derx(1,lll,kkk,iii,2,2))
9639               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9640      &          AEAb2derx(1,lll,kkk,iii,2,2))
9641             enddo
9642           enddo
9643         enddo
9644         ENDIF
9645 C End vectors
9646       endif
9647       return
9648       end
9649 C---------------------------------------------------------------------------
9650       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9651      &  KK,KKderg,AKA,AKAderg,AKAderx)
9652       implicit none
9653       integer nderg
9654       logical transp
9655       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9656      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9657      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9658       integer iii,kkk,lll
9659       integer jjj,mmm
9660       logical lprn
9661       common /kutas/ lprn
9662       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9663       do iii=1,nderg
9664         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9665      &    AKAderg(1,1,iii))
9666       enddo
9667 cd      if (lprn) write (2,*) 'In kernel'
9668       do kkk=1,5
9669 cd        if (lprn) write (2,*) 'kkk=',kkk
9670         do lll=1,3
9671           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9672      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9673 cd          if (lprn) then
9674 cd            write (2,*) 'lll=',lll
9675 cd            write (2,*) 'iii=1'
9676 cd            do jjj=1,2
9677 cd              write (2,'(3(2f10.5),5x)')
9678 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9679 cd            enddo
9680 cd          endif
9681           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9682      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9683 cd          if (lprn) then
9684 cd            write (2,*) 'lll=',lll
9685 cd            write (2,*) 'iii=2'
9686 cd            do jjj=1,2
9687 cd              write (2,'(3(2f10.5),5x)')
9688 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9689 cd            enddo
9690 cd          endif
9691         enddo
9692       enddo
9693       return
9694       end
9695 C---------------------------------------------------------------------------
9696       double precision function eello4(i,j,k,l,jj,kk)
9697       implicit real*8 (a-h,o-z)
9698       include 'DIMENSIONS'
9699       include 'COMMON.IOUNITS'
9700       include 'COMMON.CHAIN'
9701       include 'COMMON.DERIV'
9702       include 'COMMON.INTERACT'
9703       include 'COMMON.CONTACTS'
9704       include 'COMMON.TORSION'
9705       include 'COMMON.VAR'
9706       include 'COMMON.GEO'
9707       double precision pizda(2,2),ggg1(3),ggg2(3)
9708 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9709 cd        eello4=0.0d0
9710 cd        return
9711 cd      endif
9712 cd      print *,'eello4:',i,j,k,l,jj,kk
9713 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9714 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9715 cold      eij=facont_hb(jj,i)
9716 cold      ekl=facont_hb(kk,k)
9717 cold      ekont=eij*ekl
9718       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9719 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9720       gcorr_loc(k-1)=gcorr_loc(k-1)
9721      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9722       if (l.eq.j+1) then
9723         gcorr_loc(l-1)=gcorr_loc(l-1)
9724      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9725       else
9726         gcorr_loc(j-1)=gcorr_loc(j-1)
9727      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9728       endif
9729       do iii=1,2
9730         do kkk=1,5
9731           do lll=1,3
9732             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9733      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9734 cd            derx(lll,kkk,iii)=0.0d0
9735           enddo
9736         enddo
9737       enddo
9738 cd      gcorr_loc(l-1)=0.0d0
9739 cd      gcorr_loc(j-1)=0.0d0
9740 cd      gcorr_loc(k-1)=0.0d0
9741 cd      eel4=1.0d0
9742 cd      write (iout,*)'Contacts have occurred for peptide groups',
9743 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9744 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9745       if (j.lt.nres-1) then
9746         j1=j+1
9747         j2=j-1
9748       else
9749         j1=j-1
9750         j2=j-2
9751       endif
9752       if (l.lt.nres-1) then
9753         l1=l+1
9754         l2=l-1
9755       else
9756         l1=l-1
9757         l2=l-2
9758       endif
9759       do ll=1,3
9760 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9761 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9762         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9763         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9764 cgrad        ghalf=0.5d0*ggg1(ll)
9765         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9766         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9767         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9768         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9769         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9770         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9771 cgrad        ghalf=0.5d0*ggg2(ll)
9772         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9773         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9774         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9775         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9776         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9777         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9778       enddo
9779 cgrad      do m=i+1,j-1
9780 cgrad        do ll=1,3
9781 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9782 cgrad        enddo
9783 cgrad      enddo
9784 cgrad      do m=k+1,l-1
9785 cgrad        do ll=1,3
9786 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9787 cgrad        enddo
9788 cgrad      enddo
9789 cgrad      do m=i+2,j2
9790 cgrad        do ll=1,3
9791 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9792 cgrad        enddo
9793 cgrad      enddo
9794 cgrad      do m=k+2,l2
9795 cgrad        do ll=1,3
9796 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9797 cgrad        enddo
9798 cgrad      enddo
9799 cd      do iii=1,nres-3
9800 cd        write (2,*) iii,gcorr_loc(iii)
9801 cd      enddo
9802       eello4=ekont*eel4
9803 cd      write (2,*) 'ekont',ekont
9804 cd      write (iout,*) 'eello4',ekont*eel4
9805       return
9806       end
9807 C---------------------------------------------------------------------------
9808       double precision function eello5(i,j,k,l,jj,kk)
9809       implicit real*8 (a-h,o-z)
9810       include 'DIMENSIONS'
9811       include 'COMMON.IOUNITS'
9812       include 'COMMON.CHAIN'
9813       include 'COMMON.DERIV'
9814       include 'COMMON.INTERACT'
9815       include 'COMMON.CONTACTS'
9816       include 'COMMON.TORSION'
9817       include 'COMMON.VAR'
9818       include 'COMMON.GEO'
9819       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9820       double precision ggg1(3),ggg2(3)
9821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9822 C                                                                              C
9823 C                            Parallel chains                                   C
9824 C                                                                              C
9825 C          o             o                   o             o                   C
9826 C         /l\           / \             \   / \           / \   /              C
9827 C        /   \         /   \             \ /   \         /   \ /               C
9828 C       j| o |l1       | o |              o| o |         | o |o                C
9829 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9830 C      \i/   \         /   \ /             /   \         /   \                 C
9831 C       o    k1             o                                                  C
9832 C         (I)          (II)                (III)          (IV)                 C
9833 C                                                                              C
9834 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9835 C                                                                              C
9836 C                            Antiparallel chains                               C
9837 C                                                                              C
9838 C          o             o                   o             o                   C
9839 C         /j\           / \             \   / \           / \   /              C
9840 C        /   \         /   \             \ /   \         /   \ /               C
9841 C      j1| o |l        | o |              o| o |         | o |o                C
9842 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9843 C      \i/   \         /   \ /             /   \         /   \                 C
9844 C       o     k1            o                                                  C
9845 C         (I)          (II)                (III)          (IV)                 C
9846 C                                                                              C
9847 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9848 C                                                                              C
9849 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9850 C                                                                              C
9851 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9852 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9853 cd        eello5=0.0d0
9854 cd        return
9855 cd      endif
9856 cd      write (iout,*)
9857 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9858 cd     &   ' and',k,l
9859       itk=itype2loc(itype(k))
9860       itl=itype2loc(itype(l))
9861       itj=itype2loc(itype(j))
9862       eello5_1=0.0d0
9863       eello5_2=0.0d0
9864       eello5_3=0.0d0
9865       eello5_4=0.0d0
9866 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9867 cd     &   eel5_3_num,eel5_4_num)
9868       do iii=1,2
9869         do kkk=1,5
9870           do lll=1,3
9871             derx(lll,kkk,iii)=0.0d0
9872           enddo
9873         enddo
9874       enddo
9875 cd      eij=facont_hb(jj,i)
9876 cd      ekl=facont_hb(kk,k)
9877 cd      ekont=eij*ekl
9878 cd      write (iout,*)'Contacts have occurred for peptide groups',
9879 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9880 cd      goto 1111
9881 C Contribution from the graph I.
9882 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9883 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9884       call transpose2(EUg(1,1,k),auxmat(1,1))
9885       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9886       vv(1)=pizda(1,1)-pizda(2,2)
9887       vv(2)=pizda(1,2)+pizda(2,1)
9888       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9889      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9890 C Explicit gradient in virtual-dihedral angles.
9891       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9892      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9893      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9894       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9895       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9896       vv(1)=pizda(1,1)-pizda(2,2)
9897       vv(2)=pizda(1,2)+pizda(2,1)
9898       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9899      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9900      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9901       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9902       vv(1)=pizda(1,1)-pizda(2,2)
9903       vv(2)=pizda(1,2)+pizda(2,1)
9904       if (l.eq.j+1) then
9905         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9906      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9907      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9908       else
9909         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9910      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9911      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9912       endif
9913 C Cartesian gradient
9914       do iii=1,2
9915         do kkk=1,5
9916           do lll=1,3
9917             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9918      &        pizda(1,1))
9919             vv(1)=pizda(1,1)-pizda(2,2)
9920             vv(2)=pizda(1,2)+pizda(2,1)
9921             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9922      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9923      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9924           enddo
9925         enddo
9926       enddo
9927 c      goto 1112
9928 c1111  continue
9929 C Contribution from graph II
9930       call transpose2(EE(1,1,k),auxmat(1,1))
9931       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9932       vv(1)=pizda(1,1)+pizda(2,2)
9933       vv(2)=pizda(2,1)-pizda(1,2)
9934       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9935      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9936 C Explicit gradient in virtual-dihedral angles.
9937       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9938      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9939       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9940       vv(1)=pizda(1,1)+pizda(2,2)
9941       vv(2)=pizda(2,1)-pizda(1,2)
9942       if (l.eq.j+1) then
9943         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9944      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9945      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9946       else
9947         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9948      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9949      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9950       endif
9951 C Cartesian gradient
9952       do iii=1,2
9953         do kkk=1,5
9954           do lll=1,3
9955             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9956      &        pizda(1,1))
9957             vv(1)=pizda(1,1)+pizda(2,2)
9958             vv(2)=pizda(2,1)-pizda(1,2)
9959             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9960      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9961      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9962           enddo
9963         enddo
9964       enddo
9965 cd      goto 1112
9966 cd1111  continue
9967       if (l.eq.j+1) then
9968 cd        goto 1110
9969 C Parallel orientation
9970 C Contribution from graph III
9971         call transpose2(EUg(1,1,l),auxmat(1,1))
9972         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9973         vv(1)=pizda(1,1)-pizda(2,2)
9974         vv(2)=pizda(1,2)+pizda(2,1)
9975         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9976      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9977 C Explicit gradient in virtual-dihedral angles.
9978         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9979      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9980      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9981         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9982         vv(1)=pizda(1,1)-pizda(2,2)
9983         vv(2)=pizda(1,2)+pizda(2,1)
9984         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9985      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9986      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9987         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9988         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9989         vv(1)=pizda(1,1)-pizda(2,2)
9990         vv(2)=pizda(1,2)+pizda(2,1)
9991         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9992      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9993      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9994 C Cartesian gradient
9995         do iii=1,2
9996           do kkk=1,5
9997             do lll=1,3
9998               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9999      &          pizda(1,1))
10000               vv(1)=pizda(1,1)-pizda(2,2)
10001               vv(2)=pizda(1,2)+pizda(2,1)
10002               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10003      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10004      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10005             enddo
10006           enddo
10007         enddo
10008 cd        goto 1112
10009 C Contribution from graph IV
10010 cd1110    continue
10011         call transpose2(EE(1,1,l),auxmat(1,1))
10012         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10013         vv(1)=pizda(1,1)+pizda(2,2)
10014         vv(2)=pizda(2,1)-pizda(1,2)
10015         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10016      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10017 C Explicit gradient in virtual-dihedral angles.
10018         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10019      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10020         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10021         vv(1)=pizda(1,1)+pizda(2,2)
10022         vv(2)=pizda(2,1)-pizda(1,2)
10023         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10024      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10025      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10026 C Cartesian gradient
10027         do iii=1,2
10028           do kkk=1,5
10029             do lll=1,3
10030               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10031      &          pizda(1,1))
10032               vv(1)=pizda(1,1)+pizda(2,2)
10033               vv(2)=pizda(2,1)-pizda(1,2)
10034               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10035      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10036      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10037             enddo
10038           enddo
10039         enddo
10040       else
10041 C Antiparallel orientation
10042 C Contribution from graph III
10043 c        goto 1110
10044         call transpose2(EUg(1,1,j),auxmat(1,1))
10045         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10046         vv(1)=pizda(1,1)-pizda(2,2)
10047         vv(2)=pizda(1,2)+pizda(2,1)
10048         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10049      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10050 C Explicit gradient in virtual-dihedral angles.
10051         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10052      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10053      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10054         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10055         vv(1)=pizda(1,1)-pizda(2,2)
10056         vv(2)=pizda(1,2)+pizda(2,1)
10057         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10058      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10059      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10060         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10061         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10062         vv(1)=pizda(1,1)-pizda(2,2)
10063         vv(2)=pizda(1,2)+pizda(2,1)
10064         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10065      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10066      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10067 C Cartesian gradient
10068         do iii=1,2
10069           do kkk=1,5
10070             do lll=1,3
10071               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10072      &          pizda(1,1))
10073               vv(1)=pizda(1,1)-pizda(2,2)
10074               vv(2)=pizda(1,2)+pizda(2,1)
10075               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10076      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10077      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10078             enddo
10079           enddo
10080         enddo
10081 cd        goto 1112
10082 C Contribution from graph IV
10083 1110    continue
10084         call transpose2(EE(1,1,j),auxmat(1,1))
10085         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10086         vv(1)=pizda(1,1)+pizda(2,2)
10087         vv(2)=pizda(2,1)-pizda(1,2)
10088         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10089      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10090 C Explicit gradient in virtual-dihedral angles.
10091         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10092      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10093         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10094         vv(1)=pizda(1,1)+pizda(2,2)
10095         vv(2)=pizda(2,1)-pizda(1,2)
10096         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10097      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10098      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10099 C Cartesian gradient
10100         do iii=1,2
10101           do kkk=1,5
10102             do lll=1,3
10103               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10104      &          pizda(1,1))
10105               vv(1)=pizda(1,1)+pizda(2,2)
10106               vv(2)=pizda(2,1)-pizda(1,2)
10107               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10108      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10109      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10110             enddo
10111           enddo
10112         enddo
10113       endif
10114 1112  continue
10115       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10116 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10117 cd        write (2,*) 'ijkl',i,j,k,l
10118 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10119 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10120 cd      endif
10121 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10122 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10123 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10124 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10125       if (j.lt.nres-1) then
10126         j1=j+1
10127         j2=j-1
10128       else
10129         j1=j-1
10130         j2=j-2
10131       endif
10132       if (l.lt.nres-1) then
10133         l1=l+1
10134         l2=l-1
10135       else
10136         l1=l-1
10137         l2=l-2
10138       endif
10139 cd      eij=1.0d0
10140 cd      ekl=1.0d0
10141 cd      ekont=1.0d0
10142 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10143 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10144 C        summed up outside the subrouine as for the other subroutines
10145 C        handling long-range interactions. The old code is commented out
10146 C        with "cgrad" to keep track of changes.
10147       do ll=1,3
10148 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10149 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10150         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10151         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10152 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10153 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10154 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10155 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10156 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10157 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10158 c     &   gradcorr5ij,
10159 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10160 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10161 cgrad        ghalf=0.5d0*ggg1(ll)
10162 cd        ghalf=0.0d0
10163         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10164         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10165         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10166         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10167         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10168         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10169 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10170 cgrad        ghalf=0.5d0*ggg2(ll)
10171 cd        ghalf=0.0d0
10172         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10173         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10174         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10175         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10176         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10177         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10178       enddo
10179 cd      goto 1112
10180 cgrad      do m=i+1,j-1
10181 cgrad        do ll=1,3
10182 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10183 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10184 cgrad        enddo
10185 cgrad      enddo
10186 cgrad      do m=k+1,l-1
10187 cgrad        do ll=1,3
10188 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10189 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10190 cgrad        enddo
10191 cgrad      enddo
10192 c1112  continue
10193 cgrad      do m=i+2,j2
10194 cgrad        do ll=1,3
10195 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10196 cgrad        enddo
10197 cgrad      enddo
10198 cgrad      do m=k+2,l2
10199 cgrad        do ll=1,3
10200 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10201 cgrad        enddo
10202 cgrad      enddo
10203 cd      do iii=1,nres-3
10204 cd        write (2,*) iii,g_corr5_loc(iii)
10205 cd      enddo
10206       eello5=ekont*eel5
10207 cd      write (2,*) 'ekont',ekont
10208 cd      write (iout,*) 'eello5',ekont*eel5
10209       return
10210       end
10211 c--------------------------------------------------------------------------
10212       double precision function eello6(i,j,k,l,jj,kk)
10213       implicit real*8 (a-h,o-z)
10214       include 'DIMENSIONS'
10215       include 'COMMON.IOUNITS'
10216       include 'COMMON.CHAIN'
10217       include 'COMMON.DERIV'
10218       include 'COMMON.INTERACT'
10219       include 'COMMON.CONTACTS'
10220       include 'COMMON.TORSION'
10221       include 'COMMON.VAR'
10222       include 'COMMON.GEO'
10223       include 'COMMON.FFIELD'
10224       double precision ggg1(3),ggg2(3)
10225 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10226 cd        eello6=0.0d0
10227 cd        return
10228 cd      endif
10229 cd      write (iout,*)
10230 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10231 cd     &   ' and',k,l
10232       eello6_1=0.0d0
10233       eello6_2=0.0d0
10234       eello6_3=0.0d0
10235       eello6_4=0.0d0
10236       eello6_5=0.0d0
10237       eello6_6=0.0d0
10238 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10239 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10240       do iii=1,2
10241         do kkk=1,5
10242           do lll=1,3
10243             derx(lll,kkk,iii)=0.0d0
10244           enddo
10245         enddo
10246       enddo
10247 cd      eij=facont_hb(jj,i)
10248 cd      ekl=facont_hb(kk,k)
10249 cd      ekont=eij*ekl
10250 cd      eij=1.0d0
10251 cd      ekl=1.0d0
10252 cd      ekont=1.0d0
10253       if (l.eq.j+1) then
10254         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10255         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10256         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10257         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10258         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10259         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10260       else
10261         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10262         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10263         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10264         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10265         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10266           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10267         else
10268           eello6_5=0.0d0
10269         endif
10270         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10271       endif
10272 C If turn contributions are considered, they will be handled separately.
10273       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10274 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10275 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10276 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10277 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10278 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10279 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10280 cd      goto 1112
10281       if (j.lt.nres-1) then
10282         j1=j+1
10283         j2=j-1
10284       else
10285         j1=j-1
10286         j2=j-2
10287       endif
10288       if (l.lt.nres-1) then
10289         l1=l+1
10290         l2=l-1
10291       else
10292         l1=l-1
10293         l2=l-2
10294       endif
10295       do ll=1,3
10296 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10297 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10298 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10299 cgrad        ghalf=0.5d0*ggg1(ll)
10300 cd        ghalf=0.0d0
10301         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10302         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10303         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10304         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10305         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10306         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10307         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10308         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10309 cgrad        ghalf=0.5d0*ggg2(ll)
10310 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10311 cd        ghalf=0.0d0
10312         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10313         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10314         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10315         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10316         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10317         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10318       enddo
10319 cd      goto 1112
10320 cgrad      do m=i+1,j-1
10321 cgrad        do ll=1,3
10322 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10323 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10324 cgrad        enddo
10325 cgrad      enddo
10326 cgrad      do m=k+1,l-1
10327 cgrad        do ll=1,3
10328 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10329 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10330 cgrad        enddo
10331 cgrad      enddo
10332 cgrad1112  continue
10333 cgrad      do m=i+2,j2
10334 cgrad        do ll=1,3
10335 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10336 cgrad        enddo
10337 cgrad      enddo
10338 cgrad      do m=k+2,l2
10339 cgrad        do ll=1,3
10340 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10341 cgrad        enddo
10342 cgrad      enddo
10343 cd      do iii=1,nres-3
10344 cd        write (2,*) iii,g_corr6_loc(iii)
10345 cd      enddo
10346       eello6=ekont*eel6
10347 cd      write (2,*) 'ekont',ekont
10348 cd      write (iout,*) 'eello6',ekont*eel6
10349       return
10350       end
10351 c--------------------------------------------------------------------------
10352       double precision function eello6_graph1(i,j,k,l,imat,swap)
10353       implicit real*8 (a-h,o-z)
10354       include 'DIMENSIONS'
10355       include 'COMMON.IOUNITS'
10356       include 'COMMON.CHAIN'
10357       include 'COMMON.DERIV'
10358       include 'COMMON.INTERACT'
10359       include 'COMMON.CONTACTS'
10360       include 'COMMON.TORSION'
10361       include 'COMMON.VAR'
10362       include 'COMMON.GEO'
10363       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10364       logical swap
10365       logical lprn
10366       common /kutas/ lprn
10367 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10368 C                                                                              C
10369 C      Parallel       Antiparallel                                             C
10370 C                                                                              C
10371 C          o             o                                                     C
10372 C         /l\           /j\                                                    C
10373 C        /   \         /   \                                                   C
10374 C       /| o |         | o |\                                                  C
10375 C     \ j|/k\|  /   \  |/k\|l /                                                C
10376 C      \ /   \ /     \ /   \ /                                                 C
10377 C       o     o       o     o                                                  C
10378 C       i             i                                                        C
10379 C                                                                              C
10380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10381       itk=itype2loc(itype(k))
10382       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10383       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10384       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10385       call transpose2(EUgC(1,1,k),auxmat(1,1))
10386       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10387       vv1(1)=pizda1(1,1)-pizda1(2,2)
10388       vv1(2)=pizda1(1,2)+pizda1(2,1)
10389       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10390       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10391       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10392       s5=scalar2(vv(1),Dtobr2(1,i))
10393 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10394       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10395       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10396      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10397      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10398      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10399      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10400      & +scalar2(vv(1),Dtobr2der(1,i)))
10401       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10402       vv1(1)=pizda1(1,1)-pizda1(2,2)
10403       vv1(2)=pizda1(1,2)+pizda1(2,1)
10404       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10405       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10406       if (l.eq.j+1) then
10407         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10408      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10409      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10410      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10411      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10412       else
10413         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10414      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10415      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10416      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10417      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10418       endif
10419       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10420       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10421       vv1(1)=pizda1(1,1)-pizda1(2,2)
10422       vv1(2)=pizda1(1,2)+pizda1(2,1)
10423       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10424      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10425      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10426      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10427       do iii=1,2
10428         if (swap) then
10429           ind=3-iii
10430         else
10431           ind=iii
10432         endif
10433         do kkk=1,5
10434           do lll=1,3
10435             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10436             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10437             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10438             call transpose2(EUgC(1,1,k),auxmat(1,1))
10439             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10440      &        pizda1(1,1))
10441             vv1(1)=pizda1(1,1)-pizda1(2,2)
10442             vv1(2)=pizda1(1,2)+pizda1(2,1)
10443             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10444             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10445      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10446             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10447      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10448             s5=scalar2(vv(1),Dtobr2(1,i))
10449             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10450           enddo
10451         enddo
10452       enddo
10453       return
10454       end
10455 c----------------------------------------------------------------------------
10456       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10457       implicit real*8 (a-h,o-z)
10458       include 'DIMENSIONS'
10459       include 'COMMON.IOUNITS'
10460       include 'COMMON.CHAIN'
10461       include 'COMMON.DERIV'
10462       include 'COMMON.INTERACT'
10463       include 'COMMON.CONTACTS'
10464       include 'COMMON.TORSION'
10465       include 'COMMON.VAR'
10466       include 'COMMON.GEO'
10467       logical swap
10468       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10469      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10470       logical lprn
10471       common /kutas/ lprn
10472 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10473 C                                                                              C
10474 C      Parallel       Antiparallel                                             C
10475 C                                                                              C
10476 C          o             o                                                     C
10477 C     \   /l\           /j\   /                                                C
10478 C      \ /   \         /   \ /                                                 C
10479 C       o| o |         | o |o                                                  C
10480 C     \ j|/k\|      \  |/k\|l                                                  C
10481 C      \ /   \       \ /   \                                                   C
10482 C       o             o                                                        C
10483 C       i             i                                                        C
10484 C                                                                              C
10485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10486 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10487 C AL 7/4/01 s1 would occur in the sixth-order moment,
10488 C           but not in a cluster cumulant
10489 #ifdef MOMENT
10490       s1=dip(1,jj,i)*dip(1,kk,k)
10491 #endif
10492       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10493       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10494       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10495       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10496       call transpose2(EUg(1,1,k),auxmat(1,1))
10497       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10498       vv(1)=pizda(1,1)-pizda(2,2)
10499       vv(2)=pizda(1,2)+pizda(2,1)
10500       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10501 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10502 #ifdef MOMENT
10503       eello6_graph2=-(s1+s2+s3+s4)
10504 #else
10505       eello6_graph2=-(s2+s3+s4)
10506 #endif
10507 c      eello6_graph2=-s3
10508 C Derivatives in gamma(i-1)
10509       if (i.gt.1) then
10510 #ifdef MOMENT
10511         s1=dipderg(1,jj,i)*dip(1,kk,k)
10512 #endif
10513         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10514         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10515         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10516         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10517 #ifdef MOMENT
10518         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10519 #else
10520         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10521 #endif
10522 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10523       endif
10524 C Derivatives in gamma(k-1)
10525 #ifdef MOMENT
10526       s1=dip(1,jj,i)*dipderg(1,kk,k)
10527 #endif
10528       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10529       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10530       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10531       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10532       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10533       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10534       vv(1)=pizda(1,1)-pizda(2,2)
10535       vv(2)=pizda(1,2)+pizda(2,1)
10536       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10537 #ifdef MOMENT
10538       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10539 #else
10540       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10541 #endif
10542 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10543 C Derivatives in gamma(j-1) or gamma(l-1)
10544       if (j.gt.1) then
10545 #ifdef MOMENT
10546         s1=dipderg(3,jj,i)*dip(1,kk,k)
10547 #endif
10548         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10549         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10550         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10551         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10552         vv(1)=pizda(1,1)-pizda(2,2)
10553         vv(2)=pizda(1,2)+pizda(2,1)
10554         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10555 #ifdef MOMENT
10556         if (swap) then
10557           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10558         else
10559           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10560         endif
10561 #endif
10562         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10563 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10564       endif
10565 C Derivatives in gamma(l-1) or gamma(j-1)
10566       if (l.gt.1) then
10567 #ifdef MOMENT
10568         s1=dip(1,jj,i)*dipderg(3,kk,k)
10569 #endif
10570         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10571         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10572         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10573         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10574         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10575         vv(1)=pizda(1,1)-pizda(2,2)
10576         vv(2)=pizda(1,2)+pizda(2,1)
10577         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10578 #ifdef MOMENT
10579         if (swap) then
10580           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10581         else
10582           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10583         endif
10584 #endif
10585         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10586 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10587       endif
10588 C Cartesian derivatives.
10589       if (lprn) then
10590         write (2,*) 'In eello6_graph2'
10591         do iii=1,2
10592           write (2,*) 'iii=',iii
10593           do kkk=1,5
10594             write (2,*) 'kkk=',kkk
10595             do jjj=1,2
10596               write (2,'(3(2f10.5),5x)')
10597      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10598             enddo
10599           enddo
10600         enddo
10601       endif
10602       do iii=1,2
10603         do kkk=1,5
10604           do lll=1,3
10605 #ifdef MOMENT
10606             if (iii.eq.1) then
10607               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10608             else
10609               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10610             endif
10611 #endif
10612             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10613      &        auxvec(1))
10614             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10615             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10616      &        auxvec(1))
10617             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10618             call transpose2(EUg(1,1,k),auxmat(1,1))
10619             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10620      &        pizda(1,1))
10621             vv(1)=pizda(1,1)-pizda(2,2)
10622             vv(2)=pizda(1,2)+pizda(2,1)
10623             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10624 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10625 #ifdef MOMENT
10626             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10627 #else
10628             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10629 #endif
10630             if (swap) then
10631               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10632             else
10633               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10634             endif
10635           enddo
10636         enddo
10637       enddo
10638       return
10639       end
10640 c----------------------------------------------------------------------------
10641       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10642       implicit real*8 (a-h,o-z)
10643       include 'DIMENSIONS'
10644       include 'COMMON.IOUNITS'
10645       include 'COMMON.CHAIN'
10646       include 'COMMON.DERIV'
10647       include 'COMMON.INTERACT'
10648       include 'COMMON.CONTACTS'
10649       include 'COMMON.TORSION'
10650       include 'COMMON.VAR'
10651       include 'COMMON.GEO'
10652       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10653       logical swap
10654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10655 C                                                                              C
10656 C      Parallel       Antiparallel                                             C
10657 C                                                                              C
10658 C          o             o                                                     C
10659 C         /l\   /   \   /j\                                                    C
10660 C        /   \ /     \ /   \                                                   C
10661 C       /| o |o       o| o |\                                                  C
10662 C       j|/k\|  /      |/k\|l /                                                C
10663 C        /   \ /       /   \ /                                                 C
10664 C       /     o       /     o                                                  C
10665 C       i             i                                                        C
10666 C                                                                              C
10667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10668 C
10669 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10670 C           energy moment and not to the cluster cumulant.
10671       iti=itortyp(itype(i))
10672       if (j.lt.nres-1) then
10673         itj1=itype2loc(itype(j+1))
10674       else
10675         itj1=nloctyp
10676       endif
10677       itk=itype2loc(itype(k))
10678       itk1=itype2loc(itype(k+1))
10679       if (l.lt.nres-1) then
10680         itl1=itype2loc(itype(l+1))
10681       else
10682         itl1=nloctyp
10683       endif
10684 #ifdef MOMENT
10685       s1=dip(4,jj,i)*dip(4,kk,k)
10686 #endif
10687       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10688       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10689       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10690       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10691       call transpose2(EE(1,1,k),auxmat(1,1))
10692       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10693       vv(1)=pizda(1,1)+pizda(2,2)
10694       vv(2)=pizda(2,1)-pizda(1,2)
10695       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10696 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10697 cd     & "sum",-(s2+s3+s4)
10698 #ifdef MOMENT
10699       eello6_graph3=-(s1+s2+s3+s4)
10700 #else
10701       eello6_graph3=-(s2+s3+s4)
10702 #endif
10703 c      eello6_graph3=-s4
10704 C Derivatives in gamma(k-1)
10705       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10706       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10707       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10708       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10709 C Derivatives in gamma(l-1)
10710       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10711       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10712       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10713       vv(1)=pizda(1,1)+pizda(2,2)
10714       vv(2)=pizda(2,1)-pizda(1,2)
10715       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10716       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10717 C Cartesian derivatives.
10718       do iii=1,2
10719         do kkk=1,5
10720           do lll=1,3
10721 #ifdef MOMENT
10722             if (iii.eq.1) then
10723               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10724             else
10725               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10726             endif
10727 #endif
10728             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10729      &        auxvec(1))
10730             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10731             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10732      &        auxvec(1))
10733             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10734             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10735      &        pizda(1,1))
10736             vv(1)=pizda(1,1)+pizda(2,2)
10737             vv(2)=pizda(2,1)-pizda(1,2)
10738             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10739 #ifdef MOMENT
10740             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10741 #else
10742             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10743 #endif
10744             if (swap) then
10745               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10746             else
10747               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10748             endif
10749 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10750           enddo
10751         enddo
10752       enddo
10753       return
10754       end
10755 c----------------------------------------------------------------------------
10756       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10757       implicit real*8 (a-h,o-z)
10758       include 'DIMENSIONS'
10759       include 'COMMON.IOUNITS'
10760       include 'COMMON.CHAIN'
10761       include 'COMMON.DERIV'
10762       include 'COMMON.INTERACT'
10763       include 'COMMON.CONTACTS'
10764       include 'COMMON.TORSION'
10765       include 'COMMON.VAR'
10766       include 'COMMON.GEO'
10767       include 'COMMON.FFIELD'
10768       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10769      & auxvec1(2),auxmat1(2,2)
10770       logical swap
10771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10772 C                                                                              C
10773 C      Parallel       Antiparallel                                             C
10774 C                                                                              C
10775 C          o             o                                                     C
10776 C         /l\   /   \   /j\                                                    C
10777 C        /   \ /     \ /   \                                                   C
10778 C       /| o |o       o| o |\                                                  C
10779 C     \ j|/k\|      \  |/k\|l                                                  C
10780 C      \ /   \       \ /   \                                                   C
10781 C       o     \       o     \                                                  C
10782 C       i             i                                                        C
10783 C                                                                              C
10784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10785 C
10786 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10787 C           energy moment and not to the cluster cumulant.
10788 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10789       iti=itype2loc(itype(i))
10790       itj=itype2loc(itype(j))
10791       if (j.lt.nres-1) then
10792         itj1=itype2loc(itype(j+1))
10793       else
10794         itj1=nloctyp
10795       endif
10796       itk=itype2loc(itype(k))
10797       if (k.lt.nres-1) then
10798         itk1=itype2loc(itype(k+1))
10799       else
10800         itk1=nloctyp
10801       endif
10802       itl=itype2loc(itype(l))
10803       if (l.lt.nres-1) then
10804         itl1=itype2loc(itype(l+1))
10805       else
10806         itl1=nloctyp
10807       endif
10808 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10809 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10810 cd     & ' itl',itl,' itl1',itl1
10811 #ifdef MOMENT
10812       if (imat.eq.1) then
10813         s1=dip(3,jj,i)*dip(3,kk,k)
10814       else
10815         s1=dip(2,jj,j)*dip(2,kk,l)
10816       endif
10817 #endif
10818       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10819       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10820       if (j.eq.l+1) then
10821         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10822         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10823       else
10824         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10825         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10826       endif
10827       call transpose2(EUg(1,1,k),auxmat(1,1))
10828       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10829       vv(1)=pizda(1,1)-pizda(2,2)
10830       vv(2)=pizda(2,1)+pizda(1,2)
10831       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10832 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10833 #ifdef MOMENT
10834       eello6_graph4=-(s1+s2+s3+s4)
10835 #else
10836       eello6_graph4=-(s2+s3+s4)
10837 #endif
10838 C Derivatives in gamma(i-1)
10839       if (i.gt.1) then
10840 #ifdef MOMENT
10841         if (imat.eq.1) then
10842           s1=dipderg(2,jj,i)*dip(3,kk,k)
10843         else
10844           s1=dipderg(4,jj,j)*dip(2,kk,l)
10845         endif
10846 #endif
10847         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10848         if (j.eq.l+1) then
10849           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10850           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10851         else
10852           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10853           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10854         endif
10855         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10856         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10857 cd          write (2,*) 'turn6 derivatives'
10858 #ifdef MOMENT
10859           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10860 #else
10861           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10862 #endif
10863         else
10864 #ifdef MOMENT
10865           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10866 #else
10867           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10868 #endif
10869         endif
10870       endif
10871 C Derivatives in gamma(k-1)
10872 #ifdef MOMENT
10873       if (imat.eq.1) then
10874         s1=dip(3,jj,i)*dipderg(2,kk,k)
10875       else
10876         s1=dip(2,jj,j)*dipderg(4,kk,l)
10877       endif
10878 #endif
10879       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10880       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10881       if (j.eq.l+1) then
10882         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10883         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10884       else
10885         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10886         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10887       endif
10888       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10889       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10890       vv(1)=pizda(1,1)-pizda(2,2)
10891       vv(2)=pizda(2,1)+pizda(1,2)
10892       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10893       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10894 #ifdef MOMENT
10895         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10896 #else
10897         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10898 #endif
10899       else
10900 #ifdef MOMENT
10901         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10902 #else
10903         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10904 #endif
10905       endif
10906 C Derivatives in gamma(j-1) or gamma(l-1)
10907       if (l.eq.j+1 .and. l.gt.1) then
10908         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10909         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10910         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10911         vv(1)=pizda(1,1)-pizda(2,2)
10912         vv(2)=pizda(2,1)+pizda(1,2)
10913         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10914         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10915       else if (j.gt.1) then
10916         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10917         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10918         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10919         vv(1)=pizda(1,1)-pizda(2,2)
10920         vv(2)=pizda(2,1)+pizda(1,2)
10921         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10922         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10923           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10924         else
10925           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10926         endif
10927       endif
10928 C Cartesian derivatives.
10929       do iii=1,2
10930         do kkk=1,5
10931           do lll=1,3
10932 #ifdef MOMENT
10933             if (iii.eq.1) then
10934               if (imat.eq.1) then
10935                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10936               else
10937                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10938               endif
10939             else
10940               if (imat.eq.1) then
10941                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10942               else
10943                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10944               endif
10945             endif
10946 #endif
10947             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10948      &        auxvec(1))
10949             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10950             if (j.eq.l+1) then
10951               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10952      &          b1(1,j+1),auxvec(1))
10953               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10954             else
10955               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10956      &          b1(1,l+1),auxvec(1))
10957               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10958             endif
10959             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10960      &        pizda(1,1))
10961             vv(1)=pizda(1,1)-pizda(2,2)
10962             vv(2)=pizda(2,1)+pizda(1,2)
10963             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10964             if (swap) then
10965               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10966 #ifdef MOMENT
10967                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10968      &             -(s1+s2+s4)
10969 #else
10970                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10971      &             -(s2+s4)
10972 #endif
10973                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10974               else
10975 #ifdef MOMENT
10976                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10977 #else
10978                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10979 #endif
10980                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10981               endif
10982             else
10983 #ifdef MOMENT
10984               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10985 #else
10986               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10987 #endif
10988               if (l.eq.j+1) then
10989                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10990               else
10991                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10992               endif
10993             endif
10994           enddo
10995         enddo
10996       enddo
10997       return
10998       end
10999 c----------------------------------------------------------------------------
11000       double precision function eello_turn6(i,jj,kk)
11001       implicit real*8 (a-h,o-z)
11002       include 'DIMENSIONS'
11003       include 'COMMON.IOUNITS'
11004       include 'COMMON.CHAIN'
11005       include 'COMMON.DERIV'
11006       include 'COMMON.INTERACT'
11007       include 'COMMON.CONTACTS'
11008       include 'COMMON.TORSION'
11009       include 'COMMON.VAR'
11010       include 'COMMON.GEO'
11011       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11012      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11013      &  ggg1(3),ggg2(3)
11014       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11015      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11016 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11017 C           the respective energy moment and not to the cluster cumulant.
11018       s1=0.0d0
11019       s8=0.0d0
11020       s13=0.0d0
11021 c
11022       eello_turn6=0.0d0
11023       j=i+4
11024       k=i+1
11025       l=i+3
11026       iti=itype2loc(itype(i))
11027       itk=itype2loc(itype(k))
11028       itk1=itype2loc(itype(k+1))
11029       itl=itype2loc(itype(l))
11030       itj=itype2loc(itype(j))
11031 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11032 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11033 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11034 cd        eello6=0.0d0
11035 cd        return
11036 cd      endif
11037 cd      write (iout,*)
11038 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11039 cd     &   ' and',k,l
11040 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11041       do iii=1,2
11042         do kkk=1,5
11043           do lll=1,3
11044             derx_turn(lll,kkk,iii)=0.0d0
11045           enddo
11046         enddo
11047       enddo
11048 cd      eij=1.0d0
11049 cd      ekl=1.0d0
11050 cd      ekont=1.0d0
11051       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11052 cd      eello6_5=0.0d0
11053 cd      write (2,*) 'eello6_5',eello6_5
11054 #ifdef MOMENT
11055       call transpose2(AEA(1,1,1),auxmat(1,1))
11056       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11057       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11058       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11059 #endif
11060       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11061       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11062       s2 = scalar2(b1(1,k),vtemp1(1))
11063 #ifdef MOMENT
11064       call transpose2(AEA(1,1,2),atemp(1,1))
11065       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11066       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11067       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11068 #endif
11069       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11070       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11071       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11072 #ifdef MOMENT
11073       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11074       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11075       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11076       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11077       ss13 = scalar2(b1(1,k),vtemp4(1))
11078       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11079 #endif
11080 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11081 c      s1=0.0d0
11082 c      s2=0.0d0
11083 c      s8=0.0d0
11084 c      s12=0.0d0
11085 c      s13=0.0d0
11086       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11087 C Derivatives in gamma(i+2)
11088       s1d =0.0d0
11089       s8d =0.0d0
11090 #ifdef MOMENT
11091       call transpose2(AEA(1,1,1),auxmatd(1,1))
11092       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11093       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11094       call transpose2(AEAderg(1,1,2),atempd(1,1))
11095       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11096       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11097 #endif
11098       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11099       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11100       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11101 c      s1d=0.0d0
11102 c      s2d=0.0d0
11103 c      s8d=0.0d0
11104 c      s12d=0.0d0
11105 c      s13d=0.0d0
11106       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11107 C Derivatives in gamma(i+3)
11108 #ifdef MOMENT
11109       call transpose2(AEA(1,1,1),auxmatd(1,1))
11110       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11111       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11112       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11113 #endif
11114       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11115       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11116       s2d = scalar2(b1(1,k),vtemp1d(1))
11117 #ifdef MOMENT
11118       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11119       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11120 #endif
11121       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11122 #ifdef MOMENT
11123       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11124       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11125       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11126 #endif
11127 c      s1d=0.0d0
11128 c      s2d=0.0d0
11129 c      s8d=0.0d0
11130 c      s12d=0.0d0
11131 c      s13d=0.0d0
11132 #ifdef MOMENT
11133       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11134      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11135 #else
11136       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11137      &               -0.5d0*ekont*(s2d+s12d)
11138 #endif
11139 C Derivatives in gamma(i+4)
11140       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11141       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11142       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11143 #ifdef MOMENT
11144       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11145       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11146       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11147 #endif
11148 c      s1d=0.0d0
11149 c      s2d=0.0d0
11150 c      s8d=0.0d0
11151 C      s12d=0.0d0
11152 c      s13d=0.0d0
11153 #ifdef MOMENT
11154       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11155 #else
11156       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11157 #endif
11158 C Derivatives in gamma(i+5)
11159 #ifdef MOMENT
11160       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11161       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11162       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11163 #endif
11164       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11165       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11166       s2d = scalar2(b1(1,k),vtemp1d(1))
11167 #ifdef MOMENT
11168       call transpose2(AEA(1,1,2),atempd(1,1))
11169       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11170       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11171 #endif
11172       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11173       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11174 #ifdef MOMENT
11175       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11176       ss13d = scalar2(b1(1,k),vtemp4d(1))
11177       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11178 #endif
11179 c      s1d=0.0d0
11180 c      s2d=0.0d0
11181 c      s8d=0.0d0
11182 c      s12d=0.0d0
11183 c      s13d=0.0d0
11184 #ifdef MOMENT
11185       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11186      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11187 #else
11188       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11189      &               -0.5d0*ekont*(s2d+s12d)
11190 #endif
11191 C Cartesian derivatives
11192       do iii=1,2
11193         do kkk=1,5
11194           do lll=1,3
11195 #ifdef MOMENT
11196             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11197             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11198             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11199 #endif
11200             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11201             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11202      &          vtemp1d(1))
11203             s2d = scalar2(b1(1,k),vtemp1d(1))
11204 #ifdef MOMENT
11205             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11206             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11207             s8d = -(atempd(1,1)+atempd(2,2))*
11208      &           scalar2(cc(1,1,itl),vtemp2(1))
11209 #endif
11210             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11211      &           auxmatd(1,1))
11212             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11213             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11214 c      s1d=0.0d0
11215 c      s2d=0.0d0
11216 c      s8d=0.0d0
11217 c      s12d=0.0d0
11218 c      s13d=0.0d0
11219 #ifdef MOMENT
11220             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11221      &        - 0.5d0*(s1d+s2d)
11222 #else
11223             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11224      &        - 0.5d0*s2d
11225 #endif
11226 #ifdef MOMENT
11227             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11228      &        - 0.5d0*(s8d+s12d)
11229 #else
11230             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11231      &        - 0.5d0*s12d
11232 #endif
11233           enddo
11234         enddo
11235       enddo
11236 #ifdef MOMENT
11237       do kkk=1,5
11238         do lll=1,3
11239           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11240      &      achuj_tempd(1,1))
11241           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11242           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11243           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11244           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11245           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11246      &      vtemp4d(1))
11247           ss13d = scalar2(b1(1,k),vtemp4d(1))
11248           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11249           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11250         enddo
11251       enddo
11252 #endif
11253 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11254 cd     &  16*eel_turn6_num
11255 cd      goto 1112
11256       if (j.lt.nres-1) then
11257         j1=j+1
11258         j2=j-1
11259       else
11260         j1=j-1
11261         j2=j-2
11262       endif
11263       if (l.lt.nres-1) then
11264         l1=l+1
11265         l2=l-1
11266       else
11267         l1=l-1
11268         l2=l-2
11269       endif
11270       do ll=1,3
11271 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11272 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11273 cgrad        ghalf=0.5d0*ggg1(ll)
11274 cd        ghalf=0.0d0
11275         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11276         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11277         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11278      &    +ekont*derx_turn(ll,2,1)
11279         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11280         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11281      &    +ekont*derx_turn(ll,4,1)
11282         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11283         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11284         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11285 cgrad        ghalf=0.5d0*ggg2(ll)
11286 cd        ghalf=0.0d0
11287         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11288      &    +ekont*derx_turn(ll,2,2)
11289         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11290         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11291      &    +ekont*derx_turn(ll,4,2)
11292         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11293         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11294         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11295       enddo
11296 cd      goto 1112
11297 cgrad      do m=i+1,j-1
11298 cgrad        do ll=1,3
11299 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11300 cgrad        enddo
11301 cgrad      enddo
11302 cgrad      do m=k+1,l-1
11303 cgrad        do ll=1,3
11304 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11305 cgrad        enddo
11306 cgrad      enddo
11307 cgrad1112  continue
11308 cgrad      do m=i+2,j2
11309 cgrad        do ll=1,3
11310 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11311 cgrad        enddo
11312 cgrad      enddo
11313 cgrad      do m=k+2,l2
11314 cgrad        do ll=1,3
11315 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11316 cgrad        enddo
11317 cgrad      enddo
11318 cd      do iii=1,nres-3
11319 cd        write (2,*) iii,g_corr6_loc(iii)
11320 cd      enddo
11321       eello_turn6=ekont*eel_turn6
11322 cd      write (2,*) 'ekont',ekont
11323 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11324       return
11325       end
11326
11327 C-----------------------------------------------------------------------------
11328       double precision function scalar(u,v)
11329 !DIR$ INLINEALWAYS scalar
11330 #ifndef OSF
11331 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11332 #endif
11333       implicit none
11334       double precision u(3),v(3)
11335 cd      double precision sc
11336 cd      integer i
11337 cd      sc=0.0d0
11338 cd      do i=1,3
11339 cd        sc=sc+u(i)*v(i)
11340 cd      enddo
11341 cd      scalar=sc
11342
11343       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11344       return
11345       end
11346 crc-------------------------------------------------
11347       SUBROUTINE MATVEC2(A1,V1,V2)
11348 !DIR$ INLINEALWAYS MATVEC2
11349 #ifndef OSF
11350 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11351 #endif
11352       implicit real*8 (a-h,o-z)
11353       include 'DIMENSIONS'
11354       DIMENSION A1(2,2),V1(2),V2(2)
11355 c      DO 1 I=1,2
11356 c        VI=0.0
11357 c        DO 3 K=1,2
11358 c    3     VI=VI+A1(I,K)*V1(K)
11359 c        Vaux(I)=VI
11360 c    1 CONTINUE
11361
11362       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11363       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11364
11365       v2(1)=vaux1
11366       v2(2)=vaux2
11367       END
11368 C---------------------------------------
11369       SUBROUTINE MATMAT2(A1,A2,A3)
11370 #ifndef OSF
11371 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11372 #endif
11373       implicit real*8 (a-h,o-z)
11374       include 'DIMENSIONS'
11375       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11376 c      DIMENSION AI3(2,2)
11377 c        DO  J=1,2
11378 c          A3IJ=0.0
11379 c          DO K=1,2
11380 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11381 c          enddo
11382 c          A3(I,J)=A3IJ
11383 c       enddo
11384 c      enddo
11385
11386       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11387       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11388       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11389       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11390
11391       A3(1,1)=AI3_11
11392       A3(2,1)=AI3_21
11393       A3(1,2)=AI3_12
11394       A3(2,2)=AI3_22
11395       END
11396
11397 c-------------------------------------------------------------------------
11398       double precision function scalar2(u,v)
11399 !DIR$ INLINEALWAYS scalar2
11400       implicit none
11401       double precision u(2),v(2)
11402       double precision sc
11403       integer i
11404       scalar2=u(1)*v(1)+u(2)*v(2)
11405       return
11406       end
11407
11408 C-----------------------------------------------------------------------------
11409
11410       subroutine transpose2(a,at)
11411 !DIR$ INLINEALWAYS transpose2
11412 #ifndef OSF
11413 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11414 #endif
11415       implicit none
11416       double precision a(2,2),at(2,2)
11417       at(1,1)=a(1,1)
11418       at(1,2)=a(2,1)
11419       at(2,1)=a(1,2)
11420       at(2,2)=a(2,2)
11421       return
11422       end
11423 c--------------------------------------------------------------------------
11424       subroutine transpose(n,a,at)
11425       implicit none
11426       integer n,i,j
11427       double precision a(n,n),at(n,n)
11428       do i=1,n
11429         do j=1,n
11430           at(j,i)=a(i,j)
11431         enddo
11432       enddo
11433       return
11434       end
11435 C---------------------------------------------------------------------------
11436       subroutine prodmat3(a1,a2,kk,transp,prod)
11437 !DIR$ INLINEALWAYS prodmat3
11438 #ifndef OSF
11439 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11440 #endif
11441       implicit none
11442       integer i,j
11443       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11444       logical transp
11445 crc      double precision auxmat(2,2),prod_(2,2)
11446
11447       if (transp) then
11448 crc        call transpose2(kk(1,1),auxmat(1,1))
11449 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11450 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11451
11452            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11453      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11454            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11455      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11456            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11457      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11458            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11459      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11460
11461       else
11462 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11463 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11464
11465            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11466      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11467            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11468      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11469            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11470      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11471            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11472      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11473
11474       endif
11475 c      call transpose2(a2(1,1),a2t(1,1))
11476
11477 crc      print *,transp
11478 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11479 crc      print *,((prod(i,j),i=1,2),j=1,2)
11480
11481       return
11482       end
11483 CCC----------------------------------------------
11484       subroutine Eliptransfer(eliptran)
11485       implicit real*8 (a-h,o-z)
11486       include 'DIMENSIONS'
11487       include 'COMMON.GEO'
11488       include 'COMMON.VAR'
11489       include 'COMMON.LOCAL'
11490       include 'COMMON.CHAIN'
11491       include 'COMMON.DERIV'
11492       include 'COMMON.NAMES'
11493       include 'COMMON.INTERACT'
11494       include 'COMMON.IOUNITS'
11495       include 'COMMON.CALC'
11496       include 'COMMON.CONTROL'
11497       include 'COMMON.SPLITELE'
11498       include 'COMMON.SBRIDGE'
11499 C this is done by Adasko
11500 C      print *,"wchodze"
11501 C structure of box:
11502 C      water
11503 C--bordliptop-- buffore starts
11504 C--bufliptop--- here true lipid starts
11505 C      lipid
11506 C--buflipbot--- lipid ends buffore starts
11507 C--bordlipbot--buffore ends
11508       eliptran=0.0
11509       do i=ilip_start,ilip_end
11510 C       do i=1,1
11511         if (itype(i).eq.ntyp1) cycle
11512
11513         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11514         if (positi.le.0.0) positi=positi+boxzsize
11515 C        print *,i
11516 C first for peptide groups
11517 c for each residue check if it is in lipid or lipid water border area
11518        if ((positi.gt.bordlipbot)
11519      &.and.(positi.lt.bordliptop)) then
11520 C the energy transfer exist
11521         if (positi.lt.buflipbot) then
11522 C what fraction I am in
11523          fracinbuf=1.0d0-
11524      &        ((positi-bordlipbot)/lipbufthick)
11525 C lipbufthick is thickenes of lipid buffore
11526          sslip=sscalelip(fracinbuf)
11527          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11528          eliptran=eliptran+sslip*pepliptran
11529          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11530          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11531 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11532
11533 C        print *,"doing sccale for lower part"
11534 C         print *,i,sslip,fracinbuf,ssgradlip
11535         elseif (positi.gt.bufliptop) then
11536          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11537          sslip=sscalelip(fracinbuf)
11538          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11539          eliptran=eliptran+sslip*pepliptran
11540          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11541          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11542 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11543 C          print *, "doing sscalefor top part"
11544 C         print *,i,sslip,fracinbuf,ssgradlip
11545         else
11546          eliptran=eliptran+pepliptran
11547 C         print *,"I am in true lipid"
11548         endif
11549 C       else
11550 C       eliptran=elpitran+0.0 ! I am in water
11551        endif
11552        enddo
11553 C       print *, "nic nie bylo w lipidzie?"
11554 C now multiply all by the peptide group transfer factor
11555 C       eliptran=eliptran*pepliptran
11556 C now the same for side chains
11557 CV       do i=1,1
11558        do i=ilip_start,ilip_end
11559         if (itype(i).eq.ntyp1) cycle
11560         positi=(mod(c(3,i+nres),boxzsize))
11561         if (positi.le.0) positi=positi+boxzsize
11562 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11563 c for each residue check if it is in lipid or lipid water border area
11564 C       respos=mod(c(3,i+nres),boxzsize)
11565 C       print *,positi,bordlipbot,buflipbot
11566        if ((positi.gt.bordlipbot)
11567      & .and.(positi.lt.bordliptop)) then
11568 C the energy transfer exist
11569         if (positi.lt.buflipbot) then
11570          fracinbuf=1.0d0-
11571      &     ((positi-bordlipbot)/lipbufthick)
11572 C lipbufthick is thickenes of lipid buffore
11573          sslip=sscalelip(fracinbuf)
11574          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11575          eliptran=eliptran+sslip*liptranene(itype(i))
11576          gliptranx(3,i)=gliptranx(3,i)
11577      &+ssgradlip*liptranene(itype(i))
11578          gliptranc(3,i-1)= gliptranc(3,i-1)
11579      &+ssgradlip*liptranene(itype(i))
11580 C         print *,"doing sccale for lower part"
11581         elseif (positi.gt.bufliptop) then
11582          fracinbuf=1.0d0-
11583      &((bordliptop-positi)/lipbufthick)
11584          sslip=sscalelip(fracinbuf)
11585          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11586          eliptran=eliptran+sslip*liptranene(itype(i))
11587          gliptranx(3,i)=gliptranx(3,i)
11588      &+ssgradlip*liptranene(itype(i))
11589          gliptranc(3,i-1)= gliptranc(3,i-1)
11590      &+ssgradlip*liptranene(itype(i))
11591 C          print *, "doing sscalefor top part",sslip,fracinbuf
11592         else
11593          eliptran=eliptran+liptranene(itype(i))
11594 C         print *,"I am in true lipid"
11595         endif
11596         endif ! if in lipid or buffor
11597 C       else
11598 C       eliptran=elpitran+0.0 ! I am in water
11599        enddo
11600        return
11601        end
11602 C---------------------------------------------------------
11603 C AFM soubroutine for constant force
11604        subroutine AFMforce(Eafmforce)
11605        implicit real*8 (a-h,o-z)
11606       include 'DIMENSIONS'
11607       include 'COMMON.GEO'
11608       include 'COMMON.VAR'
11609       include 'COMMON.LOCAL'
11610       include 'COMMON.CHAIN'
11611       include 'COMMON.DERIV'
11612       include 'COMMON.NAMES'
11613       include 'COMMON.INTERACT'
11614       include 'COMMON.IOUNITS'
11615       include 'COMMON.CALC'
11616       include 'COMMON.CONTROL'
11617       include 'COMMON.SPLITELE'
11618       include 'COMMON.SBRIDGE'
11619       real*8 diffafm(3)
11620       dist=0.0d0
11621       Eafmforce=0.0d0
11622       do i=1,3
11623       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11624       dist=dist+diffafm(i)**2
11625       enddo
11626       dist=dsqrt(dist)
11627       Eafmforce=-forceAFMconst*(dist-distafminit)
11628       do i=1,3
11629       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11630       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11631       enddo
11632 C      print *,'AFM',Eafmforce
11633       return
11634       end
11635 C---------------------------------------------------------
11636 C AFM subroutine with pseudoconstant velocity
11637        subroutine AFMvel(Eafmforce)
11638        implicit real*8 (a-h,o-z)
11639       include 'DIMENSIONS'
11640       include 'COMMON.GEO'
11641       include 'COMMON.VAR'
11642       include 'COMMON.LOCAL'
11643       include 'COMMON.CHAIN'
11644       include 'COMMON.DERIV'
11645       include 'COMMON.NAMES'
11646       include 'COMMON.INTERACT'
11647       include 'COMMON.IOUNITS'
11648       include 'COMMON.CALC'
11649       include 'COMMON.CONTROL'
11650       include 'COMMON.SPLITELE'
11651       include 'COMMON.SBRIDGE'
11652       real*8 diffafm(3)
11653 C Only for check grad COMMENT if not used for checkgrad
11654 C      totT=3.0d0
11655 C--------------------------------------------------------
11656 C      print *,"wchodze"
11657       dist=0.0d0
11658       Eafmforce=0.0d0
11659       do i=1,3
11660       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11661       dist=dist+diffafm(i)**2
11662       enddo
11663       dist=dsqrt(dist)
11664       Eafmforce=0.5d0*forceAFMconst
11665      & *(distafminit+totTafm*velAFMconst-dist)**2
11666 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11667       do i=1,3
11668       gradafm(i,afmend-1)=-forceAFMconst*
11669      &(distafminit+totTafm*velAFMconst-dist)
11670      &*diffafm(i)/dist
11671       gradafm(i,afmbeg-1)=forceAFMconst*
11672      &(distafminit+totTafm*velAFMconst-dist)
11673      &*diffafm(i)/dist
11674       enddo
11675 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11676       return
11677       end
11678 C-----------------------------------------------------------
11679 C first for shielding is setting of function of side-chains
11680        subroutine set_shield_fac
11681       implicit real*8 (a-h,o-z)
11682       include 'DIMENSIONS'
11683       include 'COMMON.CHAIN'
11684       include 'COMMON.DERIV'
11685       include 'COMMON.IOUNITS'
11686       include 'COMMON.SHIELD'
11687       include 'COMMON.INTERACT'
11688 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11689       double precision div77_81/0.974996043d0/,
11690      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11691
11692 C the vector between center of side_chain and peptide group
11693        double precision pep_side(3),long,side_calf(3),
11694      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11695      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11696 C the line belowe needs to be changed for FGPROC>1
11697       do i=1,nres-1
11698       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11699       ishield_list(i)=0
11700 Cif there two consequtive dummy atoms there is no peptide group between them
11701 C the line below has to be changed for FGPROC>1
11702       VolumeTotal=0.0
11703       do k=1,nres
11704        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11705        dist_pep_side=0.0
11706        dist_side_calf=0.0
11707        do j=1,3
11708 C first lets set vector conecting the ithe side-chain with kth side-chain
11709       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11710 C      pep_side(j)=2.0d0
11711 C and vector conecting the side-chain with its proper calfa
11712       side_calf(j)=c(j,k+nres)-c(j,k)
11713 C      side_calf(j)=2.0d0
11714       pept_group(j)=c(j,i)-c(j,i+1)
11715 C lets have their lenght
11716       dist_pep_side=pep_side(j)**2+dist_pep_side
11717       dist_side_calf=dist_side_calf+side_calf(j)**2
11718       dist_pept_group=dist_pept_group+pept_group(j)**2
11719       enddo
11720        dist_pep_side=dsqrt(dist_pep_side)
11721        dist_pept_group=dsqrt(dist_pept_group)
11722        dist_side_calf=dsqrt(dist_side_calf)
11723       do j=1,3
11724         pep_side_norm(j)=pep_side(j)/dist_pep_side
11725         side_calf_norm(j)=dist_side_calf
11726       enddo
11727 C now sscale fraction
11728        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11729 C       print *,buff_shield,"buff"
11730 C now sscale
11731         if (sh_frac_dist.le.0.0) cycle
11732 C If we reach here it means that this side chain reaches the shielding sphere
11733 C Lets add him to the list for gradient
11734         ishield_list(i)=ishield_list(i)+1
11735 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11736 C this list is essential otherwise problem would be O3
11737         shield_list(ishield_list(i),i)=k
11738 C Lets have the sscale value
11739         if (sh_frac_dist.gt.1.0) then
11740          scale_fac_dist=1.0d0
11741          do j=1,3
11742          sh_frac_dist_grad(j)=0.0d0
11743          enddo
11744         else
11745          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11746      &                   *(2.0*sh_frac_dist-3.0d0)
11747          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11748      &                  /dist_pep_side/buff_shield*0.5
11749 C remember for the final gradient multiply sh_frac_dist_grad(j)
11750 C for side_chain by factor -2 !
11751          do j=1,3
11752          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11753 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11754 C     &                    sh_frac_dist_grad(j)
11755          enddo
11756         endif
11757 C        if ((i.eq.3).and.(k.eq.2)) then
11758 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11759 C     & ,"TU"
11760 C        endif
11761
11762 C this is what is now we have the distance scaling now volume...
11763       short=short_r_sidechain(itype(k))
11764       long=long_r_sidechain(itype(k))
11765       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11766 C now costhet_grad
11767 C       costhet=0.0d0
11768        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11769 C       costhet_fac=0.0d0
11770        do j=1,3
11771          costhet_grad(j)=costhet_fac*pep_side(j)
11772        enddo
11773 C remember for the final gradient multiply costhet_grad(j)
11774 C for side_chain by factor -2 !
11775 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11776 C pep_side0pept_group is vector multiplication
11777       pep_side0pept_group=0.0
11778       do j=1,3
11779       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11780       enddo
11781       cosalfa=(pep_side0pept_group/
11782      & (dist_pep_side*dist_side_calf))
11783       fac_alfa_sin=1.0-cosalfa**2
11784       fac_alfa_sin=dsqrt(fac_alfa_sin)
11785       rkprim=fac_alfa_sin*(long-short)+short
11786 C now costhet_grad
11787        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11788        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11789
11790        do j=1,3
11791          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11792      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11793      &*(long-short)/fac_alfa_sin*cosalfa/
11794      &((dist_pep_side*dist_side_calf))*
11795      &((side_calf(j))-cosalfa*
11796      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11797
11798         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11799      &*(long-short)/fac_alfa_sin*cosalfa
11800      &/((dist_pep_side*dist_side_calf))*
11801      &(pep_side(j)-
11802      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11803        enddo
11804
11805       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11806      &                    /VSolvSphere_div
11807      &                    *wshield
11808 C now the gradient...
11809 C grad_shield is gradient of Calfa for peptide groups
11810 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11811 C     &               costhet,cosphi
11812 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11813 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11814       do j=1,3
11815       grad_shield(j,i)=grad_shield(j,i)
11816 C gradient po skalowaniu
11817      &                +(sh_frac_dist_grad(j)
11818 C  gradient po costhet
11819      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11820      &-scale_fac_dist*(cosphi_grad_long(j))
11821      &/(1.0-cosphi) )*div77_81
11822      &*VofOverlap
11823 C grad_shield_side is Cbeta sidechain gradient
11824       grad_shield_side(j,ishield_list(i),i)=
11825      &        (sh_frac_dist_grad(j)*-2.0d0
11826      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11827      &       +scale_fac_dist*(cosphi_grad_long(j))
11828      &        *2.0d0/(1.0-cosphi))
11829      &        *div77_81*VofOverlap
11830
11831        grad_shield_loc(j,ishield_list(i),i)=
11832      &   scale_fac_dist*cosphi_grad_loc(j)
11833      &        *2.0d0/(1.0-cosphi)
11834      &        *div77_81*VofOverlap
11835       enddo
11836       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11837       enddo
11838       fac_shield(i)=VolumeTotal*div77_81+div4_81
11839 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11840       enddo
11841       return
11842       end
11843 C--------------------------------------------------------------------------
11844       double precision function tschebyshev(m,n,x,y)
11845       implicit none
11846       include "DIMENSIONS"
11847       integer i,m,n
11848       double precision x(n),y,yy(0:maxvar),aux
11849 c Tschebyshev polynomial. Note that the first term is omitted
11850 c m=0: the constant term is included
11851 c m=1: the constant term is not included
11852       yy(0)=1.0d0
11853       yy(1)=y
11854       do i=2,n
11855         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11856       enddo
11857       aux=0.0d0
11858       do i=m,n
11859         aux=aux+x(i)*yy(i)
11860       enddo
11861       tschebyshev=aux
11862       return
11863       end
11864 C--------------------------------------------------------------------------
11865       double precision function gradtschebyshev(m,n,x,y)
11866       implicit none
11867       include "DIMENSIONS"
11868       integer i,m,n
11869       double precision x(n+1),y,yy(0:maxvar),aux
11870 c Tschebyshev polynomial. Note that the first term is omitted
11871 c m=0: the constant term is included
11872 c m=1: the constant term is not included
11873       yy(0)=1.0d0
11874       yy(1)=2.0d0*y
11875       do i=2,n
11876         yy(i)=2*y*yy(i-1)-yy(i-2)
11877       enddo
11878       aux=0.0d0
11879       do i=m,n
11880         aux=aux+x(i+1)*yy(i)*(i+1)
11881 C        print *, x(i+1),yy(i),i
11882       enddo
11883       gradtschebyshev=aux
11884       return
11885       end
11886 C------------------------------------------------------------------------
11887 C first for shielding is setting of function of side-chains
11888        subroutine set_shield_fac2
11889       implicit real*8 (a-h,o-z)
11890       include 'DIMENSIONS'
11891       include 'COMMON.CHAIN'
11892       include 'COMMON.DERIV'
11893       include 'COMMON.IOUNITS'
11894       include 'COMMON.SHIELD'
11895       include 'COMMON.INTERACT'
11896       include 'COMMON.LOCAL'
11897
11898 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11899       double precision div77_81/0.974996043d0/,
11900      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11901
11902 C the vector between center of side_chain and peptide group
11903        double precision pep_side(3),long,side_calf(3),
11904      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11905      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11906 C      write(2,*) "ivec",ivec_start,ivec_end
11907       do i=1,nres
11908         fac_shield(i)=0.0d0
11909         do j=1,3
11910         grad_shield(j,i)=0.0d0
11911         enddo
11912       enddo
11913 C the line belowe needs to be changed for FGPROC>1
11914       do i=ivec_start,ivec_end
11915 C      do i=1,nres-1
11916 C      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11917       ishield_list(i)=0
11918       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11919 Cif there two consequtive dummy atoms there is no peptide group between them
11920 C the line below has to be changed for FGPROC>1
11921       VolumeTotal=0.0
11922       do k=1,nres
11923        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11924        dist_pep_side=0.0
11925        dist_side_calf=0.0
11926        do j=1,3
11927 C first lets set vector conecting the ithe side-chain with kth side-chain
11928       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11929 C      pep_side(j)=2.0d0
11930 C and vector conecting the side-chain with its proper calfa
11931       side_calf(j)=c(j,k+nres)-c(j,k)
11932 C      side_calf(j)=2.0d0
11933       pept_group(j)=c(j,i)-c(j,i+1)
11934 C lets have their lenght
11935       dist_pep_side=pep_side(j)**2+dist_pep_side
11936       dist_side_calf=dist_side_calf+side_calf(j)**2
11937       dist_pept_group=dist_pept_group+pept_group(j)**2
11938       enddo
11939        dist_pep_side=dsqrt(dist_pep_side)
11940        dist_pept_group=dsqrt(dist_pept_group)
11941        dist_side_calf=dsqrt(dist_side_calf)
11942       do j=1,3
11943         pep_side_norm(j)=pep_side(j)/dist_pep_side
11944         side_calf_norm(j)=dist_side_calf
11945       enddo
11946 C now sscale fraction
11947        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11948 C       print *,buff_shield,"buff"
11949 C now sscale
11950         if (sh_frac_dist.le.0.0) cycle
11951 C        print *,ishield_list(i),i
11952 C If we reach here it means that this side chain reaches the shielding sphere
11953 C Lets add him to the list for gradient
11954         ishield_list(i)=ishield_list(i)+1
11955 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11956 C this list is essential otherwise problem would be O3
11957         shield_list(ishield_list(i),i)=k
11958 C Lets have the sscale value
11959         if (sh_frac_dist.gt.1.0) then
11960          scale_fac_dist=1.0d0
11961          do j=1,3
11962          sh_frac_dist_grad(j)=0.0d0
11963          enddo
11964         else
11965          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11966      &                   *(2.0d0*sh_frac_dist-3.0d0)
11967          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11968      &                  /dist_pep_side/buff_shield*0.5d0
11969 C remember for the final gradient multiply sh_frac_dist_grad(j)
11970 C for side_chain by factor -2 !
11971          do j=1,3
11972          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11973 C         sh_frac_dist_grad(j)=0.0d0
11974 C         scale_fac_dist=1.0d0
11975 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11976 C     &                    sh_frac_dist_grad(j)
11977          enddo
11978         endif
11979 C this is what is now we have the distance scaling now volume...
11980       short=short_r_sidechain(itype(k))
11981       long=long_r_sidechain(itype(k))
11982       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11983       sinthet=short/dist_pep_side*costhet
11984 C now costhet_grad
11985 C       costhet=0.6d0
11986 C       sinthet=0.8
11987        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11988 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11989 C     &             -short/dist_pep_side**2/costhet)
11990 C       costhet_fac=0.0d0
11991        do j=1,3
11992          costhet_grad(j)=costhet_fac*pep_side(j)
11993        enddo
11994 C remember for the final gradient multiply costhet_grad(j)
11995 C for side_chain by factor -2 !
11996 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11997 C pep_side0pept_group is vector multiplication
11998       pep_side0pept_group=0.0d0
11999       do j=1,3
12000       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12001       enddo
12002       cosalfa=(pep_side0pept_group/
12003      & (dist_pep_side*dist_side_calf))
12004       fac_alfa_sin=1.0d0-cosalfa**2
12005       fac_alfa_sin=dsqrt(fac_alfa_sin)
12006       rkprim=fac_alfa_sin*(long-short)+short
12007 C      rkprim=short
12008
12009 C now costhet_grad
12010        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12011 C       cosphi=0.6
12012        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12013        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12014      &      dist_pep_side**2)
12015 C       sinphi=0.8
12016        do j=1,3
12017          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12018      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12019      &*(long-short)/fac_alfa_sin*cosalfa/
12020      &((dist_pep_side*dist_side_calf))*
12021      &((side_calf(j))-cosalfa*
12022      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12023 C       cosphi_grad_long(j)=0.0d0
12024         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12025      &*(long-short)/fac_alfa_sin*cosalfa
12026      &/((dist_pep_side*dist_side_calf))*
12027      &(pep_side(j)-
12028      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12029 C       cosphi_grad_loc(j)=0.0d0
12030        enddo
12031 C      print *,sinphi,sinthet
12032       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12033      &                    /VSolvSphere_div
12034 C     &                    *wshield
12035 C now the gradient...
12036       do j=1,3
12037       grad_shield(j,i)=grad_shield(j,i)
12038 C gradient po skalowaniu
12039      &                +(sh_frac_dist_grad(j)*VofOverlap
12040 C  gradient po costhet
12041      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12042      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12043      &       sinphi/sinthet*costhet*costhet_grad(j)
12044      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12045      & )*wshield
12046 C grad_shield_side is Cbeta sidechain gradient
12047       grad_shield_side(j,ishield_list(i),i)=
12048      &        (sh_frac_dist_grad(j)*-2.0d0
12049      &        *VofOverlap
12050      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12051      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12052      &       sinphi/sinthet*costhet*costhet_grad(j)
12053      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12054      &       )*wshield
12055
12056        grad_shield_loc(j,ishield_list(i),i)=
12057      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12058      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12059      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12060      &        ))
12061      &        *wshield
12062       enddo
12063       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12064       enddo
12065       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12066 C      write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12067       enddo
12068       return
12069       end
12070 C-----------------------------------------------------------------------
12071 C-----------------------------------------------------------
12072 C This subroutine is to mimic the histone like structure but as well can be
12073 C utilizet to nanostructures (infinit) small modification has to be used to
12074 C make it finite (z gradient at the ends has to be changes as well as the x,y
12075 C gradient has to be modified at the ends
12076 C The energy function is Kihara potential
12077 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12078 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12079 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12080 C simple Kihara potential
12081       subroutine calctube(Etube)
12082        implicit real*8 (a-h,o-z)
12083       include 'DIMENSIONS'
12084       include 'COMMON.GEO'
12085       include 'COMMON.VAR'
12086       include 'COMMON.LOCAL'
12087       include 'COMMON.CHAIN'
12088       include 'COMMON.DERIV'
12089       include 'COMMON.NAMES'
12090       include 'COMMON.INTERACT'
12091       include 'COMMON.IOUNITS'
12092       include 'COMMON.CALC'
12093       include 'COMMON.CONTROL'
12094       include 'COMMON.SPLITELE'
12095       include 'COMMON.SBRIDGE'
12096       double precision tub_r,vectube(3),enetube(maxres*2)
12097       Etube=0.0d0
12098       do i=1,2*nres
12099         enetube(i)=0.0d0
12100       enddo
12101 C first we calculate the distance from tube center
12102 C first sugare-phosphate group for NARES this would be peptide group
12103 C for UNRES
12104       do i=1,nres
12105 C lets ommit dummy atoms for now
12106        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12107 C now calculate distance from center of tube and direction vectors
12108       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12109           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12110       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12111           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12112       vectube(1)=vectube(1)-tubecenter(1)
12113       vectube(2)=vectube(2)-tubecenter(2)
12114
12115 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12116 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12117
12118 C as the tube is infinity we do not calculate the Z-vector use of Z
12119 C as chosen axis
12120       vectube(3)=0.0d0
12121 C now calculte the distance
12122        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12123 C now normalize vector
12124       vectube(1)=vectube(1)/tub_r
12125       vectube(2)=vectube(2)/tub_r
12126 C calculte rdiffrence between r and r0
12127       rdiff=tub_r-tubeR0
12128 C and its 6 power
12129       rdiff6=rdiff**6.0d0
12130 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12131        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12132 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12133 C       print *,rdiff,rdiff6,pep_aa_tube
12134 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12135 C now we calculate gradient
12136        fac=(-12.0d0*pep_aa_tube/rdiff6+
12137      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12138 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12139 C     &rdiff,fac
12140
12141 C now direction of gg_tube vector
12142         do j=1,3
12143         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12144         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12145         enddo
12146         enddo
12147 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12148         do i=1,nres
12149 C Lets not jump over memory as we use many times iti
12150          iti=itype(i)
12151 C lets ommit dummy atoms for now
12152          if ((iti.eq.ntyp1)
12153 C in UNRES uncomment the line below as GLY has no side-chain...
12154 C      .or.(iti.eq.10)
12155      &   ) cycle
12156           vectube(1)=c(1,i+nres)
12157           vectube(1)=mod(vectube(1),boxxsize)
12158           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12159           vectube(2)=c(2,i+nres)
12160           vectube(2)=mod(vectube(2),boxysize)
12161           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12162
12163       vectube(1)=vectube(1)-tubecenter(1)
12164       vectube(2)=vectube(2)-tubecenter(2)
12165
12166 C as the tube is infinity we do not calculate the Z-vector use of Z
12167 C as chosen axis
12168       vectube(3)=0.0d0
12169 C now calculte the distance
12170        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12171 C now normalize vector
12172       vectube(1)=vectube(1)/tub_r
12173       vectube(2)=vectube(2)/tub_r
12174 C calculte rdiffrence between r and r0
12175       rdiff=tub_r-tubeR0
12176 C and its 6 power
12177       rdiff6=rdiff**6.0d0
12178 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12179        sc_aa_tube=sc_aa_tube_par(iti)
12180        sc_bb_tube=sc_bb_tube_par(iti)
12181        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12182 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12183 C now we calculate gradient
12184        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12185      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12186 C now direction of gg_tube vector
12187          do j=1,3
12188           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12189           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12190          enddo
12191         enddo
12192         do i=1,2*nres
12193           Etube=Etube+enetube(i)
12194         enddo
12195 C        print *,"ETUBE", etube
12196         return
12197         end
12198 C TO DO 1) add to total energy
12199 C       2) add to gradient summation
12200 C       3) add reading parameters (AND of course oppening of PARAM file)
12201 C       4) add reading the center of tube
12202 C       5) add COMMONs
12203 C       6) add to zerograd
12204
12205 C-----------------------------------------------------------------------
12206 C-----------------------------------------------------------
12207 C This subroutine is to mimic the histone like structure but as well can be
12208 C utilizet to nanostructures (infinit) small modification has to be used to
12209 C make it finite (z gradient at the ends has to be changes as well as the x,y
12210 C gradient has to be modified at the ends
12211 C The energy function is Kihara potential
12212 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12213 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12214 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12215 C simple Kihara potential
12216       subroutine calctube2(Etube)
12217        implicit real*8 (a-h,o-z)
12218       include 'DIMENSIONS'
12219       include 'COMMON.GEO'
12220       include 'COMMON.VAR'
12221       include 'COMMON.LOCAL'
12222       include 'COMMON.CHAIN'
12223       include 'COMMON.DERIV'
12224       include 'COMMON.NAMES'
12225       include 'COMMON.INTERACT'
12226       include 'COMMON.IOUNITS'
12227       include 'COMMON.CALC'
12228       include 'COMMON.CONTROL'
12229       include 'COMMON.SPLITELE'
12230       include 'COMMON.SBRIDGE'
12231       double precision tub_r,vectube(3),enetube(maxres*2)
12232       Etube=0.0d0
12233       do i=1,2*nres
12234         enetube(i)=0.0d0
12235       enddo
12236 C first we calculate the distance from tube center
12237 C first sugare-phosphate group for NARES this would be peptide group
12238 C for UNRES
12239       do i=1,nres
12240 C lets ommit dummy atoms for now
12241
12242        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12243 C now calculate distance from center of tube and direction vectors
12244       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12245           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12246       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12247           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12248       vectube(1)=vectube(1)-tubecenter(1)
12249       vectube(2)=vectube(2)-tubecenter(2)
12250
12251 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12252 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12253
12254 C as the tube is infinity we do not calculate the Z-vector use of Z
12255 C as chosen axis
12256       vectube(3)=0.0d0
12257 C now calculte the distance
12258        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12259 C now normalize vector
12260       vectube(1)=vectube(1)/tub_r
12261       vectube(2)=vectube(2)/tub_r
12262 C calculte rdiffrence between r and r0
12263       rdiff=tub_r-tubeR0
12264 C and its 6 power
12265       rdiff6=rdiff**6.0d0
12266 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12267        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12268 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12269 C       print *,rdiff,rdiff6,pep_aa_tube
12270 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12271 C now we calculate gradient
12272        fac=(-12.0d0*pep_aa_tube/rdiff6+
12273      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12274 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12275 C     &rdiff,fac
12276
12277 C now direction of gg_tube vector
12278         do j=1,3
12279         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12280         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12281         enddo
12282         enddo
12283 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12284         do i=1,nres
12285 C Lets not jump over memory as we use many times iti
12286          iti=itype(i)
12287 C lets ommit dummy atoms for now
12288          if ((iti.eq.ntyp1)
12289 C in UNRES uncomment the line below as GLY has no side-chain...
12290      &      .or.(iti.eq.10)
12291      &   ) cycle
12292           vectube(1)=c(1,i+nres)
12293           vectube(1)=mod(vectube(1),boxxsize)
12294           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12295           vectube(2)=c(2,i+nres)
12296           vectube(2)=mod(vectube(2),boxysize)
12297           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12298
12299       vectube(1)=vectube(1)-tubecenter(1)
12300       vectube(2)=vectube(2)-tubecenter(2)
12301 C THIS FRAGMENT MAKES TUBE FINITE
12302         positi=(mod(c(3,i+nres),boxzsize))
12303         if (positi.le.0) positi=positi+boxzsize
12304 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12305 c for each residue check if it is in lipid or lipid water border area
12306 C       respos=mod(c(3,i+nres),boxzsize)
12307        print *,positi,bordtubebot,buftubebot,bordtubetop
12308        if ((positi.gt.bordtubebot)
12309      & .and.(positi.lt.bordtubetop)) then
12310 C the energy transfer exist
12311         if (positi.lt.buftubebot) then
12312          fracinbuf=1.0d0-
12313      &     ((positi-bordtubebot)/tubebufthick)
12314 C lipbufthick is thickenes of lipid buffore
12315          sstube=sscalelip(fracinbuf)
12316          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12317          print *,ssgradtube, sstube,tubetranene(itype(i))
12318          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12319 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12320 C     &+ssgradtube*tubetranene(itype(i))
12321 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12322 C     &+ssgradtube*tubetranene(itype(i))
12323 C         print *,"doing sccale for lower part"
12324         elseif (positi.gt.buftubetop) then
12325          fracinbuf=1.0d0-
12326      &((bordtubetop-positi)/tubebufthick)
12327          sstube=sscalelip(fracinbuf)
12328          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12329          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12330 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12331 C     &+ssgradtube*tubetranene(itype(i))
12332 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12333 C     &+ssgradtube*tubetranene(itype(i))
12334 C          print *, "doing sscalefor top part",sslip,fracinbuf
12335         else
12336          sstube=1.0d0
12337          ssgradtube=0.0d0
12338          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12339 C         print *,"I am in true lipid"
12340         endif
12341         else
12342 C          sstube=0.0d0
12343 C          ssgradtube=0.0d0
12344         cycle
12345         endif ! if in lipid or buffor
12346 CEND OF FINITE FRAGMENT
12347 C as the tube is infinity we do not calculate the Z-vector use of Z
12348 C as chosen axis
12349       vectube(3)=0.0d0
12350 C now calculte the distance
12351        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12352 C now normalize vector
12353       vectube(1)=vectube(1)/tub_r
12354       vectube(2)=vectube(2)/tub_r
12355 C calculte rdiffrence between r and r0
12356       rdiff=tub_r-tubeR0
12357 C and its 6 power
12358       rdiff6=rdiff**6.0d0
12359 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12360        sc_aa_tube=sc_aa_tube_par(iti)
12361        sc_bb_tube=sc_bb_tube_par(iti)
12362        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12363      &                 *sstube+enetube(i+nres)
12364 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12365 C now we calculate gradient
12366        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12367      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12368 C now direction of gg_tube vector
12369          do j=1,3
12370           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12371           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12372          enddo
12373          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12374      &+ssgradtube*enetube(i+nres)/sstube
12375          gg_tube(3,i-1)= gg_tube(3,i-1)
12376      &+ssgradtube*enetube(i+nres)/sstube
12377
12378         enddo
12379         do i=1,2*nres
12380           Etube=Etube+enetube(i)
12381         enddo
12382 C        print *,"ETUBE", etube
12383         return
12384         end
12385 C TO DO 1) add to total energy
12386 C       2) add to gradient summation
12387 C       3) add reading parameters (AND of course oppening of PARAM file)
12388 C       4) add reading the center of tube
12389 C       5) add COMMONs
12390 C       6) add to zerograd
12391