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 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 141       if (ipot.lt.6) then
 142 #ifdef SPLITELE
 143          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 144      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 145      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 146      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 147 #else
 148          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 149      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 150      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 151      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 152 #endif
 153             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 154          else
 155             ees=0.0d0
 156             evdw1=0.0d0
 157             eel_loc=0.0d0
 158             eello_turn3=0.0d0
 159             eello_turn4=0.0d0
 160          endif
 161       else
 162         write (iout,*) "Soft-spheer ELEC potential"
 163 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164 c     &   eello_turn4)
 165       endif
 166 c      print *,"Processor",myrank," computed UELEC"
 167 C
 168 C Calculate excluded-volume interaction energy between peptide groups
 169 C and side chains.
 170 C
 171       if (ipot.lt.6) then
 172        if(wscp.gt.0d0) then
 173         call escp(evdw2,evdw2_14)
 174        else
 175         evdw2=0
 176         evdw2_14=0
 177        endif
 178       else
 179 c        write (iout,*) "Soft-sphere SCP potential"
 180         call escp_soft_sphere(evdw2,evdw2_14)
 181       endif
 182 c
 183 c Calculate the bond-stretching energy
 184 c
 185       call ebond(estr)
 186 C
 187 C Calculate the disulfide-bridge and other energy and the contributions
 188 C from other distance constraints.
 189 cd    print *,'Calling EHPB'
 190       call edis(ehpb)
 191 cd    print *,'EHPB exitted succesfully.'
 192 C
 193 C Calculate the virtual-bond-angle energy.
 194 C
 195       if (wang.gt.0d0) then
 196         call ebend(ebe)
 197       else
 198         ebe=0
 199       endif
 200 c      print *,"Processor",myrank," computed UB"
 201 C
 202 C Calculate the SC local energy.
 203 C
 204 C      print *,"TU DOCHODZE?"
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 C      print *,"PRZED MULIt"
 236 c      print *,"Processor",myrank," computed Usccorr"
 237 C
 238 C 12/1/95 Multi-body terms
 239 C
 240       n_corr=0
 241       n_corr1=0
 242       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 243      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 245 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 246 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 247       else
 248          ecorr=0.0d0
 249          ecorr5=0.0d0
 250          ecorr6=0.0d0
 251          eturn6=0.0d0
 252       endif
 253       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 254          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 255 cd         write (iout,*) "multibody_hb ecorr",ecorr
 256       endif
 257 c      print *,"Processor",myrank," computed Ucorr"
 258 C
 259 C If performing constraint dynamics, call the constraint energy
 260 C  after the equilibration time
 261       if(usampl.and.totT.gt.eq_time) then
 262          call EconstrQ
 263          call Econstr_back
 264       else
 265          Uconst=0.0d0
 266          Uconst_back=0.0d0
 267       endif
 268 C 01/27/2015 added by adasko
 269 C the energy component below is energy transfer into lipid environment
 270 C based on partition function
 271 C      print *,"przed lipidami"
 272       if (wliptran.gt.0) then
 273         call Eliptransfer(eliptran)
 274       endif
 275 C      print *,"za lipidami"
 276       if (AFMlog.gt.0) then
 277         call AFMforce(Eafmforce)
 278       else if (selfguide.gt.0) then
 279         call AFMvel(Eafmforce)
 280       endif
 281 #ifdef TIMING
 282       time_enecalc=time_enecalc+MPI_Wtime()-time00
 283 #endif
 284 c      print *,"Processor",myrank," computed Uconstr"
 285 #ifdef TIMING
 286       time00=MPI_Wtime()
 287 #endif
 288 c
 289 C Sum the energies
 290 C
 291       energia(1)=evdw
 292 #ifdef SCP14
 293       energia(2)=evdw2-evdw2_14
 294       energia(18)=evdw2_14
 295 #else
 296       energia(2)=evdw2
 297       energia(18)=0.0d0
 298 #endif
 299 #ifdef SPLITELE
 300       energia(3)=ees
 301       energia(16)=evdw1
 302 #else
 303       energia(3)=ees+evdw1
 304       energia(16)=0.0d0
 305 #endif
 306       energia(4)=ecorr
 307       energia(5)=ecorr5
 308       energia(6)=ecorr6
 309       energia(7)=eel_loc
 310       energia(8)=eello_turn3
 311       energia(9)=eello_turn4
 312       energia(10)=eturn6
 313       energia(11)=ebe
 314       energia(12)=escloc
 315       energia(13)=etors
 316       energia(14)=etors_d
 317       energia(15)=ehpb
 318       energia(19)=edihcnstr
 319       energia(17)=estr
 320       energia(20)=Uconst+Uconst_back
 321       energia(21)=esccor
 322       energia(22)=eliptran
 323       energia(23)=Eafmforce
 324 c    Here are the energies showed per procesor if the are more processors
 325 c    per molecule then we sum it up in sum_energy subroutine
 326 c      print *," Processor",myrank," calls SUM_ENERGY"
 327       call sum_energy(energia,.true.)
 328       if (dyn_ss) call dyn_set_nss
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331       time_sumene=time_sumene+MPI_Wtime()-time00
 332 #endif
 333       return
 334       end
 335 c-------------------------------------------------------------------------------
 336       subroutine sum_energy(energia,reduce)
 337       implicit real*8 (a-h,o-z)
 338       include 'DIMENSIONS'
 339 #ifndef ISNAN
 340       external proc_proc
 341 #ifdef WINPGI
 342 cMS$ATTRIBUTES C ::  proc_proc
 343 #endif
 344 #endif
 345 #ifdef MPI
 346       include "mpif.h"
 347 #endif
 348       include 'COMMON.SETUP'
 349       include 'COMMON.IOUNITS'
 350       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 351       include 'COMMON.FFIELD'
 352       include 'COMMON.DERIV'
 353       include 'COMMON.INTERACT'
 354       include 'COMMON.SBRIDGE'
 355       include 'COMMON.CHAIN'
 356       include 'COMMON.VAR'
 357       include 'COMMON.CONTROL'
 358       include 'COMMON.TIME1'
 359       logical reduce
 360 #ifdef MPI
 361       if (nfgtasks.gt.1 .and. reduce) then
 362 #ifdef DEBUG
 363         write (iout,*) "energies before REDUCE"
 364         call enerprint(energia)
 365         call flush(iout)
 366 #endif
 367         do i=0,n_ene
 368           enebuff(i)=energia(i)
 369         enddo
 370         time00=MPI_Wtime()
 371         call MPI_Barrier(FG_COMM,IERR)
 372         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 373         time00=MPI_Wtime()
 374         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 375      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 376 #ifdef DEBUG
 377         write (iout,*) "energies after REDUCE"
 378         call enerprint(energia)
 379         call flush(iout)
 380 #endif
 381         time_Reduce=time_Reduce+MPI_Wtime()-time00
 382       endif
 383       if (fg_rank.eq.0) then
 384 #endif
 385       evdw=energia(1)
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       eliptran=energia(22)
 416       Eafmforce=energia(23)
 417 #ifdef SPLITELE
 418       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 419      & +wang*ebe+wtor*etors+wscloc*escloc
 420      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 421      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 422      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 423      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 424 #else
 425       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 426      & +wang*ebe+wtor*etors+wscloc*escloc
 427      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 428      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 429      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 430      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 431      & +Eafmforce
 432 #endif
 433       energia(0)=etot
 434 c detecting NaNQ
 435 #ifdef ISNAN
 436 #ifdef AIX
 437       if (isnan(etot).ne.0) energia(0)=1.0d+99
 438 #else
 439       if (isnan(etot)) energia(0)=1.0d+99
 440 #endif
 441 #else
 442       i=0
 443 #ifdef WINPGI
 444       idumm=proc_proc(etot,i)
 445 #else
 446       call proc_proc(etot,i)
 447 #endif
 448       if(i.eq.1)energia(0)=1.0d+99
 449 #endif
 450 #ifdef MPI
 451       endif
 452 #endif
 453       return
 454       end
 455 c-------------------------------------------------------------------------------
 456       subroutine sum_gradient
 457       implicit real*8 (a-h,o-z)
 458       include 'DIMENSIONS'
 459 #ifndef ISNAN
 460       external proc_proc
 461 #ifdef WINPGI
 462 cMS$ATTRIBUTES C ::  proc_proc
 463 #endif
 464 #endif
 465 #ifdef MPI
 466       include 'mpif.h'
 467 #endif
 468       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 469      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 470      & ,gloc_scbuf(3,-1:maxres)
 471       include 'COMMON.SETUP'
 472       include 'COMMON.IOUNITS'
 473       include 'COMMON.FFIELD'
 474       include 'COMMON.DERIV'
 475       include 'COMMON.INTERACT'
 476       include 'COMMON.SBRIDGE'
 477       include 'COMMON.CHAIN'
 478       include 'COMMON.VAR'
 479       include 'COMMON.CONTROL'
 480       include 'COMMON.TIME1'
 481       include 'COMMON.MAXGRAD'
 482       include 'COMMON.SCCOR'
 483 #ifdef TIMING
 484       time01=MPI_Wtime()
 485 #endif
 486 #ifdef DEBUG
 487       write (iout,*) "sum_gradient gvdwc, gvdwx"
 488       do i=1,nres
 489         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 490      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 491       enddo
 492       call flush(iout)
 493 #endif
 494 #ifdef MPI
 495 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 496         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 497      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 498 #endif
 499 C
 500 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 501 C            in virtual-bond-vector coordinates
 502 C
 503 #ifdef DEBUG
 504 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 505 c      do i=1,nres-1
 506 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 507 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 508 c      enddo
 509 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 510 c      do i=1,nres-1
 511 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 512 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 513 c      enddo
 514       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 515       do i=1,nres
 516         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 517      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 518      &   g_corr5_loc(i)
 519       enddo
 520       call flush(iout)
 521 #endif
 522 #ifdef SPLITELE
 523       do i=0,nct
 524         do j=1,3
 525           gradbufc(j,i)=wsc*gvdwc(j,i)+
 526      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 527      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 528      &                wel_loc*gel_loc_long(j,i)+
 529      &                wcorr*gradcorr_long(j,i)+
 530      &                wcorr5*gradcorr5_long(j,i)+
 531      &                wcorr6*gradcorr6_long(j,i)+
 532      &                wturn6*gcorr6_turn_long(j,i)+
 533      &                wstrain*ghpbc(j,i)
 534      &                +wliptran*gliptranc(j,i)
 535      &                +gradafm(j,i)
 536
 537         enddo
 538       enddo
 539 #else
 540       do i=0,nct
 541         do j=1,3
 542           gradbufc(j,i)=wsc*gvdwc(j,i)+
 543      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 544      &                welec*gelc_long(j,i)+
 545      &                wbond*gradb(j,i)+
 546      &                wel_loc*gel_loc_long(j,i)+
 547      &                wcorr*gradcorr_long(j,i)+
 548      &                wcorr5*gradcorr5_long(j,i)+
 549      &                wcorr6*gradcorr6_long(j,i)+
 550      &                wturn6*gcorr6_turn_long(j,i)+
 551      &                wstrain*ghpbc(j,i)
 552      &                +wliptran*gliptranc(j,i)
 553      &                +gradafm(j,i)
 554
 555         enddo
 556       enddo
 557 #endif
 558 #ifdef MPI
 559       if (nfgtasks.gt.1) then
 560       time00=MPI_Wtime()
 561 #ifdef DEBUG
 562       write (iout,*) "gradbufc before allreduce"
 563       do i=1,nres
 564         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 565       enddo
 566       call flush(iout)
 567 #endif
 568       do i=0,nres
 569         do j=1,3
 570           gradbufc_sum(j,i)=gradbufc(j,i)
 571         enddo
 572       enddo
 573 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 574 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 575 c      time_reduce=time_reduce+MPI_Wtime()-time00
 576 #ifdef DEBUG
 577 c      write (iout,*) "gradbufc_sum after allreduce"
 578 c      do i=1,nres
 579 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 580 c      enddo
 581 c      call flush(iout)
 582 #endif
 583 #ifdef TIMING
 584 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 585 #endif
 586       do i=nnt,nres
 587         do k=1,3
 588           gradbufc(k,i)=0.0d0
 589         enddo
 590       enddo
 591 #ifdef DEBUG
 592       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 593       write (iout,*) (i," jgrad_start",jgrad_start(i),
 594      &                  " jgrad_end  ",jgrad_end(i),
 595      &                  i=igrad_start,igrad_end)
 596 #endif
 597 c
 598 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 599 c do not parallelize this part.
 600 c
 601 c      do i=igrad_start,igrad_end
 602 c        do j=jgrad_start(i),jgrad_end(i)
 603 c          do k=1,3
 604 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 605 c          enddo
 606 c        enddo
 607 c      enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,-1,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "gradbufc after summing"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 620       enddo
 621       call flush(iout)
 622 #endif
 623       else
 624 #endif
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632       do i=-1,nres
 633         do j=1,3
 634           gradbufc_sum(j,i)=gradbufc(j,i)
 635           gradbufc(j,i)=0.0d0
 636         enddo
 637       enddo
 638       do j=1,3
 639         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 640       enddo
 641       do i=nres-2,-1,-1
 642         do j=1,3
 643           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 644         enddo
 645       enddo
 646 c      do i=nnt,nres-1
 647 c        do k=1,3
 648 c          gradbufc(k,i)=0.0d0
 649 c        enddo
 650 c        do j=i+1,nres
 651 c          do k=1,3
 652 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 653 c          enddo
 654 c        enddo
 655 c      enddo
 656 #ifdef DEBUG
 657       write (iout,*) "gradbufc after summing"
 658       do i=1,nres
 659         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 660       enddo
 661       call flush(iout)
 662 #endif
 663 #ifdef MPI
 664       endif
 665 #endif
 666       do k=1,3
 667         gradbufc(k,nres)=0.0d0
 668       enddo
 669       do i=-1,nct
 670         do j=1,3
 671 #ifdef SPLITELE
 672           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 673      &                wel_loc*gel_loc(j,i)+
 674      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 675      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 676      &                wel_loc*gel_loc_long(j,i)+
 677      &                wcorr*gradcorr_long(j,i)+
 678      &                wcorr5*gradcorr5_long(j,i)+
 679      &                wcorr6*gradcorr6_long(j,i)+
 680      &                wturn6*gcorr6_turn_long(j,i))+
 681      &                wbond*gradb(j,i)+
 682      &                wcorr*gradcorr(j,i)+
 683      &                wturn3*gcorr3_turn(j,i)+
 684      &                wturn4*gcorr4_turn(j,i)+
 685      &                wcorr5*gradcorr5(j,i)+
 686      &                wcorr6*gradcorr6(j,i)+
 687      &                wturn6*gcorr6_turn(j,i)+
 688      &                wsccor*gsccorc(j,i)
 689      &               +wscloc*gscloc(j,i)
 690      &               +wliptran*gliptranc(j,i)
 691      &                +gradafm(j,i)
 692 #else
 693           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 694      &                wel_loc*gel_loc(j,i)+
 695      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 696      &                welec*gelc_long(j,i)
 697      &                wel_loc*gel_loc_long(j,i)+
 698      &                wcorr*gcorr_long(j,i)+
 699      &                wcorr5*gradcorr5_long(j,i)+
 700      &                wcorr6*gradcorr6_long(j,i)+
 701      &                wturn6*gcorr6_turn_long(j,i))+
 702      &                wbond*gradb(j,i)+
 703      &                wcorr*gradcorr(j,i)+
 704      &                wturn3*gcorr3_turn(j,i)+
 705      &                wturn4*gcorr4_turn(j,i)+
 706      &                wcorr5*gradcorr5(j,i)+
 707      &                wcorr6*gradcorr6(j,i)+
 708      &                wturn6*gcorr6_turn(j,i)+
 709      &                wsccor*gsccorc(j,i)
 710      &               +wscloc*gscloc(j,i)
 711      &               +wliptran*gliptranc(j,i)
 712      &                +gradafm(j,i)
 713
 714 #endif
 715           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 716      &                  wbond*gradbx(j,i)+
 717      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 718      &                  wsccor*gsccorx(j,i)
 719      &                 +wscloc*gsclocx(j,i)
 720      &                 +wliptran*gliptranx(j,i)
 721         enddo
 722       enddo
 723 #ifdef DEBUG
 724       write (iout,*) "gloc before adding corr"
 725       do i=1,4*nres
 726         write (iout,*) i,gloc(i,icg)
 727       enddo
 728 #endif
 729       do i=1,nres-3
 730         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 731      &   +wcorr5*g_corr5_loc(i)
 732      &   +wcorr6*g_corr6_loc(i)
 733      &   +wturn4*gel_loc_turn4(i)
 734      &   +wturn3*gel_loc_turn3(i)
 735      &   +wturn6*gel_loc_turn6(i)
 736      &   +wel_loc*gel_loc_loc(i)
 737       enddo
 738 #ifdef DEBUG
 739       write (iout,*) "gloc after adding corr"
 740       do i=1,4*nres
 741         write (iout,*) i,gloc(i,icg)
 742       enddo
 743 #endif
 744 #ifdef MPI
 745       if (nfgtasks.gt.1) then
 746         do j=1,3
 747           do i=1,nres
 748             gradbufc(j,i)=gradc(j,i,icg)
 749             gradbufx(j,i)=gradx(j,i,icg)
 750           enddo
 751         enddo
 752         do i=1,4*nres
 753           glocbuf(i)=gloc(i,icg)
 754         enddo
 755 c#define DEBUG
 756 #ifdef DEBUG
 757       write (iout,*) "gloc_sc before reduce"
 758       do i=1,nres
 759        do j=1,1
 760         write (iout,*) i,j,gloc_sc(j,i,icg)
 761        enddo
 762       enddo
 763 #endif
 764 c#undef DEBUG
 765         do i=1,nres
 766          do j=1,3
 767           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 768          enddo
 769         enddo
 770         time00=MPI_Wtime()
 771         call MPI_Barrier(FG_COMM,IERR)
 772         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 773         time00=MPI_Wtime()
 774         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 775      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 776         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 777      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 778         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 779      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 780         time_reduce=time_reduce+MPI_Wtime()-time00
 781         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 782      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 783         time_reduce=time_reduce+MPI_Wtime()-time00
 784 c#define DEBUG
 785 #ifdef DEBUG
 786       write (iout,*) "gloc_sc after reduce"
 787       do i=1,nres
 788        do j=1,1
 789         write (iout,*) i,j,gloc_sc(j,i,icg)
 790        enddo
 791       enddo
 792 #endif
 793 c#undef DEBUG
 794 #ifdef DEBUG
 795       write (iout,*) "gloc after reduce"
 796       do i=1,4*nres
 797         write (iout,*) i,gloc(i,icg)
 798       enddo
 799 #endif
 800       endif
 801 #endif
 802       if (gnorm_check) then
 803 c
 804 c Compute the maximum elements of the gradient
 805 c
 806       gvdwc_max=0.0d0
 807       gvdwc_scp_max=0.0d0
 808       gelc_max=0.0d0
 809       gvdwpp_max=0.0d0
 810       gradb_max=0.0d0
 811       ghpbc_max=0.0d0
 812       gradcorr_max=0.0d0
 813       gel_loc_max=0.0d0
 814       gcorr3_turn_max=0.0d0
 815       gcorr4_turn_max=0.0d0
 816       gradcorr5_max=0.0d0
 817       gradcorr6_max=0.0d0
 818       gcorr6_turn_max=0.0d0
 819       gsccorc_max=0.0d0
 820       gscloc_max=0.0d0
 821       gvdwx_max=0.0d0
 822       gradx_scp_max=0.0d0
 823       ghpbx_max=0.0d0
 824       gradxorr_max=0.0d0
 825       gsccorx_max=0.0d0
 826       gsclocx_max=0.0d0
 827       do i=1,nct
 828         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 829         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 830         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 831         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 832      &   gvdwc_scp_max=gvdwc_scp_norm
 833         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 834         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 835         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 836         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 837         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 838         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 839         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 840         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 841         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 842         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 843         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 844         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 845         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 846      &    gcorr3_turn(1,i)))
 847         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 848      &    gcorr3_turn_max=gcorr3_turn_norm
 849         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 850      &    gcorr4_turn(1,i)))
 851         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 852      &    gcorr4_turn_max=gcorr4_turn_norm
 853         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 854         if (gradcorr5_norm.gt.gradcorr5_max)
 855      &    gradcorr5_max=gradcorr5_norm
 856         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 857         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 858         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 859      &    gcorr6_turn(1,i)))
 860         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 861      &    gcorr6_turn_max=gcorr6_turn_norm
 862         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 863         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 864         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 865         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 866         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 867         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 868         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 869         if (gradx_scp_norm.gt.gradx_scp_max)
 870      &    gradx_scp_max=gradx_scp_norm
 871         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 872         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 873         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 874         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 875         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 876         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 877         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 878         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 879       enddo
 880       if (gradout) then
 881 #ifdef AIX
 882         open(istat,file=statname,position="append")
 883 #else
 884         open(istat,file=statname,access="append")
 885 #endif
 886         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 887      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 888      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 889      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 890      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 891      &     gsccorx_max,gsclocx_max
 892         close(istat)
 893         if (gvdwc_max.gt.1.0d4) then
 894           write (iout,*) "gvdwc gvdwx gradb gradbx"
 895           do i=nnt,nct
 896             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 897      &        gradb(j,i),gradbx(j,i),j=1,3)
 898           enddo
 899           call pdbout(0.0d0,'cipiszcze',iout)
 900           call flush(iout)
 901         endif
 902       endif
 903       endif
 904 #ifdef DEBUG
 905       write (iout,*) "gradc gradx gloc"
 906       do i=1,nres
 907         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 908      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 909       enddo
 910 #endif
 911 #ifdef TIMING
 912       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 913 #endif
 914       return
 915       end
 916 c-------------------------------------------------------------------------------
 917       subroutine rescale_weights(t_bath)
 918       implicit real*8 (a-h,o-z)
 919       include 'DIMENSIONS'
 920       include 'COMMON.IOUNITS'
 921       include 'COMMON.FFIELD'
 922       include 'COMMON.SBRIDGE'
 923       double precision kfac /2.4d0/
 924       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 925 c      facT=temp0/t_bath
 926 c      facT=2*temp0/(t_bath+temp0)
 927       if (rescale_mode.eq.0) then
 928         facT=1.0d0
 929         facT2=1.0d0
 930         facT3=1.0d0
 931         facT4=1.0d0
 932         facT5=1.0d0
 933       else if (rescale_mode.eq.1) then
 934         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 935         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 936         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 937         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 938         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 939       else if (rescale_mode.eq.2) then
 940         x=t_bath/temp0
 941         x2=x*x
 942         x3=x2*x
 943         x4=x3*x
 944         x5=x4*x
 945         facT=licznik/dlog(dexp(x)+dexp(-x))
 946         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 947         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 948         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 949         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 950       else
 951         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 952         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 953 #ifdef MPI
 954        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 955 #endif
 956        stop 555
 957       endif
 958       welec=weights(3)*fact
 959       wcorr=weights(4)*fact3
 960       wcorr5=weights(5)*fact4
 961       wcorr6=weights(6)*fact5
 962       wel_loc=weights(7)*fact2
 963       wturn3=weights(8)*fact2
 964       wturn4=weights(9)*fact3
 965       wturn6=weights(10)*fact5
 966       wtor=weights(13)*fact
 967       wtor_d=weights(14)*fact2
 968       wsccor=weights(21)*fact
 969
 970       return
 971       end
 972 C------------------------------------------------------------------------
 973       subroutine enerprint(energia)
 974       implicit real*8 (a-h,o-z)
 975       include 'DIMENSIONS'
 976       include 'COMMON.IOUNITS'
 977       include 'COMMON.FFIELD'
 978       include 'COMMON.SBRIDGE'
 979       include 'COMMON.MD'
 980       double precision energia(0:n_ene)
 981       etot=energia(0)
 982       evdw=energia(1)
 983       evdw2=energia(2)
 984 #ifdef SCP14
 985       evdw2=energia(2)+energia(18)
 986 #else
 987       evdw2=energia(2)
 988 #endif
 989       ees=energia(3)
 990 #ifdef SPLITELE
 991       evdw1=energia(16)
 992 #endif
 993       ecorr=energia(4)
 994       ecorr5=energia(5)
 995       ecorr6=energia(6)
 996       eel_loc=energia(7)
 997       eello_turn3=energia(8)
 998       eello_turn4=energia(9)
 999       eello_turn6=energia(10)
1000       ebe=energia(11)
1001       escloc=energia(12)
1002       etors=energia(13)
1003       etors_d=energia(14)
1004       ehpb=energia(15)
1005       edihcnstr=energia(19)
1006       estr=energia(17)
1007       Uconst=energia(20)
1008       esccor=energia(21)
1009       eliptran=energia(22)
1010       Eafmforce=energia(23)
1011 #ifdef SPLITELE
1012       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1013      &  estr,wbond,ebe,wang,
1014      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1015      &  ecorr,wcorr,
1016      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1017      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1018      &  edihcnstr,ebr*nss,
1019      &  Uconst,eliptran,wliptran,Eafmforce,etot
1020    10 format (/'Virtual-chain energies:'//
1021      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1022      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1023      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1024      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1025      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1026      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1027      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1028      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1029      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1030      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1031      & ' (SS bridges & dist. cnstr.)'/
1032      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1033      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1034      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1035      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1036      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1037      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1038      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1039      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1040      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1041      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1042      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1043      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1044      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1045      & 'ETOT=  ',1pE16.6,' (total)')
1046
1047 #else
1048       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1049      &  estr,wbond,ebe,wang,
1050      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1051      &  ecorr,wcorr,
1052      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1053      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1054      &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
1055    10 format (/'Virtual-chain energies:'//
1056      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1057      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1058      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1059      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1060      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1061      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1062      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1063      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1064      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1065      & ' (SS bridges & dist. cnstr.)'/
1066      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1067      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1068      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1069      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1070      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1071      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1072      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1073      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1074      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1075      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1076      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1077      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1078      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1079      & 'ETOT=  ',1pE16.6,' (total)')
1080 #endif
1081       return
1082       end
1083 C-----------------------------------------------------------------------
1084       subroutine elj(evdw)
1085 C
1086 C This subroutine calculates the interaction energy of nonbonded side chains
1087 C assuming the LJ potential of interaction.
1088 C
1089       implicit real*8 (a-h,o-z)
1090       include 'DIMENSIONS'
1091       parameter (accur=1.0d-10)
1092       include 'COMMON.GEO'
1093       include 'COMMON.VAR'
1094       include 'COMMON.LOCAL'
1095       include 'COMMON.CHAIN'
1096       include 'COMMON.DERIV'
1097       include 'COMMON.INTERACT'
1098       include 'COMMON.TORSION'
1099       include 'COMMON.SBRIDGE'
1100       include 'COMMON.NAMES'
1101       include 'COMMON.IOUNITS'
1102       include 'COMMON.CONTACTS'
1103       dimension gg(3)
1104 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1105       evdw=0.0D0
1106       do i=iatsc_s,iatsc_e
1107         itypi=iabs(itype(i))
1108         if (itypi.eq.ntyp1) cycle
1109         itypi1=iabs(itype(i+1))
1110         xi=c(1,nres+i)
1111         yi=c(2,nres+i)
1112         zi=c(3,nres+i)
1113 C Change 12/1/95
1114         num_conti=0
1115 C
1116 C Calculate SC interaction energy.
1117 C
1118         do iint=1,nint_gr(i)
1119 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1120 cd   &                  'iend=',iend(i,iint)
1121           do j=istart(i,iint),iend(i,iint)
1122             itypj=iabs(itype(j))
1123             if (itypj.eq.ntyp1) cycle
1124             xj=c(1,nres+j)-xi
1125             yj=c(2,nres+j)-yi
1126             zj=c(3,nres+j)-zi
1127 C Change 12/1/95 to calculate four-body interactions
1128             rij=xj*xj+yj*yj+zj*zj
1129             rrij=1.0D0/rij
1130 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1131             eps0ij=eps(itypi,itypj)
1132             fac=rrij**expon2
1133 C have you changed here?
1134             e1=fac*fac*aa
1135             e2=fac*bb
1136             evdwij=e1+e2
1137 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1138 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1139 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1140 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1141 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1142 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1143             evdw=evdw+evdwij
1144 C
1145 C Calculate the components of the gradient in DC and X
1146 C
1147             fac=-rrij*(e1+evdwij)
1148             gg(1)=xj*fac
1149             gg(2)=yj*fac
1150             gg(3)=zj*fac
1151             do k=1,3
1152               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1153               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1154               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1155               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1156             enddo
1157 cgrad            do k=i,j-1
1158 cgrad              do l=1,3
1159 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1160 cgrad              enddo
1161 cgrad            enddo
1162 C
1163 C 12/1/95, revised on 5/20/97
1164 C
1165 C Calculate the contact function. The ith column of the array JCONT will
1166 C contain the numbers of atoms that make contacts with the atom I (of numbers
1167 C greater than I). The arrays FACONT and GACONT will contain the values of
1168 C the contact function and its derivative.
1169 C
1170 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1171 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1172 C Uncomment next line, if the correlation interactions are contact function only
1173             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1174               rij=dsqrt(rij)
1175               sigij=sigma(itypi,itypj)
1176               r0ij=rs0(itypi,itypj)
1177 C
1178 C Check whether the SC's are not too far to make a contact.
1179 C
1180               rcut=1.5d0*r0ij
1181               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1182 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1183 C
1184               if (fcont.gt.0.0D0) then
1185 C If the SC-SC distance if close to sigma, apply spline.
1186 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1187 cAdam &             fcont1,fprimcont1)
1188 cAdam           fcont1=1.0d0-fcont1
1189 cAdam           if (fcont1.gt.0.0d0) then
1190 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1191 cAdam             fcont=fcont*fcont1
1192 cAdam           endif
1193 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1194 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1195 cga             do k=1,3
1196 cga               gg(k)=gg(k)*eps0ij
1197 cga             enddo
1198 cga             eps0ij=-evdwij*eps0ij
1199 C Uncomment for AL's type of SC correlation interactions.
1200 cadam           eps0ij=-evdwij
1201                 num_conti=num_conti+1
1202                 jcont(num_conti,i)=j
1203                 facont(num_conti,i)=fcont*eps0ij
1204                 fprimcont=eps0ij*fprimcont/rij
1205                 fcont=expon*fcont
1206 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1207 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1208 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1209 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1210                 gacont(1,num_conti,i)=-fprimcont*xj
1211                 gacont(2,num_conti,i)=-fprimcont*yj
1212                 gacont(3,num_conti,i)=-fprimcont*zj
1213 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1214 cd              write (iout,'(2i3,3f10.5)')
1215 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1216               endif
1217             endif
1218           enddo      ! j
1219         enddo        ! iint
1220 C Change 12/1/95
1221         num_cont(i)=num_conti
1222       enddo          ! i
1223       do i=1,nct
1224         do j=1,3
1225           gvdwc(j,i)=expon*gvdwc(j,i)
1226           gvdwx(j,i)=expon*gvdwx(j,i)
1227         enddo
1228       enddo
1229 C******************************************************************************
1230 C
1231 C                              N O T E !!!
1232 C
1233 C To save time, the factor of EXPON has been extracted from ALL components
1234 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1235 C use!
1236 C
1237 C******************************************************************************
1238       return
1239       end
1240 C-----------------------------------------------------------------------------
1241       subroutine eljk(evdw)
1242 C
1243 C This subroutine calculates the interaction energy of nonbonded side chains
1244 C assuming the LJK potential of interaction.
1245 C
1246       implicit real*8 (a-h,o-z)
1247       include 'DIMENSIONS'
1248       include 'COMMON.GEO'
1249       include 'COMMON.VAR'
1250       include 'COMMON.LOCAL'
1251       include 'COMMON.CHAIN'
1252       include 'COMMON.DERIV'
1253       include 'COMMON.INTERACT'
1254       include 'COMMON.IOUNITS'
1255       include 'COMMON.NAMES'
1256       dimension gg(3)
1257       logical scheck
1258 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1259       evdw=0.0D0
1260       do i=iatsc_s,iatsc_e
1261         itypi=iabs(itype(i))
1262         if (itypi.eq.ntyp1) cycle
1263         itypi1=iabs(itype(i+1))
1264         xi=c(1,nres+i)
1265         yi=c(2,nres+i)
1266         zi=c(3,nres+i)
1267 C
1268 C Calculate SC interaction energy.
1269 C
1270         do iint=1,nint_gr(i)
1271           do j=istart(i,iint),iend(i,iint)
1272             itypj=iabs(itype(j))
1273             if (itypj.eq.ntyp1) cycle
1274             xj=c(1,nres+j)-xi
1275             yj=c(2,nres+j)-yi
1276             zj=c(3,nres+j)-zi
1277             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1278             fac_augm=rrij**expon
1279             e_augm=augm(itypi,itypj)*fac_augm
1280             r_inv_ij=dsqrt(rrij)
1281             rij=1.0D0/r_inv_ij
1282             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1283             fac=r_shift_inv**expon
1284 C have you changed here?
1285             e1=fac*fac*aa
1286             e2=fac*bb
1287             evdwij=e_augm+e1+e2
1288 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1289 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1290 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1291 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1292 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1293 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1294 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1295             evdw=evdw+evdwij
1296 C
1297 C Calculate the components of the gradient in DC and X
1298 C
1299             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1300             gg(1)=xj*fac
1301             gg(2)=yj*fac
1302             gg(3)=zj*fac
1303             do k=1,3
1304               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1305               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1306               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1307               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1308             enddo
1309 cgrad            do k=i,j-1
1310 cgrad              do l=1,3
1311 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1312 cgrad              enddo
1313 cgrad            enddo
1314           enddo      ! j
1315         enddo        ! iint
1316       enddo          ! i
1317       do i=1,nct
1318         do j=1,3
1319           gvdwc(j,i)=expon*gvdwc(j,i)
1320           gvdwx(j,i)=expon*gvdwx(j,i)
1321         enddo
1322       enddo
1323       return
1324       end
1325 C-----------------------------------------------------------------------------
1326       subroutine ebp(evdw)
1327 C
1328 C This subroutine calculates the interaction energy of nonbonded side chains
1329 C assuming the Berne-Pechukas potential of interaction.
1330 C
1331       implicit real*8 (a-h,o-z)
1332       include 'DIMENSIONS'
1333       include 'COMMON.GEO'
1334       include 'COMMON.VAR'
1335       include 'COMMON.LOCAL'
1336       include 'COMMON.CHAIN'
1337       include 'COMMON.DERIV'
1338       include 'COMMON.NAMES'
1339       include 'COMMON.INTERACT'
1340       include 'COMMON.IOUNITS'
1341       include 'COMMON.CALC'
1342       common /srutu/ icall
1343 c     double precision rrsave(maxdim)
1344       logical lprn
1345       evdw=0.0D0
1346 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1347       evdw=0.0D0
1348 c     if (icall.eq.0) then
1349 c       lprn=.true.
1350 c     else
1351         lprn=.false.
1352 c     endif
1353       ind=0
1354       do i=iatsc_s,iatsc_e
1355         itypi=iabs(itype(i))
1356         if (itypi.eq.ntyp1) cycle
1357         itypi1=iabs(itype(i+1))
1358         xi=c(1,nres+i)
1359         yi=c(2,nres+i)
1360         zi=c(3,nres+i)
1361         dxi=dc_norm(1,nres+i)
1362         dyi=dc_norm(2,nres+i)
1363         dzi=dc_norm(3,nres+i)
1364 c        dsci_inv=dsc_inv(itypi)
1365         dsci_inv=vbld_inv(i+nres)
1366 C
1367 C Calculate SC interaction energy.
1368 C
1369         do iint=1,nint_gr(i)
1370           do j=istart(i,iint),iend(i,iint)
1371             ind=ind+1
1372             itypj=iabs(itype(j))
1373             if (itypj.eq.ntyp1) cycle
1374 c            dscj_inv=dsc_inv(itypj)
1375             dscj_inv=vbld_inv(j+nres)
1376             chi1=chi(itypi,itypj)
1377             chi2=chi(itypj,itypi)
1378             chi12=chi1*chi2
1379             chip1=chip(itypi)
1380             chip2=chip(itypj)
1381             chip12=chip1*chip2
1382             alf1=alp(itypi)
1383             alf2=alp(itypj)
1384             alf12=0.5D0*(alf1+alf2)
1385 C For diagnostics only!!!
1386 c           chi1=0.0D0
1387 c           chi2=0.0D0
1388 c           chi12=0.0D0
1389 c           chip1=0.0D0
1390 c           chip2=0.0D0
1391 c           chip12=0.0D0
1392 c           alf1=0.0D0
1393 c           alf2=0.0D0
1394 c           alf12=0.0D0
1395             xj=c(1,nres+j)-xi
1396             yj=c(2,nres+j)-yi
1397             zj=c(3,nres+j)-zi
1398             dxj=dc_norm(1,nres+j)
1399             dyj=dc_norm(2,nres+j)
1400             dzj=dc_norm(3,nres+j)
1401             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1402 cd          if (icall.eq.0) then
1403 cd            rrsave(ind)=rrij
1404 cd          else
1405 cd            rrij=rrsave(ind)
1406 cd          endif
1407             rij=dsqrt(rrij)
1408 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1409             call sc_angular
1410 C Calculate whole angle-dependent part of epsilon and contributions
1411 C to its derivatives
1412 C have you changed here?
1413             fac=(rrij*sigsq)**expon2
1414             e1=fac*fac*aa
1415             e2=fac*bb
1416             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1417             eps2der=evdwij*eps3rt
1418             eps3der=evdwij*eps2rt
1419             evdwij=evdwij*eps2rt*eps3rt
1420             evdw=evdw+evdwij
1421             if (lprn) then
1422             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1423             epsi=bb**2/aa
1424 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1425 cd     &        restyp(itypi),i,restyp(itypj),j,
1426 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1427 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1428 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1429 cd     &        evdwij
1430             endif
1431 C Calculate gradient components.
1432             e1=e1*eps1*eps2rt**2*eps3rt**2
1433             fac=-expon*(e1+evdwij)
1434             sigder=fac/sigsq
1435             fac=rrij*fac
1436 C Calculate radial part of the gradient
1437             gg(1)=xj*fac
1438             gg(2)=yj*fac
1439             gg(3)=zj*fac
1440 C Calculate the angular part of the gradient and sum add the contributions
1441 C to the appropriate components of the Cartesian gradient.
1442             call sc_grad
1443           enddo      ! j
1444         enddo        ! iint
1445       enddo          ! i
1446 c     stop
1447       return
1448       end
1449 C-----------------------------------------------------------------------------
1450       subroutine egb(evdw)
1451 C
1452 C This subroutine calculates the interaction energy of nonbonded side chains
1453 C assuming the Gay-Berne potential of interaction.
1454 C
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'COMMON.GEO'
1458       include 'COMMON.VAR'
1459       include 'COMMON.LOCAL'
1460       include 'COMMON.CHAIN'
1461       include 'COMMON.DERIV'
1462       include 'COMMON.NAMES'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.IOUNITS'
1465       include 'COMMON.CALC'
1466       include 'COMMON.CONTROL'
1467       include 'COMMON.SPLITELE'
1468       include 'COMMON.SBRIDGE'
1469       logical lprn
1470       integer xshift,yshift,zshift
1471       evdw=0.0D0
1472 ccccc      energy_dec=.false.
1473 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1474       evdw=0.0D0
1475       lprn=.false.
1476 c     if (icall.eq.0) lprn=.false.
1477       ind=0
1478 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1479 C we have the original box)
1480 C      do xshift=-1,1
1481 C      do yshift=-1,1
1482 C      do zshift=-1,1
1483       do i=iatsc_s,iatsc_e
1484         itypi=iabs(itype(i))
1485         if (itypi.eq.ntyp1) cycle
1486         itypi1=iabs(itype(i+1))
1487         xi=c(1,nres+i)
1488         yi=c(2,nres+i)
1489         zi=c(3,nres+i)
1490 C Return atom into box, boxxsize is size of box in x dimension
1491 c  134   continue
1492 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1493 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1494 C Condition for being inside the proper box
1495 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1496 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1497 c        go to 134
1498 c        endif
1499 c  135   continue
1500 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1501 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1502 C Condition for being inside the proper box
1503 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1504 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1505 c        go to 135
1506 c        endif
1507 c  136   continue
1508 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1509 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1510 C Condition for being inside the proper box
1511 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1512 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1513 c        go to 136
1514 c        endif
1515           xi=mod(xi,boxxsize)
1516           if (xi.lt.0) xi=xi+boxxsize
1517           yi=mod(yi,boxysize)
1518           if (yi.lt.0) yi=yi+boxysize
1519           zi=mod(zi,boxzsize)
1520           if (zi.lt.0) zi=zi+boxzsize
1521 C define scaling factor for lipids
1522
1523 C        if (positi.le.0) positi=positi+boxzsize
1524 C        print *,i
1525 C first for peptide groups
1526 c for each residue check if it is in lipid or lipid water border area
1527        if ((zi.gt.bordlipbot)
1528      &.and.(zi.lt.bordliptop)) then
1529 C the energy transfer exist
1530         if (zi.lt.buflipbot) then
1531 C what fraction I am in
1532          fracinbuf=1.0d0-
1533      &        ((zi-bordlipbot)/lipbufthick)
1534 C lipbufthick is thickenes of lipid buffore
1535          sslipi=sscalelip(fracinbuf)
1536          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1537         elseif (zi.gt.bufliptop) then
1538          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1539          sslipi=sscalelip(fracinbuf)
1540          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1541         else
1542          sslipi=1.0d0
1543          ssgradlipi=0.0
1544         endif
1545        else
1546          sslipi=0.0d0
1547          ssgradlipi=0.0
1548        endif
1549
1550 C          xi=xi+xshift*boxxsize
1551 C          yi=yi+yshift*boxysize
1552 C          zi=zi+zshift*boxzsize
1553
1554         dxi=dc_norm(1,nres+i)
1555         dyi=dc_norm(2,nres+i)
1556         dzi=dc_norm(3,nres+i)
1557 c        dsci_inv=dsc_inv(itypi)
1558         dsci_inv=vbld_inv(i+nres)
1559 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1560 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1561 C
1562 C Calculate SC interaction energy.
1563 C
1564         do iint=1,nint_gr(i)
1565           do j=istart(i,iint),iend(i,iint)
1566             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1567               call dyn_ssbond_ene(i,j,evdwij)
1568               evdw=evdw+evdwij
1569               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1570      &                        'evdw',i,j,evdwij,' ss'
1571             ELSE
1572             ind=ind+1
1573             itypj=iabs(itype(j))
1574             if (itypj.eq.ntyp1) cycle
1575 c            dscj_inv=dsc_inv(itypj)
1576             dscj_inv=vbld_inv(j+nres)
1577 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1578 c     &       1.0d0/vbld(j+nres)
1579 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1580             sig0ij=sigma(itypi,itypj)
1581             chi1=chi(itypi,itypj)
1582             chi2=chi(itypj,itypi)
1583             chi12=chi1*chi2
1584             chip1=chip(itypi)
1585             chip2=chip(itypj)
1586             chip12=chip1*chip2
1587             alf1=alp(itypi)
1588             alf2=alp(itypj)
1589             alf12=0.5D0*(alf1+alf2)
1590 C For diagnostics only!!!
1591 c           chi1=0.0D0
1592 c           chi2=0.0D0
1593 c           chi12=0.0D0
1594 c           chip1=0.0D0
1595 c           chip2=0.0D0
1596 c           chip12=0.0D0
1597 c           alf1=0.0D0
1598 c           alf2=0.0D0
1599 c           alf12=0.0D0
1600             xj=c(1,nres+j)
1601             yj=c(2,nres+j)
1602             zj=c(3,nres+j)
1603 C Return atom J into box the original box
1604 c  137   continue
1605 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1606 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1607 C Condition for being inside the proper box
1608 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1609 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1610 c        go to 137
1611 c        endif
1612 c  138   continue
1613 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1614 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1615 C Condition for being inside the proper box
1616 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1617 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1618 c        go to 138
1619 c        endif
1620 c  139   continue
1621 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1622 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1623 C Condition for being inside the proper box
1624 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1625 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1626 c        go to 139
1627 c        endif
1628           xj=mod(xj,boxxsize)
1629           if (xj.lt.0) xj=xj+boxxsize
1630           yj=mod(yj,boxysize)
1631           if (yj.lt.0) yj=yj+boxysize
1632           zj=mod(zj,boxzsize)
1633           if (zj.lt.0) zj=zj+boxzsize
1634        if ((zj.gt.bordlipbot)
1635      &.and.(zj.lt.bordliptop)) then
1636 C the energy transfer exist
1637         if (zj.lt.buflipbot) then
1638 C what fraction I am in
1639          fracinbuf=1.0d0-
1640      &        ((zj-bordlipbot)/lipbufthick)
1641 C lipbufthick is thickenes of lipid buffore
1642          sslipj=sscalelip(fracinbuf)
1643          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1644         elseif (zj.gt.bufliptop) then
1645          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1646          sslipj=sscalelip(fracinbuf)
1647          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1648         else
1649          sslipj=1.0d0
1650          ssgradlipj=0.0
1651         endif
1652        else
1653          sslipj=0.0d0
1654          ssgradlipj=0.0
1655        endif
1656       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1657      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1658       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1659      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1660 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1661 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1662 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1663 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1664       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1665       xj_safe=xj
1666       yj_safe=yj
1667       zj_safe=zj
1668       subchap=0
1669       do xshift=-1,1
1670       do yshift=-1,1
1671       do zshift=-1,1
1672           xj=xj_safe+xshift*boxxsize
1673           yj=yj_safe+yshift*boxysize
1674           zj=zj_safe+zshift*boxzsize
1675           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1676           if(dist_temp.lt.dist_init) then
1677             dist_init=dist_temp
1678             xj_temp=xj
1679             yj_temp=yj
1680             zj_temp=zj
1681             subchap=1
1682           endif
1683        enddo
1684        enddo
1685        enddo
1686        if (subchap.eq.1) then
1687           xj=xj_temp-xi
1688           yj=yj_temp-yi
1689           zj=zj_temp-zi
1690        else
1691           xj=xj_safe-xi
1692           yj=yj_safe-yi
1693           zj=zj_safe-zi
1694        endif
1695             dxj=dc_norm(1,nres+j)
1696             dyj=dc_norm(2,nres+j)
1697             dzj=dc_norm(3,nres+j)
1698 C            xj=xj-xi
1699 C            yj=yj-yi
1700 C            zj=zj-zi
1701 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1702 c            write (iout,*) "j",j," dc_norm",
1703 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1704             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1705             rij=dsqrt(rrij)
1706             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1707             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1708
1709 c            write (iout,'(a7,4f8.3)')
1710 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1711             if (sss.gt.0.0d0) then
1712 C Calculate angle-dependent terms of energy and contributions to their
1713 C derivatives.
1714             call sc_angular
1715             sigsq=1.0D0/sigsq
1716             sig=sig0ij*dsqrt(sigsq)
1717             rij_shift=1.0D0/rij-sig+sig0ij
1718 c for diagnostics; uncomment
1719 c            rij_shift=1.2*sig0ij
1720 C I hate to put IF's in the loops, but here don't have another choice!!!!
1721             if (rij_shift.le.0.0D0) then
1722               evdw=1.0D20
1723 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1724 cd     &        restyp(itypi),i,restyp(itypj),j,
1725 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1726               return
1727             endif
1728             sigder=-sig*sigsq
1729 c---------------------------------------------------------------
1730             rij_shift=1.0D0/rij_shift
1731             fac=rij_shift**expon
1732 C here to start with
1733 C            if (c(i,3).gt.
1734             faclip=fac
1735             e1=fac*fac*aa
1736             e2=fac*bb
1737             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1738             eps2der=evdwij*eps3rt
1739             eps3der=evdwij*eps2rt
1740 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1741 C     &((sslipi+sslipj)/2.0d0+
1742 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1743 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1744 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1745             evdwij=evdwij*eps2rt*eps3rt
1746             evdw=evdw+evdwij*sss
1747             if (lprn) then
1748             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1749             epsi=bb**2/aa
1750             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1751      &        restyp(itypi),i,restyp(itypj),j,
1752      &        epsi,sigm,chi1,chi2,chip1,chip2,
1753      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1754      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1755      &        evdwij
1756             endif
1757
1758             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1759      &                        'evdw',i,j,evdwij
1760
1761 C Calculate gradient components.
1762             e1=e1*eps1*eps2rt**2*eps3rt**2
1763             fac=-expon*(e1+evdwij)*rij_shift
1764             sigder=fac*sigder
1765             fac=rij*fac
1766 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1767 c     &      evdwij,fac,sigma(itypi,itypj),expon
1768             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1769 c            fac=0.0d0
1770 C Calculate the radial part of the gradient
1771             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1772      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1773      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1774      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1775             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1776             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1777 C            gg_lipi(3)=0.0d0
1778 C            gg_lipj(3)=0.0d0
1779             gg(1)=xj*fac
1780             gg(2)=yj*fac
1781             gg(3)=zj*fac
1782 C Calculate angular part of the gradient.
1783             call sc_grad
1784             endif
1785             ENDIF    ! dyn_ss
1786           enddo      ! j
1787         enddo        ! iint
1788       enddo          ! i
1789 C      enddo          ! zshift
1790 C      enddo          ! yshift
1791 C      enddo          ! xshift
1792 c      write (iout,*) "Number of loop steps in EGB:",ind
1793 cccc      energy_dec=.false.
1794       return
1795       end
1796 C-----------------------------------------------------------------------------
1797       subroutine egbv(evdw)
1798 C
1799 C This subroutine calculates the interaction energy of nonbonded side chains
1800 C assuming the Gay-Berne-Vorobjev potential of interaction.
1801 C
1802       implicit real*8 (a-h,o-z)
1803       include 'DIMENSIONS'
1804       include 'COMMON.GEO'
1805       include 'COMMON.VAR'
1806       include 'COMMON.LOCAL'
1807       include 'COMMON.CHAIN'
1808       include 'COMMON.DERIV'
1809       include 'COMMON.NAMES'
1810       include 'COMMON.INTERACT'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CALC'
1813       common /srutu/ icall
1814       logical lprn
1815       evdw=0.0D0
1816 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1817       evdw=0.0D0
1818       lprn=.false.
1819 c     if (icall.eq.0) lprn=.true.
1820       ind=0
1821       do i=iatsc_s,iatsc_e
1822         itypi=iabs(itype(i))
1823         if (itypi.eq.ntyp1) cycle
1824         itypi1=iabs(itype(i+1))
1825         xi=c(1,nres+i)
1826         yi=c(2,nres+i)
1827         zi=c(3,nres+i)
1828           xi=mod(xi,boxxsize)
1829           if (xi.lt.0) xi=xi+boxxsize
1830           yi=mod(yi,boxysize)
1831           if (yi.lt.0) yi=yi+boxysize
1832           zi=mod(zi,boxzsize)
1833           if (zi.lt.0) zi=zi+boxzsize
1834 C define scaling factor for lipids
1835
1836 C        if (positi.le.0) positi=positi+boxzsize
1837 C        print *,i
1838 C first for peptide groups
1839 c for each residue check if it is in lipid or lipid water border area
1840        if ((zi.gt.bordlipbot)
1841      &.and.(zi.lt.bordliptop)) then
1842 C the energy transfer exist
1843         if (zi.lt.buflipbot) then
1844 C what fraction I am in
1845          fracinbuf=1.0d0-
1846      &        ((zi-bordlipbot)/lipbufthick)
1847 C lipbufthick is thickenes of lipid buffore
1848          sslipi=sscalelip(fracinbuf)
1849          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1850         elseif (zi.gt.bufliptop) then
1851          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1852          sslipi=sscalelip(fracinbuf)
1853          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1854         else
1855          sslipi=1.0d0
1856          ssgradlipi=0.0
1857         endif
1858        else
1859          sslipi=0.0d0
1860          ssgradlipi=0.0
1861        endif
1862
1863         dxi=dc_norm(1,nres+i)
1864         dyi=dc_norm(2,nres+i)
1865         dzi=dc_norm(3,nres+i)
1866 c        dsci_inv=dsc_inv(itypi)
1867         dsci_inv=vbld_inv(i+nres)
1868 C
1869 C Calculate SC interaction energy.
1870 C
1871         do iint=1,nint_gr(i)
1872           do j=istart(i,iint),iend(i,iint)
1873             ind=ind+1
1874             itypj=iabs(itype(j))
1875             if (itypj.eq.ntyp1) cycle
1876 c            dscj_inv=dsc_inv(itypj)
1877             dscj_inv=vbld_inv(j+nres)
1878             sig0ij=sigma(itypi,itypj)
1879             r0ij=r0(itypi,itypj)
1880             chi1=chi(itypi,itypj)
1881             chi2=chi(itypj,itypi)
1882             chi12=chi1*chi2
1883             chip1=chip(itypi)
1884             chip2=chip(itypj)
1885             chip12=chip1*chip2
1886             alf1=alp(itypi)
1887             alf2=alp(itypj)
1888             alf12=0.5D0*(alf1+alf2)
1889 C For diagnostics only!!!
1890 c           chi1=0.0D0
1891 c           chi2=0.0D0
1892 c           chi12=0.0D0
1893 c           chip1=0.0D0
1894 c           chip2=0.0D0
1895 c           chip12=0.0D0
1896 c           alf1=0.0D0
1897 c           alf2=0.0D0
1898 c           alf12=0.0D0
1899 C            xj=c(1,nres+j)-xi
1900 C            yj=c(2,nres+j)-yi
1901 C            zj=c(3,nres+j)-zi
1902           xj=mod(xj,boxxsize)
1903           if (xj.lt.0) xj=xj+boxxsize
1904           yj=mod(yj,boxysize)
1905           if (yj.lt.0) yj=yj+boxysize
1906           zj=mod(zj,boxzsize)
1907           if (zj.lt.0) zj=zj+boxzsize
1908        if ((zj.gt.bordlipbot)
1909      &.and.(zj.lt.bordliptop)) then
1910 C the energy transfer exist
1911         if (zj.lt.buflipbot) then
1912 C what fraction I am in
1913          fracinbuf=1.0d0-
1914      &        ((zj-bordlipbot)/lipbufthick)
1915 C lipbufthick is thickenes of lipid buffore
1916          sslipj=sscalelip(fracinbuf)
1917          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1918         elseif (zj.gt.bufliptop) then
1919          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1920          sslipj=sscalelip(fracinbuf)
1921          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1922         else
1923          sslipj=1.0d0
1924          ssgradlipj=0.0
1925         endif
1926        else
1927          sslipj=0.0d0
1928          ssgradlipj=0.0
1929        endif
1930       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1931      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1932       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1933      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1934 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1935 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1936       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1937       xj_safe=xj
1938       yj_safe=yj
1939       zj_safe=zj
1940       subchap=0
1941       do xshift=-1,1
1942       do yshift=-1,1
1943       do zshift=-1,1
1944           xj=xj_safe+xshift*boxxsize
1945           yj=yj_safe+yshift*boxysize
1946           zj=zj_safe+zshift*boxzsize
1947           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1948           if(dist_temp.lt.dist_init) then
1949             dist_init=dist_temp
1950             xj_temp=xj
1951             yj_temp=yj
1952             zj_temp=zj
1953             subchap=1
1954           endif
1955        enddo
1956        enddo
1957        enddo
1958        if (subchap.eq.1) then
1959           xj=xj_temp-xi
1960           yj=yj_temp-yi
1961           zj=zj_temp-zi
1962        else
1963           xj=xj_safe-xi
1964           yj=yj_safe-yi
1965           zj=zj_safe-zi
1966        endif
1967             dxj=dc_norm(1,nres+j)
1968             dyj=dc_norm(2,nres+j)
1969             dzj=dc_norm(3,nres+j)
1970             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1971             rij=dsqrt(rrij)
1972 C Calculate angle-dependent terms of energy and contributions to their
1973 C derivatives.
1974             call sc_angular
1975             sigsq=1.0D0/sigsq
1976             sig=sig0ij*dsqrt(sigsq)
1977             rij_shift=1.0D0/rij-sig+r0ij
1978 C I hate to put IF's in the loops, but here don't have another choice!!!!
1979             if (rij_shift.le.0.0D0) then
1980               evdw=1.0D20
1981               return
1982             endif
1983             sigder=-sig*sigsq
1984 c---------------------------------------------------------------
1985             rij_shift=1.0D0/rij_shift
1986             fac=rij_shift**expon
1987             e1=fac*fac*aa
1988             e2=fac*bb
1989             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1990             eps2der=evdwij*eps3rt
1991             eps3der=evdwij*eps2rt
1992             fac_augm=rrij**expon
1993             e_augm=augm(itypi,itypj)*fac_augm
1994             evdwij=evdwij*eps2rt*eps3rt
1995             evdw=evdw+evdwij+e_augm
1996             if (lprn) then
1997             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1998             epsi=bb**2/aa
1999             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2000      &        restyp(itypi),i,restyp(itypj),j,
2001      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2002      &        chi1,chi2,chip1,chip2,
2003      &        eps1,eps2rt**2,eps3rt**2,
2004      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2005      &        evdwij+e_augm
2006             endif
2007 C Calculate gradient components.
2008             e1=e1*eps1*eps2rt**2*eps3rt**2
2009             fac=-expon*(e1+evdwij)*rij_shift
2010             sigder=fac*sigder
2011             fac=rij*fac-2*expon*rrij*e_augm
2012             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2013 C Calculate the radial part of the gradient
2014             gg(1)=xj*fac
2015             gg(2)=yj*fac
2016             gg(3)=zj*fac
2017 C Calculate angular part of the gradient.
2018             call sc_grad
2019           enddo      ! j
2020         enddo        ! iint
2021       enddo          ! i
2022       end
2023 C-----------------------------------------------------------------------------
2024       subroutine sc_angular
2025 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2026 C om12. Called by ebp, egb, and egbv.
2027       implicit none
2028       include 'COMMON.CALC'
2029       include 'COMMON.IOUNITS'
2030       erij(1)=xj*rij
2031       erij(2)=yj*rij
2032       erij(3)=zj*rij
2033       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2034       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2035       om12=dxi*dxj+dyi*dyj+dzi*dzj
2036       chiom12=chi12*om12
2037 C Calculate eps1(om12) and its derivative in om12
2038       faceps1=1.0D0-om12*chiom12
2039       faceps1_inv=1.0D0/faceps1
2040       eps1=dsqrt(faceps1_inv)
2041 C Following variable is eps1*deps1/dom12
2042       eps1_om12=faceps1_inv*chiom12
2043 c diagnostics only
2044 c      faceps1_inv=om12
2045 c      eps1=om12
2046 c      eps1_om12=1.0d0
2047 c      write (iout,*) "om12",om12," eps1",eps1
2048 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2049 C and om12.
2050       om1om2=om1*om2
2051       chiom1=chi1*om1
2052       chiom2=chi2*om2
2053       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2054       sigsq=1.0D0-facsig*faceps1_inv
2055       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2056       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2057       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2058 c diagnostics only
2059 c      sigsq=1.0d0
2060 c      sigsq_om1=0.0d0
2061 c      sigsq_om2=0.0d0
2062 c      sigsq_om12=0.0d0
2063 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2064 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2065 c     &    " eps1",eps1
2066 C Calculate eps2 and its derivatives in om1, om2, and om12.
2067       chipom1=chip1*om1
2068       chipom2=chip2*om2
2069       chipom12=chip12*om12
2070       facp=1.0D0-om12*chipom12
2071       facp_inv=1.0D0/facp
2072       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2073 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2074 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2075 C Following variable is the square root of eps2
2076       eps2rt=1.0D0-facp1*facp_inv
2077 C Following three variables are the derivatives of the square root of eps
2078 C in om1, om2, and om12.
2079       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2080       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2081       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2082 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2083       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2084 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2085 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2086 c     &  " eps2rt_om12",eps2rt_om12
2087 C Calculate whole angle-dependent part of epsilon and contributions
2088 C to its derivatives
2089       return
2090       end
2091 C----------------------------------------------------------------------------
2092       subroutine sc_grad
2093       implicit real*8 (a-h,o-z)
2094       include 'DIMENSIONS'
2095       include 'COMMON.CHAIN'
2096       include 'COMMON.DERIV'
2097       include 'COMMON.CALC'
2098       include 'COMMON.IOUNITS'
2099       double precision dcosom1(3),dcosom2(3)
2100 cc      print *,'sss=',sss
2101       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2102       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2103       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2104      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2105 c diagnostics only
2106 c      eom1=0.0d0
2107 c      eom2=0.0d0
2108 c      eom12=evdwij*eps1_om12
2109 c end diagnostics
2110 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2111 c     &  " sigder",sigder
2112 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2113 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2114       do k=1,3
2115         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2116         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2117       enddo
2118       do k=1,3
2119         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2120       enddo
2121 c      write (iout,*) "gg",(gg(k),k=1,3)
2122       do k=1,3
2123         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2124      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2125      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2126         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2127      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2128      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2129 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2130 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2131 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2132 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2133       enddo
2134 C
2135 C Calculate the components of the gradient in DC and X
2136 C
2137 cgrad      do k=i,j-1
2138 cgrad        do l=1,3
2139 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2140 cgrad        enddo
2141 cgrad      enddo
2142       do l=1,3
2143         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2144         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2145       enddo
2146       return
2147       end
2148 C-----------------------------------------------------------------------
2149       subroutine e_softsphere(evdw)
2150 C
2151 C This subroutine calculates the interaction energy of nonbonded side chains
2152 C assuming the LJ potential of interaction.
2153 C
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       parameter (accur=1.0d-10)
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.DERIV'
2162       include 'COMMON.INTERACT'
2163       include 'COMMON.TORSION'
2164       include 'COMMON.SBRIDGE'
2165       include 'COMMON.NAMES'
2166       include 'COMMON.IOUNITS'
2167       include 'COMMON.CONTACTS'
2168       dimension gg(3)
2169 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2170       evdw=0.0D0
2171       do i=iatsc_s,iatsc_e
2172         itypi=iabs(itype(i))
2173         if (itypi.eq.ntyp1) cycle
2174         itypi1=iabs(itype(i+1))
2175         xi=c(1,nres+i)
2176         yi=c(2,nres+i)
2177         zi=c(3,nres+i)
2178 C
2179 C Calculate SC interaction energy.
2180 C
2181         do iint=1,nint_gr(i)
2182 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2183 cd   &                  'iend=',iend(i,iint)
2184           do j=istart(i,iint),iend(i,iint)
2185             itypj=iabs(itype(j))
2186             if (itypj.eq.ntyp1) cycle
2187             xj=c(1,nres+j)-xi
2188             yj=c(2,nres+j)-yi
2189             zj=c(3,nres+j)-zi
2190             rij=xj*xj+yj*yj+zj*zj
2191 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2192             r0ij=r0(itypi,itypj)
2193             r0ijsq=r0ij*r0ij
2194 c            print *,i,j,r0ij,dsqrt(rij)
2195             if (rij.lt.r0ijsq) then
2196               evdwij=0.25d0*(rij-r0ijsq)**2
2197               fac=rij-r0ijsq
2198             else
2199               evdwij=0.0d0
2200               fac=0.0d0
2201             endif
2202             evdw=evdw+evdwij
2203 C
2204 C Calculate the components of the gradient in DC and X
2205 C
2206             gg(1)=xj*fac
2207             gg(2)=yj*fac
2208             gg(3)=zj*fac
2209             do k=1,3
2210               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2211               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2212               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2213               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2214             enddo
2215 cgrad            do k=i,j-1
2216 cgrad              do l=1,3
2217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2218 cgrad              enddo
2219 cgrad            enddo
2220           enddo ! j
2221         enddo ! iint
2222       enddo ! i
2223       return
2224       end
2225 C--------------------------------------------------------------------------
2226       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2227      &              eello_turn4)
2228 C
2229 C Soft-sphere potential of p-p interaction
2230 C
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233       include 'COMMON.CONTROL'
2234       include 'COMMON.IOUNITS'
2235       include 'COMMON.GEO'
2236       include 'COMMON.VAR'
2237       include 'COMMON.LOCAL'
2238       include 'COMMON.CHAIN'
2239       include 'COMMON.DERIV'
2240       include 'COMMON.INTERACT'
2241       include 'COMMON.CONTACTS'
2242       include 'COMMON.TORSION'
2243       include 'COMMON.VECTORS'
2244       include 'COMMON.FFIELD'
2245       dimension ggg(3)
2246 C      write(iout,*) 'In EELEC_soft_sphere'
2247       ees=0.0D0
2248       evdw1=0.0D0
2249       eel_loc=0.0d0
2250       eello_turn3=0.0d0
2251       eello_turn4=0.0d0
2252       ind=0
2253       do i=iatel_s,iatel_e
2254         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2255         dxi=dc(1,i)
2256         dyi=dc(2,i)
2257         dzi=dc(3,i)
2258         xmedi=c(1,i)+0.5d0*dxi
2259         ymedi=c(2,i)+0.5d0*dyi
2260         zmedi=c(3,i)+0.5d0*dzi
2261           xmedi=mod(xmedi,boxxsize)
2262           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2263           ymedi=mod(ymedi,boxysize)
2264           if (ymedi.lt.0) ymedi=ymedi+boxysize
2265           zmedi=mod(zmedi,boxzsize)
2266           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2267         num_conti=0
2268 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2269         do j=ielstart(i),ielend(i)
2270           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2271           ind=ind+1
2272           iteli=itel(i)
2273           itelj=itel(j)
2274           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2275           r0ij=rpp(iteli,itelj)
2276           r0ijsq=r0ij*r0ij
2277           dxj=dc(1,j)
2278           dyj=dc(2,j)
2279           dzj=dc(3,j)
2280           xj=c(1,j)+0.5D0*dxj
2281           yj=c(2,j)+0.5D0*dyj
2282           zj=c(3,j)+0.5D0*dzj
2283           xj=mod(xj,boxxsize)
2284           if (xj.lt.0) xj=xj+boxxsize
2285           yj=mod(yj,boxysize)
2286           if (yj.lt.0) yj=yj+boxysize
2287           zj=mod(zj,boxzsize)
2288           if (zj.lt.0) zj=zj+boxzsize
2289       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2290       xj_safe=xj
2291       yj_safe=yj
2292       zj_safe=zj
2293       isubchap=0
2294       do xshift=-1,1
2295       do yshift=-1,1
2296       do zshift=-1,1
2297           xj=xj_safe+xshift*boxxsize
2298           yj=yj_safe+yshift*boxysize
2299           zj=zj_safe+zshift*boxzsize
2300           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2301           if(dist_temp.lt.dist_init) then
2302             dist_init=dist_temp
2303             xj_temp=xj
2304             yj_temp=yj
2305             zj_temp=zj
2306             isubchap=1
2307           endif
2308        enddo
2309        enddo
2310        enddo
2311        if (isubchap.eq.1) then
2312           xj=xj_temp-xmedi
2313           yj=yj_temp-ymedi
2314           zj=zj_temp-zmedi
2315        else
2316           xj=xj_safe-xmedi
2317           yj=yj_safe-ymedi
2318           zj=zj_safe-zmedi
2319        endif
2320           rij=xj*xj+yj*yj+zj*zj
2321             sss=sscale(sqrt(rij))
2322             sssgrad=sscagrad(sqrt(rij))
2323           if (rij.lt.r0ijsq) then
2324             evdw1ij=0.25d0*(rij-r0ijsq)**2
2325             fac=rij-r0ijsq
2326           else
2327             evdw1ij=0.0d0
2328             fac=0.0d0
2329           endif
2330           evdw1=evdw1+evdw1ij*sss
2331 C
2332 C Calculate contributions to the Cartesian gradient.
2333 C
2334           ggg(1)=fac*xj*sssgrad
2335           ggg(2)=fac*yj*sssgrad
2336           ggg(3)=fac*zj*sssgrad
2337           do k=1,3
2338             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2339             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2340           enddo
2341 *
2342 * Loop over residues i+1 thru j-1.
2343 *
2344 cgrad          do k=i+1,j-1
2345 cgrad            do l=1,3
2346 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2347 cgrad            enddo
2348 cgrad          enddo
2349         enddo ! j
2350       enddo   ! i
2351 cgrad      do i=nnt,nct-1
2352 cgrad        do k=1,3
2353 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2354 cgrad        enddo
2355 cgrad        do j=i+1,nct-1
2356 cgrad          do k=1,3
2357 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2358 cgrad          enddo
2359 cgrad        enddo
2360 cgrad      enddo
2361       return
2362       end
2363 c------------------------------------------------------------------------------
2364       subroutine vec_and_deriv
2365       implicit real*8 (a-h,o-z)
2366       include 'DIMENSIONS'
2367 #ifdef MPI
2368       include 'mpif.h'
2369 #endif
2370       include 'COMMON.IOUNITS'
2371       include 'COMMON.GEO'
2372       include 'COMMON.VAR'
2373       include 'COMMON.LOCAL'
2374       include 'COMMON.CHAIN'
2375       include 'COMMON.VECTORS'
2376       include 'COMMON.SETUP'
2377       include 'COMMON.TIME1'
2378       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2379 C Compute the local reference systems. For reference system (i), the
2380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2382 #ifdef PARVEC
2383       do i=ivec_start,ivec_end
2384 #else
2385       do i=1,nres-1
2386 #endif
2387           if (i.eq.nres-1) then
2388 C Case of the last full residue
2389 C Compute the Z-axis
2390             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2391             costh=dcos(pi-theta(nres))
2392             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2393             do k=1,3
2394               uz(k,i)=fac*uz(k,i)
2395             enddo
2396 C Compute the derivatives of uz
2397             uzder(1,1,1)= 0.0d0
2398             uzder(2,1,1)=-dc_norm(3,i-1)
2399             uzder(3,1,1)= dc_norm(2,i-1)
2400             uzder(1,2,1)= dc_norm(3,i-1)
2401             uzder(2,2,1)= 0.0d0
2402             uzder(3,2,1)=-dc_norm(1,i-1)
2403             uzder(1,3,1)=-dc_norm(2,i-1)
2404             uzder(2,3,1)= dc_norm(1,i-1)
2405             uzder(3,3,1)= 0.0d0
2406             uzder(1,1,2)= 0.0d0
2407             uzder(2,1,2)= dc_norm(3,i)
2408             uzder(3,1,2)=-dc_norm(2,i)
2409             uzder(1,2,2)=-dc_norm(3,i)
2410             uzder(2,2,2)= 0.0d0
2411             uzder(3,2,2)= dc_norm(1,i)
2412             uzder(1,3,2)= dc_norm(2,i)
2413             uzder(2,3,2)=-dc_norm(1,i)
2414             uzder(3,3,2)= 0.0d0
2415 C Compute the Y-axis
2416             facy=fac
2417             do k=1,3
2418               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2419             enddo
2420 C Compute the derivatives of uy
2421             do j=1,3
2422               do k=1,3
2423                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2424      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2425                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2426               enddo
2427               uyder(j,j,1)=uyder(j,j,1)-costh
2428               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2429             enddo
2430             do j=1,2
2431               do k=1,3
2432                 do l=1,3
2433                   uygrad(l,k,j,i)=uyder(l,k,j)
2434                   uzgrad(l,k,j,i)=uzder(l,k,j)
2435                 enddo
2436               enddo
2437             enddo
2438             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2439             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2440             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2441             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2442           else
2443 C Other residues
2444 C Compute the Z-axis
2445             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2446             costh=dcos(pi-theta(i+2))
2447             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2448             do k=1,3
2449               uz(k,i)=fac*uz(k,i)
2450             enddo
2451 C Compute the derivatives of uz
2452             uzder(1,1,1)= 0.0d0
2453             uzder(2,1,1)=-dc_norm(3,i+1)
2454             uzder(3,1,1)= dc_norm(2,i+1)
2455             uzder(1,2,1)= dc_norm(3,i+1)
2456             uzder(2,2,1)= 0.0d0
2457             uzder(3,2,1)=-dc_norm(1,i+1)
2458             uzder(1,3,1)=-dc_norm(2,i+1)
2459             uzder(2,3,1)= dc_norm(1,i+1)
2460             uzder(3,3,1)= 0.0d0
2461             uzder(1,1,2)= 0.0d0
2462             uzder(2,1,2)= dc_norm(3,i)
2463             uzder(3,1,2)=-dc_norm(2,i)
2464             uzder(1,2,2)=-dc_norm(3,i)
2465             uzder(2,2,2)= 0.0d0
2466             uzder(3,2,2)= dc_norm(1,i)
2467             uzder(1,3,2)= dc_norm(2,i)
2468             uzder(2,3,2)=-dc_norm(1,i)
2469             uzder(3,3,2)= 0.0d0
2470 C Compute the Y-axis
2471             facy=fac
2472             do k=1,3
2473               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2474             enddo
2475 C Compute the derivatives of uy
2476             do j=1,3
2477               do k=1,3
2478                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2479      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2480                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2481               enddo
2482               uyder(j,j,1)=uyder(j,j,1)-costh
2483               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2484             enddo
2485             do j=1,2
2486               do k=1,3
2487                 do l=1,3
2488                   uygrad(l,k,j,i)=uyder(l,k,j)
2489                   uzgrad(l,k,j,i)=uzder(l,k,j)
2490                 enddo
2491               enddo
2492             enddo
2493             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2494             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2495             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2496             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2497           endif
2498       enddo
2499       do i=1,nres-1
2500         vbld_inv_temp(1)=vbld_inv(i+1)
2501         if (i.lt.nres-1) then
2502           vbld_inv_temp(2)=vbld_inv(i+2)
2503           else
2504           vbld_inv_temp(2)=vbld_inv(i)
2505           endif
2506         do j=1,2
2507           do k=1,3
2508             do l=1,3
2509               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2510               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2511             enddo
2512           enddo
2513         enddo
2514       enddo
2515 #if defined(PARVEC) && defined(MPI)
2516       if (nfgtasks1.gt.1) then
2517         time00=MPI_Wtime()
2518 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2519 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2520 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2521         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2528      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2529      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2530         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2531      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2532      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2533         time_gather=time_gather+MPI_Wtime()-time00
2534       endif
2535 c      if (fg_rank.eq.0) then
2536 c        write (iout,*) "Arrays UY and UZ"
2537 c        do i=1,nres-1
2538 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2539 c     &     (uz(k,i),k=1,3)
2540 c        enddo
2541 c      endif
2542 #endif
2543       return
2544       end
2545 C-----------------------------------------------------------------------------
2546       subroutine check_vecgrad
2547       implicit real*8 (a-h,o-z)
2548       include 'DIMENSIONS'
2549       include 'COMMON.IOUNITS'
2550       include 'COMMON.GEO'
2551       include 'COMMON.VAR'
2552       include 'COMMON.LOCAL'
2553       include 'COMMON.CHAIN'
2554       include 'COMMON.VECTORS'
2555       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2556       dimension uyt(3,maxres),uzt(3,maxres)
2557       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2558       double precision delta /1.0d-7/
2559       call vec_and_deriv
2560 cd      do i=1,nres
2561 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2562 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2563 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2564 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2565 cd     &     (dc_norm(if90,i),if90=1,3)
2566 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2567 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2568 cd          write(iout,'(a)')
2569 cd      enddo
2570       do i=1,nres
2571         do j=1,2
2572           do k=1,3
2573             do l=1,3
2574               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2575               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2576             enddo
2577           enddo
2578         enddo
2579       enddo
2580       call vec_and_deriv
2581       do i=1,nres
2582         do j=1,3
2583           uyt(j,i)=uy(j,i)
2584           uzt(j,i)=uz(j,i)
2585         enddo
2586       enddo
2587       do i=1,nres
2588 cd        write (iout,*) 'i=',i
2589         do k=1,3
2590           erij(k)=dc_norm(k,i)
2591         enddo
2592         do j=1,3
2593           do k=1,3
2594             dc_norm(k,i)=erij(k)
2595           enddo
2596           dc_norm(j,i)=dc_norm(j,i)+delta
2597 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2598 c          do k=1,3
2599 c            dc_norm(k,i)=dc_norm(k,i)/fac
2600 c          enddo
2601 c          write (iout,*) (dc_norm(k,i),k=1,3)
2602 c          write (iout,*) (erij(k),k=1,3)
2603           call vec_and_deriv
2604           do k=1,3
2605             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2606             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2607             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2608             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2609           enddo
2610 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2611 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2612 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2613         enddo
2614         do k=1,3
2615           dc_norm(k,i)=erij(k)
2616         enddo
2617 cd        do k=1,3
2618 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2619 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2620 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2621 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2622 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2623 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2624 cd          write (iout,'(a)')
2625 cd        enddo
2626       enddo
2627       return
2628       end
2629 C--------------------------------------------------------------------------
2630       subroutine set_matrices
2631       implicit real*8 (a-h,o-z)
2632       include 'DIMENSIONS'
2633 #ifdef MPI
2634       include "mpif.h"
2635       include "COMMON.SETUP"
2636       integer IERR
2637       integer status(MPI_STATUS_SIZE)
2638 #endif
2639       include 'COMMON.IOUNITS'
2640       include 'COMMON.GEO'
2641       include 'COMMON.VAR'
2642       include 'COMMON.LOCAL'
2643       include 'COMMON.CHAIN'
2644       include 'COMMON.DERIV'
2645       include 'COMMON.INTERACT'
2646       include 'COMMON.CONTACTS'
2647       include 'COMMON.TORSION'
2648       include 'COMMON.VECTORS'
2649       include 'COMMON.FFIELD'
2650       double precision auxvec(2),auxmat(2,2)
2651 C
2652 C Compute the virtual-bond-torsional-angle dependent quantities needed
2653 C to calculate the el-loc multibody terms of various order.
2654 C
2655 c      write(iout,*) 'nphi=',nphi,nres
2656 #ifdef PARMAT
2657       do i=ivec_start+2,ivec_end+2
2658 #else
2659       do i=3,nres+1
2660 #endif
2661 #ifdef NEWCORR
2662         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2663           iti = itortyp(itype(i-2))
2664         else
2665           iti=ntortyp+1
2666         endif
2667 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2668         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2669           iti1 = itortyp(itype(i-1))
2670         else
2671           iti1=ntortyp+1
2672         endif
2673 c        write(iout,*),i
2674         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2675      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2676      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2677         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2678      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2679      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2680 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2681 c     &*(cos(theta(i)/2.0)
2682         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2683      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2684      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2685 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2686 c     &*(cos(theta(i)/2.0)
2687         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2688      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2689      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2690 c        if (ggb1(1,i).eq.0.0d0) then
2691 c        write(iout,*) 'i=',i,ggb1(1,i),
2692 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2693 c     &bnew1(2,1,iti)*cos(theta(i)),
2694 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2695 c        endif
2696         b1(2,i-2)=bnew1(1,2,iti)
2697         gtb1(2,i-2)=0.0
2698         b2(2,i-2)=bnew2(1,2,iti)
2699         gtb2(2,i-2)=0.0
2700         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2701         EE(1,2,i-2)=eeold(1,2,iti)
2702         EE(2,1,i-2)=eeold(2,1,iti)
2703         EE(2,2,i-2)=eeold(2,2,iti)
2704         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2705         gtEE(1,2,i-2)=0.0d0
2706         gtEE(2,2,i-2)=0.0d0
2707         gtEE(2,1,i-2)=0.0d0
2708 c        EE(2,2,iti)=0.0d0
2709 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2710 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2711 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2712 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2713        b1tilde(1,i-2)=b1(1,i-2)
2714        b1tilde(2,i-2)=-b1(2,i-2)
2715        b2tilde(1,i-2)=b2(1,i-2)
2716        b2tilde(2,i-2)=-b2(2,i-2)
2717 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2718 c       write(iout,*)  'b1=',b1(1,i-2)
2719 c       write (iout,*) 'theta=', theta(i-1)
2720        enddo
2721 #else
2722         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2723           iti = itortyp(itype(i-2))
2724         else
2725           iti=ntortyp+1
2726         endif
2727 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2728         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2729           iti1 = itortyp(itype(i-1))
2730         else
2731           iti1=ntortyp+1
2732         endif
2733         b1(1,i-2)=b(3,iti)
2734         b1(2,i-2)=b(5,iti)
2735         b2(1,i-2)=b(2,iti)
2736         b2(2,i-2)=b(4,iti)
2737        b1tilde(1,i-2)=b1(1,i-2)
2738        b1tilde(2,i-2)=-b1(2,i-2)
2739        b2tilde(1,i-2)=b2(1,i-2)
2740        b2tilde(2,i-2)=-b2(2,i-2)
2741         EE(1,2,i-2)=eeold(1,2,iti)
2742         EE(2,1,i-2)=eeold(2,1,iti)
2743         EE(2,2,i-2)=eeold(2,2,iti)
2744         EE(1,1,i-2)=eeold(1,1,iti)
2745       enddo
2746 #endif
2747 #ifdef PARMAT
2748       do i=ivec_start+2,ivec_end+2
2749 #else
2750       do i=3,nres+1
2751 #endif
2752         if (i .lt. nres+1) then
2753           sin1=dsin(phi(i))
2754           cos1=dcos(phi(i))
2755           sintab(i-2)=sin1
2756           costab(i-2)=cos1
2757           obrot(1,i-2)=cos1
2758           obrot(2,i-2)=sin1
2759           sin2=dsin(2*phi(i))
2760           cos2=dcos(2*phi(i))
2761           sintab2(i-2)=sin2
2762           costab2(i-2)=cos2
2763           obrot2(1,i-2)=cos2
2764           obrot2(2,i-2)=sin2
2765           Ug(1,1,i-2)=-cos1
2766           Ug(1,2,i-2)=-sin1
2767           Ug(2,1,i-2)=-sin1
2768           Ug(2,2,i-2)= cos1
2769           Ug2(1,1,i-2)=-cos2
2770           Ug2(1,2,i-2)=-sin2
2771           Ug2(2,1,i-2)=-sin2
2772           Ug2(2,2,i-2)= cos2
2773         else
2774           costab(i-2)=1.0d0
2775           sintab(i-2)=0.0d0
2776           obrot(1,i-2)=1.0d0
2777           obrot(2,i-2)=0.0d0
2778           obrot2(1,i-2)=0.0d0
2779           obrot2(2,i-2)=0.0d0
2780           Ug(1,1,i-2)=1.0d0
2781           Ug(1,2,i-2)=0.0d0
2782           Ug(2,1,i-2)=0.0d0
2783           Ug(2,2,i-2)=1.0d0
2784           Ug2(1,1,i-2)=0.0d0
2785           Ug2(1,2,i-2)=0.0d0
2786           Ug2(2,1,i-2)=0.0d0
2787           Ug2(2,2,i-2)=0.0d0
2788         endif
2789         if (i .gt. 3 .and. i .lt. nres+1) then
2790           obrot_der(1,i-2)=-sin1
2791           obrot_der(2,i-2)= cos1
2792           Ugder(1,1,i-2)= sin1
2793           Ugder(1,2,i-2)=-cos1
2794           Ugder(2,1,i-2)=-cos1
2795           Ugder(2,2,i-2)=-sin1
2796           dwacos2=cos2+cos2
2797           dwasin2=sin2+sin2
2798           obrot2_der(1,i-2)=-dwasin2
2799           obrot2_der(2,i-2)= dwacos2
2800           Ug2der(1,1,i-2)= dwasin2
2801           Ug2der(1,2,i-2)=-dwacos2
2802           Ug2der(2,1,i-2)=-dwacos2
2803           Ug2der(2,2,i-2)=-dwasin2
2804         else
2805           obrot_der(1,i-2)=0.0d0
2806           obrot_der(2,i-2)=0.0d0
2807           Ugder(1,1,i-2)=0.0d0
2808           Ugder(1,2,i-2)=0.0d0
2809           Ugder(2,1,i-2)=0.0d0
2810           Ugder(2,2,i-2)=0.0d0
2811           obrot2_der(1,i-2)=0.0d0
2812           obrot2_der(2,i-2)=0.0d0
2813           Ug2der(1,1,i-2)=0.0d0
2814           Ug2der(1,2,i-2)=0.0d0
2815           Ug2der(2,1,i-2)=0.0d0
2816           Ug2der(2,2,i-2)=0.0d0
2817         endif
2818 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2819         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2820           iti = itortyp(itype(i-2))
2821         else
2822           iti=ntortyp
2823         endif
2824 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2825         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2826           iti1 = itortyp(itype(i-1))
2827         else
2828           iti1=ntortyp
2829         endif
2830 cd        write (iout,*) '*******i',i,' iti1',iti
2831 cd        write (iout,*) 'b1',b1(:,iti)
2832 cd        write (iout,*) 'b2',b2(:,iti)
2833 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2834 c        if (i .gt. iatel_s+2) then
2835         if (i .gt. nnt+2) then
2836           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2837 #ifdef NEWCORR
2838           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2839 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2840 #endif
2841 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2842 c     &    EE(1,2,iti),EE(2,2,iti)
2843           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2844           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2845 c          write(iout,*) "Macierz EUG",
2846 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2847 c     &    eug(2,2,i-2)
2848           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2849      &    then
2850           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2851           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2852           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2853           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2854           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2855           endif
2856         else
2857           do k=1,2
2858             Ub2(k,i-2)=0.0d0
2859             Ctobr(k,i-2)=0.0d0
2860             Dtobr2(k,i-2)=0.0d0
2861             do l=1,2
2862               EUg(l,k,i-2)=0.0d0
2863               CUg(l,k,i-2)=0.0d0
2864               DUg(l,k,i-2)=0.0d0
2865               DtUg2(l,k,i-2)=0.0d0
2866             enddo
2867           enddo
2868         endif
2869         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2870         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2871         do k=1,2
2872           muder(k,i-2)=Ub2der(k,i-2)
2873         enddo
2874 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2875         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2876           if (itype(i-1).le.ntyp) then
2877             iti1 = itortyp(itype(i-1))
2878           else
2879             iti1=ntortyp
2880           endif
2881         else
2882           iti1=ntortyp
2883         endif
2884         do k=1,2
2885           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2886         enddo
2887 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2888 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2889 cd        write (iout,*) 'mu1',mu1(:,i-2)
2890 cd        write (iout,*) 'mu2',mu2(:,i-2)
2891         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2892      &  then
2893         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2894         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2895         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2896         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2897         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2898 C Vectors and matrices dependent on a single virtual-bond dihedral.
2899         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2900         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2901         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2902         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2903         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2904         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2905         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2906         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2907         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2908         endif
2909       enddo
2910 C Matrices dependent on two consecutive virtual-bond dihedrals.
2911 C The order of matrices is from left to right.
2912       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2913      &then
2914 c      do i=max0(ivec_start,2),ivec_end
2915       do i=2,nres-1
2916         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2917         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2918         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2919         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2920         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2921         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2922         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2923         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2924       enddo
2925       endif
2926 #if defined(MPI) && defined(PARMAT)
2927 #ifdef DEBUG
2928 c      if (fg_rank.eq.0) then
2929         write (iout,*) "Arrays UG and UGDER before GATHER"
2930         do i=1,nres-1
2931           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2932      &     ((ug(l,k,i),l=1,2),k=1,2),
2933      &     ((ugder(l,k,i),l=1,2),k=1,2)
2934         enddo
2935         write (iout,*) "Arrays UG2 and UG2DER"
2936         do i=1,nres-1
2937           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2938      &     ((ug2(l,k,i),l=1,2),k=1,2),
2939      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2940         enddo
2941         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2942         do i=1,nres-1
2943           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2944      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2945      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2946         enddo
2947         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2948         do i=1,nres-1
2949           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2950      &     costab(i),sintab(i),costab2(i),sintab2(i)
2951         enddo
2952         write (iout,*) "Array MUDER"
2953         do i=1,nres-1
2954           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2955         enddo
2956 c      endif
2957 #endif
2958       if (nfgtasks.gt.1) then
2959         time00=MPI_Wtime()
2960 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2961 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2962 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2963 #ifdef MATGATHER
2964         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2965      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2966      &   FG_COMM1,IERR)
2967         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2968      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2969      &   FG_COMM1,IERR)
2970         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2971      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2972      &   FG_COMM1,IERR)
2973         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2974      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2975      &   FG_COMM1,IERR)
2976         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2977      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2978      &   FG_COMM1,IERR)
2979         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2980      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2981      &   FG_COMM1,IERR)
2982         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2983      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2984      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2985         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2986      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2987      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2988         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2989      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2990      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2991         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2992      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2993      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2994         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2995      &  then
2996         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3012      &   ivec_count(fg_rank1),
3013      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3014      &   FG_COMM1,IERR)
3015         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3016      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3017      &   FG_COMM1,IERR)
3018         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3019      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3020      &   FG_COMM1,IERR)
3021         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3022      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3023      &   FG_COMM1,IERR)
3024         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3025      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3026      &   FG_COMM1,IERR)
3027         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3028      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3029      &   FG_COMM1,IERR)
3030         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3031      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3032      &   FG_COMM1,IERR)
3033         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3034      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3035      &   FG_COMM1,IERR)
3036         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3037      &   ivec_count(fg_rank1),
3038      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3042      &   FG_COMM1,IERR)
3043        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3050      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3051      &   FG_COMM1,IERR)
3052         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3053      &   ivec_count(fg_rank1),
3054      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3057      &   ivec_count(fg_rank1),
3058      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3061      &   ivec_count(fg_rank1),
3062      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3063      &   MPI_MAT2,FG_COMM1,IERR)
3064         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3065      &   ivec_count(fg_rank1),
3066      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3067      &   MPI_MAT2,FG_COMM1,IERR)
3068         endif
3069 #else
3070 c Passes matrix info through the ring
3071       isend=fg_rank1
3072       irecv=fg_rank1-1
3073       if (irecv.lt.0) irecv=nfgtasks1-1
3074       iprev=irecv
3075       inext=fg_rank1+1
3076       if (inext.ge.nfgtasks1) inext=0
3077       do i=1,nfgtasks1-1
3078 c        write (iout,*) "isend",isend," irecv",irecv
3079 c        call flush(iout)
3080         lensend=lentyp(isend)
3081         lenrecv=lentyp(irecv)
3082 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3083 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3084 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3085 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3086 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3087 c        write (iout,*) "Gather ROTAT1"
3088 c        call flush(iout)
3089 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3090 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3091 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3092 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3093 c        write (iout,*) "Gather ROTAT2"
3094 c        call flush(iout)
3095         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3096      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3097      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3098      &   iprev,4400+irecv,FG_COMM,status,IERR)
3099 c        write (iout,*) "Gather ROTAT_OLD"
3100 c        call flush(iout)
3101         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3102      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3103      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3104      &   iprev,5500+irecv,FG_COMM,status,IERR)
3105 c        write (iout,*) "Gather PRECOMP11"
3106 c        call flush(iout)
3107         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3108      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3109      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3110      &   iprev,6600+irecv,FG_COMM,status,IERR)
3111 c        write (iout,*) "Gather PRECOMP12"
3112 c        call flush(iout)
3113         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3114      &  then
3115         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3116      &   MPI_ROTAT2(lensend),inext,7700+isend,
3117      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3118      &   iprev,7700+irecv,FG_COMM,status,IERR)
3119 c        write (iout,*) "Gather PRECOMP21"
3120 c        call flush(iout)
3121         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3122      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3123      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3124      &   iprev,8800+irecv,FG_COMM,status,IERR)
3125 c        write (iout,*) "Gather PRECOMP22"
3126 c        call flush(iout)
3127         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3128      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3129      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3130      &   MPI_PRECOMP23(lenrecv),
3131      &   iprev,9900+irecv,FG_COMM,status,IERR)
3132 c        write (iout,*) "Gather PRECOMP23"
3133 c        call flush(iout)
3134         endif
3135         isend=irecv
3136         irecv=irecv-1
3137         if (irecv.lt.0) irecv=nfgtasks1-1
3138       enddo
3139 #endif
3140         time_gather=time_gather+MPI_Wtime()-time00
3141       endif
3142 #ifdef DEBUG
3143 c      if (fg_rank.eq.0) then
3144         write (iout,*) "Arrays UG and UGDER"
3145         do i=1,nres-1
3146           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3147      &     ((ug(l,k,i),l=1,2),k=1,2),
3148      &     ((ugder(l,k,i),l=1,2),k=1,2)
3149         enddo
3150         write (iout,*) "Arrays UG2 and UG2DER"
3151         do i=1,nres-1
3152           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3153      &     ((ug2(l,k,i),l=1,2),k=1,2),
3154      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3155         enddo
3156         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3157         do i=1,nres-1
3158           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3159      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3160      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3161         enddo
3162         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3163         do i=1,nres-1
3164           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3165      &     costab(i),sintab(i),costab2(i),sintab2(i)
3166         enddo
3167         write (iout,*) "Array MUDER"
3168         do i=1,nres-1
3169           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3170         enddo
3171 c      endif
3172 #endif
3173 #endif
3174 cd      do i=1,nres
3175 cd        iti = itortyp(itype(i))
3176 cd        write (iout,*) i
3177 cd        do j=1,2
3178 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3179 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3180 cd        enddo
3181 cd      enddo
3182       return
3183       end
3184 C--------------------------------------------------------------------------
3185       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3186 C
3187 C This subroutine calculates the average interaction energy and its gradient
3188 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3189 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3190 C The potential depends both on the distance of peptide-group centers and on
3191 C the orientation of the CA-CA virtual bonds.
3192 C
3193       implicit real*8 (a-h,o-z)
3194 #ifdef MPI
3195       include 'mpif.h'
3196 #endif
3197       include 'DIMENSIONS'
3198       include 'COMMON.CONTROL'
3199       include 'COMMON.SETUP'
3200       include 'COMMON.IOUNITS'
3201       include 'COMMON.GEO'
3202       include 'COMMON.VAR'
3203       include 'COMMON.LOCAL'
3204       include 'COMMON.CHAIN'
3205       include 'COMMON.DERIV'
3206       include 'COMMON.INTERACT'
3207       include 'COMMON.CONTACTS'
3208       include 'COMMON.TORSION'
3209       include 'COMMON.VECTORS'
3210       include 'COMMON.FFIELD'
3211       include 'COMMON.TIME1'
3212       include 'COMMON.SPLITELE'
3213       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3214      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3215       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3216      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3217       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3218      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3219      &    num_conti,j1,j2
3220 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3221 #ifdef MOMENT
3222       double precision scal_el /1.0d0/
3223 #else
3224       double precision scal_el /0.5d0/
3225 #endif
3226 C 12/13/98
3227 C 13-go grudnia roku pamietnego...
3228       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3229      &                   0.0d0,1.0d0,0.0d0,
3230      &                   0.0d0,0.0d0,1.0d0/
3231 cd      write(iout,*) 'In EELEC'
3232 cd      do i=1,nloctyp
3233 cd        write(iout,*) 'Type',i
3234 cd        write(iout,*) 'B1',B1(:,i)
3235 cd        write(iout,*) 'B2',B2(:,i)
3236 cd        write(iout,*) 'CC',CC(:,:,i)
3237 cd        write(iout,*) 'DD',DD(:,:,i)
3238 cd        write(iout,*) 'EE',EE(:,:,i)
3239 cd      enddo
3240 cd      call check_vecgrad
3241 cd      stop
3242       if (icheckgrad.eq.1) then
3243         do i=1,nres-1
3244           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3245           do k=1,3
3246             dc_norm(k,i)=dc(k,i)*fac
3247           enddo
3248 c          write (iout,*) 'i',i,' fac',fac
3249         enddo
3250       endif
3251       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3252      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3253      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3254 c        call vec_and_deriv
3255 #ifdef TIMING
3256         time01=MPI_Wtime()
3257 #endif
3258         call set_matrices
3259 #ifdef TIMING
3260         time_mat=time_mat+MPI_Wtime()-time01
3261 #endif
3262       endif
3263 cd      do i=1,nres-1
3264 cd        write (iout,*) 'i=',i
3265 cd        do k=1,3
3266 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3267 cd        enddo
3268 cd        do k=1,3
3269 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3270 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3271 cd        enddo
3272 cd      enddo
3273       t_eelecij=0.0d0
3274       ees=0.0D0
3275       evdw1=0.0D0
3276       eel_loc=0.0d0
3277       eello_turn3=0.0d0
3278       eello_turn4=0.0d0
3279       ind=0
3280       do i=1,nres
3281         num_cont_hb(i)=0
3282       enddo
3283 cd      print '(a)','Enter EELEC'
3284 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3285       do i=1,nres
3286         gel_loc_loc(i)=0.0d0
3287         gcorr_loc(i)=0.0d0
3288       enddo
3289 c
3290 c
3291 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3292 C
3293 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3294 C
3295 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3296       do i=iturn3_start,iturn3_end
3297         if (i.le.1) cycle
3298 C        write(iout,*) "tu jest i",i
3299         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3300 C changes suggested by Ana to avoid out of bounds
3301      & .or.((i+4).gt.nres)
3302      & .or.((i-1).le.0)
3303 C end of changes by Ana
3304      &  .or. itype(i+2).eq.ntyp1
3305      &  .or. itype(i+3).eq.ntyp1) cycle
3306         if(i.gt.1)then
3307           if(itype(i-1).eq.ntyp1)cycle
3308         end if
3309         if(i.LT.nres-3)then
3310           if (itype(i+4).eq.ntyp1) cycle
3311         end if
3312         dxi=dc(1,i)
3313         dyi=dc(2,i)
3314         dzi=dc(3,i)
3315         dx_normi=dc_norm(1,i)
3316         dy_normi=dc_norm(2,i)
3317         dz_normi=dc_norm(3,i)
3318         xmedi=c(1,i)+0.5d0*dxi
3319         ymedi=c(2,i)+0.5d0*dyi
3320         zmedi=c(3,i)+0.5d0*dzi
3321           xmedi=mod(xmedi,boxxsize)
3322           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3323           ymedi=mod(ymedi,boxysize)
3324           if (ymedi.lt.0) ymedi=ymedi+boxysize
3325           zmedi=mod(zmedi,boxzsize)
3326           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3327         num_conti=0
3328         call eelecij(i,i+2,ees,evdw1,eel_loc)
3329         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3330         num_cont_hb(i)=num_conti
3331       enddo
3332       do i=iturn4_start,iturn4_end
3333         if (i.le.1) cycle
3334         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3335 C changes suggested by Ana to avoid out of bounds
3336      & .or.((i+5).gt.nres)
3337      & .or.((i-1).le.0)
3338 C end of changes suggested by Ana
3339      &    .or. itype(i+3).eq.ntyp1
3340      &    .or. itype(i+4).eq.ntyp1
3341      &    .or. itype(i+5).eq.ntyp1
3342      &    .or. itype(i).eq.ntyp1
3343      &    .or. itype(i-1).eq.ntyp1
3344      &                             ) cycle
3345         dxi=dc(1,i)
3346         dyi=dc(2,i)
3347         dzi=dc(3,i)
3348         dx_normi=dc_norm(1,i)
3349         dy_normi=dc_norm(2,i)
3350         dz_normi=dc_norm(3,i)
3351         xmedi=c(1,i)+0.5d0*dxi
3352         ymedi=c(2,i)+0.5d0*dyi
3353         zmedi=c(3,i)+0.5d0*dzi
3354 C Return atom into box, boxxsize is size of box in x dimension
3355 c  194   continue
3356 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3357 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3358 C Condition for being inside the proper box
3359 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3360 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3361 c        go to 194
3362 c        endif
3363 c  195   continue
3364 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3365 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3366 C Condition for being inside the proper box
3367 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3368 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3369 c        go to 195
3370 c        endif
3371 c  196   continue
3372 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3373 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3374 C Condition for being inside the proper box
3375 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3376 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3377 c        go to 196
3378 c        endif
3379           xmedi=mod(xmedi,boxxsize)
3380           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3381           ymedi=mod(ymedi,boxysize)
3382           if (ymedi.lt.0) ymedi=ymedi+boxysize
3383           zmedi=mod(zmedi,boxzsize)
3384           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3385
3386         num_conti=num_cont_hb(i)
3387 c        write(iout,*) "JESTEM W PETLI"
3388         call eelecij(i,i+3,ees,evdw1,eel_loc)
3389         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3390      &   call eturn4(i,eello_turn4)
3391         num_cont_hb(i)=num_conti
3392       enddo   ! i
3393 C Loop over all neighbouring boxes
3394 C      do xshift=-1,1
3395 C      do yshift=-1,1
3396 C      do zshift=-1,1
3397 c
3398 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3399 c
3400       do i=iatel_s,iatel_e
3401         if (i.le.1) cycle
3402         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3403 C changes suggested by Ana to avoid out of bounds
3404      & .or.((i+2).gt.nres)
3405      & .or.((i-1).le.0)
3406 C end of changes by Ana
3407      &  .or. itype(i+2).eq.ntyp1
3408      &  .or. itype(i-1).eq.ntyp1
3409      &                ) cycle
3410         dxi=dc(1,i)
3411         dyi=dc(2,i)
3412         dzi=dc(3,i)
3413         dx_normi=dc_norm(1,i)
3414         dy_normi=dc_norm(2,i)
3415         dz_normi=dc_norm(3,i)
3416         xmedi=c(1,i)+0.5d0*dxi
3417         ymedi=c(2,i)+0.5d0*dyi
3418         zmedi=c(3,i)+0.5d0*dzi
3419           xmedi=mod(xmedi,boxxsize)
3420           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3421           ymedi=mod(ymedi,boxysize)
3422           if (ymedi.lt.0) ymedi=ymedi+boxysize
3423           zmedi=mod(zmedi,boxzsize)
3424           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3425 C          xmedi=xmedi+xshift*boxxsize
3426 C          ymedi=ymedi+yshift*boxysize
3427 C          zmedi=zmedi+zshift*boxzsize
3428
3429 C Return tom into box, boxxsize is size of box in x dimension
3430 c  164   continue
3431 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3432 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3433 C Condition for being inside the proper box
3434 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3435 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3436 c        go to 164
3437 c        endif
3438 c  165   continue
3439 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3440 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3441 C Condition for being inside the proper box
3442 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3443 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3444 c        go to 165
3445 c        endif
3446 c  166   continue
3447 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3448 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3449 cC Condition for being inside the proper box
3450 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3451 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3452 c        go to 166
3453 c        endif
3454
3455 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3456         num_conti=num_cont_hb(i)
3457         do j=ielstart(i),ielend(i)
3458 C          write (iout,*) i,j
3459          if (j.le.1) cycle
3460           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3461 C changes suggested by Ana to avoid out of bounds
3462      & .or.((j+2).gt.nres)
3463      & .or.((j-1).le.0)
3464 C end of changes by Ana
3465      & .or.itype(j+2).eq.ntyp1
3466      & .or.itype(j-1).eq.ntyp1
3467      &) cycle
3468           call eelecij(i,j,ees,evdw1,eel_loc)
3469         enddo ! j
3470         num_cont_hb(i)=num_conti
3471       enddo   ! i
3472 C     enddo   ! zshift
3473 C      enddo   ! yshift
3474 C      enddo   ! xshift
3475
3476 c      write (iout,*) "Number of loop steps in EELEC:",ind
3477 cd      do i=1,nres
3478 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3479 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3480 cd      enddo
3481 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3482 ccc      eel_loc=eel_loc+eello_turn3
3483 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3484       return
3485       end
3486 C-------------------------------------------------------------------------------
3487       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3488       implicit real*8 (a-h,o-z)
3489       include 'DIMENSIONS'
3490 #ifdef MPI
3491       include "mpif.h"
3492 #endif
3493       include 'COMMON.CONTROL'
3494       include 'COMMON.IOUNITS'
3495       include 'COMMON.GEO'
3496       include 'COMMON.VAR'
3497       include 'COMMON.LOCAL'
3498       include 'COMMON.CHAIN'
3499       include 'COMMON.DERIV'
3500       include 'COMMON.INTERACT'
3501       include 'COMMON.CONTACTS'
3502       include 'COMMON.TORSION'
3503       include 'COMMON.VECTORS'
3504       include 'COMMON.FFIELD'
3505       include 'COMMON.TIME1'
3506       include 'COMMON.SPLITELE'
3507       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3508      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3509       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3510      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3511      &    gmuij2(4),gmuji2(4)
3512       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3513      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3514      &    num_conti,j1,j2
3515 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3516 #ifdef MOMENT
3517       double precision scal_el /1.0d0/
3518 #else
3519       double precision scal_el /0.5d0/
3520 #endif
3521 C 12/13/98
3522 C 13-go grudnia roku pamietnego...
3523       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3524      &                   0.0d0,1.0d0,0.0d0,
3525      &                   0.0d0,0.0d0,1.0d0/
3526 c          time00=MPI_Wtime()
3527 cd      write (iout,*) "eelecij",i,j
3528 c          ind=ind+1
3529           iteli=itel(i)
3530           itelj=itel(j)
3531           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3532           aaa=app(iteli,itelj)
3533           bbb=bpp(iteli,itelj)
3534           ael6i=ael6(iteli,itelj)
3535           ael3i=ael3(iteli,itelj)
3536           dxj=dc(1,j)
3537           dyj=dc(2,j)
3538           dzj=dc(3,j)
3539           dx_normj=dc_norm(1,j)
3540           dy_normj=dc_norm(2,j)
3541           dz_normj=dc_norm(3,j)
3542 C          xj=c(1,j)+0.5D0*dxj-xmedi
3543 C          yj=c(2,j)+0.5D0*dyj-ymedi
3544 C          zj=c(3,j)+0.5D0*dzj-zmedi
3545           xj=c(1,j)+0.5D0*dxj
3546           yj=c(2,j)+0.5D0*dyj
3547           zj=c(3,j)+0.5D0*dzj
3548           xj=mod(xj,boxxsize)
3549           if (xj.lt.0) xj=xj+boxxsize
3550           yj=mod(yj,boxysize)
3551           if (yj.lt.0) yj=yj+boxysize
3552           zj=mod(zj,boxzsize)
3553           if (zj.lt.0) zj=zj+boxzsize
3554           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3555       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3556       xj_safe=xj
3557       yj_safe=yj
3558       zj_safe=zj
3559       isubchap=0
3560       do xshift=-1,1
3561       do yshift=-1,1
3562       do zshift=-1,1
3563           xj=xj_safe+xshift*boxxsize
3564           yj=yj_safe+yshift*boxysize
3565           zj=zj_safe+zshift*boxzsize
3566           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3567           if(dist_temp.lt.dist_init) then
3568             dist_init=dist_temp
3569             xj_temp=xj
3570             yj_temp=yj
3571             zj_temp=zj
3572             isubchap=1
3573           endif
3574        enddo
3575        enddo
3576        enddo
3577        if (isubchap.eq.1) then
3578           xj=xj_temp-xmedi
3579           yj=yj_temp-ymedi
3580           zj=zj_temp-zmedi
3581        else
3582           xj=xj_safe-xmedi
3583           yj=yj_safe-ymedi
3584           zj=zj_safe-zmedi
3585        endif
3586 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3587 c  174   continue
3588 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3589 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3590 C Condition for being inside the proper box
3591 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3592 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3593 c        go to 174
3594 c        endif
3595 c  175   continue
3596 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3597 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3598 C Condition for being inside the proper box
3599 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3600 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3601 c        go to 175
3602 c        endif
3603 c  176   continue
3604 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3605 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3606 C Condition for being inside the proper box
3607 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3608 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3609 c        go to 176
3610 c        endif
3611 C        endif !endPBC condintion
3612 C        xj=xj-xmedi
3613 C        yj=yj-ymedi
3614 C        zj=zj-zmedi
3615           rij=xj*xj+yj*yj+zj*zj
3616
3617             sss=sscale(sqrt(rij))
3618             sssgrad=sscagrad(sqrt(rij))
3619 c            if (sss.gt.0.0d0) then
3620           rrmij=1.0D0/rij
3621           rij=dsqrt(rij)
3622           rmij=1.0D0/rij
3623           r3ij=rrmij*rmij
3624           r6ij=r3ij*r3ij
3625           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3626           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3627           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3628           fac=cosa-3.0D0*cosb*cosg
3629           ev1=aaa*r6ij*r6ij
3630 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3631           if (j.eq.i+2) ev1=scal_el*ev1
3632           ev2=bbb*r6ij
3633           fac3=ael6i*r6ij
3634           fac4=ael3i*r3ij
3635           evdwij=(ev1+ev2)
3636           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3637           el2=fac4*fac
3638 C MARYSIA
3639           eesij=(el1+el2)
3640 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3641           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3642           ees=ees+eesij
3643           evdw1=evdw1+evdwij*sss
3644 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3645 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3646 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3647 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3648
3649           if (energy_dec) then
3650               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3651      &'evdw1',i,j,evdwij
3652      &,iteli,itelj,aaa,evdw1
3653               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3654           endif
3655
3656 C
3657 C Calculate contributions to the Cartesian gradient.
3658 C
3659 #ifdef SPLITELE
3660           facvdw=-6*rrmij*(ev1+evdwij)*sss
3661           facel=-3*rrmij*(el1+eesij)
3662           fac1=fac
3663           erij(1)=xj*rmij
3664           erij(2)=yj*rmij
3665           erij(3)=zj*rmij
3666 *
3667 * Radial derivatives. First process both termini of the fragment (i,j)
3668 *
3669           ggg(1)=facel*xj
3670           ggg(2)=facel*yj
3671           ggg(3)=facel*zj
3672 c          do k=1,3
3673 c            ghalf=0.5D0*ggg(k)
3674 c            gelc(k,i)=gelc(k,i)+ghalf
3675 c            gelc(k,j)=gelc(k,j)+ghalf
3676 c          enddo
3677 c 9/28/08 AL Gradient compotents will be summed only at the end
3678           do k=1,3
3679             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3680             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3681           enddo
3682 *
3683 * Loop over residues i+1 thru j-1.
3684 *
3685 cgrad          do k=i+1,j-1
3686 cgrad            do l=1,3
3687 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3688 cgrad            enddo
3689 cgrad          enddo
3690           if (sss.gt.0.0) then
3691           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3692           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3693           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3694           else
3695           ggg(1)=0.0
3696           ggg(2)=0.0
3697           ggg(3)=0.0
3698           endif
3699 c          do k=1,3
3700 c            ghalf=0.5D0*ggg(k)
3701 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3702 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3703 c          enddo
3704 c 9/28/08 AL Gradient compotents will be summed only at the end
3705           do k=1,3
3706             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3707             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3708           enddo
3709 *
3710 * Loop over residues i+1 thru j-1.
3711 *
3712 cgrad          do k=i+1,j-1
3713 cgrad            do l=1,3
3714 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3715 cgrad            enddo
3716 cgrad          enddo
3717 #else
3718 C MARYSIA
3719           facvdw=(ev1+evdwij)*sss
3720           facel=(el1+eesij)
3721           fac1=fac
3722           fac=-3*rrmij*(facvdw+facvdw+facel)
3723           erij(1)=xj*rmij
3724           erij(2)=yj*rmij
3725           erij(3)=zj*rmij
3726 *
3727 * Radial derivatives. First process both termini of the fragment (i,j)
3728 *
3729           ggg(1)=fac*xj
3730           ggg(2)=fac*yj
3731           ggg(3)=fac*zj
3732 c          do k=1,3
3733 c            ghalf=0.5D0*ggg(k)
3734 c            gelc(k,i)=gelc(k,i)+ghalf
3735 c            gelc(k,j)=gelc(k,j)+ghalf
3736 c          enddo
3737 c 9/28/08 AL Gradient compotents will be summed only at the end
3738           do k=1,3
3739             gelc_long(k,j)=gelc(k,j)+ggg(k)
3740             gelc_long(k,i)=gelc(k,i)-ggg(k)
3741           enddo
3742 *
3743 * Loop over residues i+1 thru j-1.
3744 *
3745 cgrad          do k=i+1,j-1
3746 cgrad            do l=1,3
3747 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3748 cgrad            enddo
3749 cgrad          enddo
3750 c 9/28/08 AL Gradient compotents will be summed only at the end
3751           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3752           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3753           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3754           do k=1,3
3755             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3756             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3757           enddo
3758 #endif
3759 *
3760 * Angular part
3761 *
3762           ecosa=2.0D0*fac3*fac1+fac4
3763           fac4=-3.0D0*fac4
3764           fac3=-6.0D0*fac3
3765           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3766           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3767           do k=1,3
3768             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3769             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3770           enddo
3771 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3772 cd   &          (dcosg(k),k=1,3)
3773           do k=1,3
3774             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3775           enddo
3776 c          do k=1,3
3777 c            ghalf=0.5D0*ggg(k)
3778 c            gelc(k,i)=gelc(k,i)+ghalf
3779 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3780 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3781 c            gelc(k,j)=gelc(k,j)+ghalf
3782 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3783 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3784 c          enddo
3785 cgrad          do k=i+1,j-1
3786 cgrad            do l=1,3
3787 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3788 cgrad            enddo
3789 cgrad          enddo
3790           do k=1,3
3791             gelc(k,i)=gelc(k,i)
3792      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3793      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3794             gelc(k,j)=gelc(k,j)
3795      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3796      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3797             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3798             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3799           enddo
3800 C MARYSIA
3801 c          endif !sscale
3802           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3803      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3804      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3805 C
3806 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3807 C   energy of a peptide unit is assumed in the form of a second-order
3808 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3809 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3810 C   are computed for EVERY pair of non-contiguous peptide groups.
3811 C
3812
3813           if (j.lt.nres-1) then
3814             j1=j+1
3815             j2=j-1
3816           else
3817             j1=j-1
3818             j2=j-2
3819           endif
3820           kkk=0
3821           lll=0
3822           do k=1,2
3823             do l=1,2
3824               kkk=kkk+1
3825               muij(kkk)=mu(k,i)*mu(l,j)
3826 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3827 #ifdef NEWCORR
3828              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3829 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3830              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3831              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3832 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3833              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3834 #endif
3835             enddo
3836           enddo
3837 cd         write (iout,*) 'EELEC: i',i,' j',j
3838 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3839 cd          write(iout,*) 'muij',muij
3840           ury=scalar(uy(1,i),erij)
3841           urz=scalar(uz(1,i),erij)
3842           vry=scalar(uy(1,j),erij)
3843           vrz=scalar(uz(1,j),erij)
3844           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3845           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3846           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3847           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3848           fac=dsqrt(-ael6i)*r3ij
3849           a22=a22*fac
3850           a23=a23*fac
3851           a32=a32*fac
3852           a33=a33*fac
3853 cd          write (iout,'(4i5,4f10.5)')
3854 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3855 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3856 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3857 cd     &      uy(:,j),uz(:,j)
3858 cd          write (iout,'(4f10.5)')
3859 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3860 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3861 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3862 cd           write (iout,'(9f10.5/)')
3863 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3864 C Derivatives of the elements of A in virtual-bond vectors
3865           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3866           do k=1,3
3867             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3868             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3869             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3870             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3871             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3872             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3873             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3874             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3875             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3876             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3877             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3878             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3879           enddo
3880 C Compute radial contributions to the gradient
3881           facr=-3.0d0*rrmij
3882           a22der=a22*facr
3883           a23der=a23*facr
3884           a32der=a32*facr
3885           a33der=a33*facr
3886           agg(1,1)=a22der*xj
3887           agg(2,1)=a22der*yj
3888           agg(3,1)=a22der*zj
3889           agg(1,2)=a23der*xj
3890           agg(2,2)=a23der*yj
3891           agg(3,2)=a23der*zj
3892           agg(1,3)=a32der*xj
3893           agg(2,3)=a32der*yj
3894           agg(3,3)=a32der*zj
3895           agg(1,4)=a33der*xj
3896           agg(2,4)=a33der*yj
3897           agg(3,4)=a33der*zj
3898 C Add the contributions coming from er
3899           fac3=-3.0d0*fac
3900           do k=1,3
3901             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3902             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3903             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3904             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3905           enddo
3906           do k=1,3
3907 C Derivatives in DC(i)
3908 cgrad            ghalf1=0.5d0*agg(k,1)
3909 cgrad            ghalf2=0.5d0*agg(k,2)
3910 cgrad            ghalf3=0.5d0*agg(k,3)
3911 cgrad            ghalf4=0.5d0*agg(k,4)
3912             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3913      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3914             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3915      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3916             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3917      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3918             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3919      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3920 C Derivatives in DC(i+1)
3921             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3922      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3923             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3924      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3925             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3926      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3927             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3928      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3929 C Derivatives in DC(j)
3930             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3931      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3932             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3933      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3934             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3935      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3936             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3937      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3938 C Derivatives in DC(j+1) or DC(nres-1)
3939             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3940      &      -3.0d0*vryg(k,3)*ury)
3941             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3942      &      -3.0d0*vrzg(k,3)*ury)
3943             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3944      &      -3.0d0*vryg(k,3)*urz)
3945             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3946      &      -3.0d0*vrzg(k,3)*urz)
3947 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3948 cgrad              do l=1,4
3949 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3950 cgrad              enddo
3951 cgrad            endif
3952           enddo
3953           acipa(1,1)=a22
3954           acipa(1,2)=a23
3955           acipa(2,1)=a32
3956           acipa(2,2)=a33
3957           a22=-a22
3958           a23=-a23
3959           do l=1,2
3960             do k=1,3
3961               agg(k,l)=-agg(k,l)
3962               aggi(k,l)=-aggi(k,l)
3963               aggi1(k,l)=-aggi1(k,l)
3964               aggj(k,l)=-aggj(k,l)
3965               aggj1(k,l)=-aggj1(k,l)
3966             enddo
3967           enddo
3968           if (j.lt.nres-1) then
3969             a22=-a22
3970             a32=-a32
3971             do l=1,3,2
3972               do k=1,3
3973                 agg(k,l)=-agg(k,l)
3974                 aggi(k,l)=-aggi(k,l)
3975                 aggi1(k,l)=-aggi1(k,l)
3976                 aggj(k,l)=-aggj(k,l)
3977                 aggj1(k,l)=-aggj1(k,l)
3978               enddo
3979             enddo
3980           else
3981             a22=-a22
3982             a23=-a23
3983             a32=-a32
3984             a33=-a33
3985             do l=1,4
3986               do k=1,3
3987                 agg(k,l)=-agg(k,l)
3988                 aggi(k,l)=-aggi(k,l)
3989                 aggi1(k,l)=-aggi1(k,l)
3990                 aggj(k,l)=-aggj(k,l)
3991                 aggj1(k,l)=-aggj1(k,l)
3992               enddo
3993             enddo
3994           endif
3995           ENDIF ! WCORR
3996           IF (wel_loc.gt.0.0d0) THEN
3997 C Contribution to the local-electrostatic energy coming from the i-j pair
3998           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3999      &     +a33*muij(4)
4000 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4001 c     &                     ' eel_loc_ij',eel_loc_ij
4002 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4003 C Calculate patrial derivative for theta angle
4004 #ifdef NEWCORR
4005          geel_loc_ij=a22*gmuij1(1)
4006      &     +a23*gmuij1(2)
4007      &     +a32*gmuij1(3)
4008      &     +a33*gmuij1(4)
4009 c         write(iout,*) "derivative over thatai"
4010 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4011 c     &   a33*gmuij1(4)
4012          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4013      &      geel_loc_ij*wel_loc
4014 c         write(iout,*) "derivative over thatai-1"
4015 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4016 c     &   a33*gmuij2(4)
4017          geel_loc_ij=
4018      &     a22*gmuij2(1)
4019      &     +a23*gmuij2(2)
4020      &     +a32*gmuij2(3)
4021      &     +a33*gmuij2(4)
4022          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4023      &      geel_loc_ij*wel_loc
4024 c  Derivative over j residue
4025          geel_loc_ji=a22*gmuji1(1)
4026      &     +a23*gmuji1(2)
4027      &     +a32*gmuji1(3)
4028      &     +a33*gmuji1(4)
4029 c         write(iout,*) "derivative over thataj"
4030 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4031 c     &   a33*gmuji1(4)
4032
4033         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4034      &      geel_loc_ji*wel_loc
4035          geel_loc_ji=
4036      &     +a22*gmuji2(1)
4037      &     +a23*gmuji2(2)
4038      &     +a32*gmuji2(3)
4039      &     +a33*gmuji2(4)
4040 c         write(iout,*) "derivative over thataj-1"
4041 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4042 c     &   a33*gmuji2(4)
4043          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4044      &      geel_loc_ji*wel_loc
4045 #endif
4046 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4047
4048           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4049      &            'eelloc',i,j,eel_loc_ij
4050 c           if (eel_loc_ij.ne.0)
4051 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4052 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4053
4054           eel_loc=eel_loc+eel_loc_ij
4055 C Partial derivatives in virtual-bond dihedral angles gamma
4056           if (i.gt.1)
4057      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4058      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4059      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4060           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4061      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4062      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4063 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4064           do l=1,3
4065             ggg(l)=agg(l,1)*muij(1)+
4066      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4067             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4068             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4069 cgrad            ghalf=0.5d0*ggg(l)
4070 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4071 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4072           enddo
4073 cgrad          do k=i+1,j2
4074 cgrad            do l=1,3
4075 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4076 cgrad            enddo
4077 cgrad          enddo
4078 C Remaining derivatives of eello
4079           do l=1,3
4080             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4081      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4082             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4083      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4084             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4085      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4086             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4087      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4088           enddo
4089           ENDIF
4090 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4091 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4092           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4093      &       .and. num_conti.le.maxconts) then
4094 c            write (iout,*) i,j," entered corr"
4095 C
4096 C Calculate the contact function. The ith column of the array JCONT will
4097 C contain the numbers of atoms that make contacts with the atom I (of numbers
4098 C greater than I). The arrays FACONT and GACONT will contain the values of
4099 C the contact function and its derivative.
4100 c           r0ij=1.02D0*rpp(iteli,itelj)
4101 c           r0ij=1.11D0*rpp(iteli,itelj)
4102             r0ij=2.20D0*rpp(iteli,itelj)
4103 c           r0ij=1.55D0*rpp(iteli,itelj)
4104             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4105             if (fcont.gt.0.0D0) then
4106               num_conti=num_conti+1
4107               if (num_conti.gt.maxconts) then
4108                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4109      &                         ' will skip next contacts for this conf.'
4110               else
4111                 jcont_hb(num_conti,i)=j
4112 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4113 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4114                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4115      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4116 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4117 C  terms.
4118                 d_cont(num_conti,i)=rij
4119 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4120 C     --- Electrostatic-interaction matrix ---
4121                 a_chuj(1,1,num_conti,i)=a22
4122                 a_chuj(1,2,num_conti,i)=a23
4123                 a_chuj(2,1,num_conti,i)=a32
4124                 a_chuj(2,2,num_conti,i)=a33
4125 C     --- Gradient of rij
4126                 do kkk=1,3
4127                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4128                 enddo
4129                 kkll=0
4130                 do k=1,2
4131                   do l=1,2
4132                     kkll=kkll+1
4133                     do m=1,3
4134                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4135                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4136                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4137                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4138                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4139                     enddo
4140                   enddo
4141                 enddo
4142                 ENDIF
4143                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4144 C Calculate contact energies
4145                 cosa4=4.0D0*cosa
4146                 wij=cosa-3.0D0*cosb*cosg
4147                 cosbg1=cosb+cosg
4148                 cosbg2=cosb-cosg
4149 c               fac3=dsqrt(-ael6i)/r0ij**3
4150                 fac3=dsqrt(-ael6i)*r3ij
4151 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4152                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4153                 if (ees0tmp.gt.0) then
4154                   ees0pij=dsqrt(ees0tmp)
4155                 else
4156                   ees0pij=0
4157                 endif
4158 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4159                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4160                 if (ees0tmp.gt.0) then
4161                   ees0mij=dsqrt(ees0tmp)
4162                 else
4163                   ees0mij=0
4164                 endif
4165 c               ees0mij=0.0D0
4166                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4167                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4168 C Diagnostics. Comment out or remove after debugging!
4169 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4170 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4171 c               ees0m(num_conti,i)=0.0D0
4172 C End diagnostics.
4173 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4174 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4175 C Angular derivatives of the contact function
4176                 ees0pij1=fac3/ees0pij
4177                 ees0mij1=fac3/ees0mij
4178                 fac3p=-3.0D0*fac3*rrmij
4179                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4180                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4181 c               ees0mij1=0.0D0
4182                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4183                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4184                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4185                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4186                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4187                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4188                 ecosap=ecosa1+ecosa2
4189                 ecosbp=ecosb1+ecosb2
4190                 ecosgp=ecosg1+ecosg2
4191                 ecosam=ecosa1-ecosa2
4192                 ecosbm=ecosb1-ecosb2
4193                 ecosgm=ecosg1-ecosg2
4194 C Diagnostics
4195 c               ecosap=ecosa1
4196 c               ecosbp=ecosb1
4197 c               ecosgp=ecosg1
4198 c               ecosam=0.0D0
4199 c               ecosbm=0.0D0
4200 c               ecosgm=0.0D0
4201 C End diagnostics
4202                 facont_hb(num_conti,i)=fcont
4203                 fprimcont=fprimcont/rij
4204 cd              facont_hb(num_conti,i)=1.0D0
4205 C Following line is for diagnostics.
4206 cd              fprimcont=0.0D0
4207                 do k=1,3
4208                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4209                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4210                 enddo
4211                 do k=1,3
4212                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4213                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4214                 enddo
4215                 gggp(1)=gggp(1)+ees0pijp*xj
4216                 gggp(2)=gggp(2)+ees0pijp*yj
4217                 gggp(3)=gggp(3)+ees0pijp*zj
4218                 gggm(1)=gggm(1)+ees0mijp*xj
4219                 gggm(2)=gggm(2)+ees0mijp*yj
4220                 gggm(3)=gggm(3)+ees0mijp*zj
4221 C Derivatives due to the contact function
4222                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4223                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4224                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4225                 do k=1,3
4226 c
4227 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4228 c          following the change of gradient-summation algorithm.
4229 c
4230 cgrad                  ghalfp=0.5D0*gggp(k)
4231 cgrad                  ghalfm=0.5D0*gggm(k)
4232                   gacontp_hb1(k,num_conti,i)=!ghalfp
4233      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4234      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4235                   gacontp_hb2(k,num_conti,i)=!ghalfp
4236      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4237      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4238                   gacontp_hb3(k,num_conti,i)=gggp(k)
4239                   gacontm_hb1(k,num_conti,i)=!ghalfm
4240      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4241      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4242                   gacontm_hb2(k,num_conti,i)=!ghalfm
4243      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4244      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4245                   gacontm_hb3(k,num_conti,i)=gggm(k)
4246                 enddo
4247 C Diagnostics. Comment out or remove after debugging!
4248 cdiag           do k=1,3
4249 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4250 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4251 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4252 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4253 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4254 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4255 cdiag           enddo
4256               ENDIF ! wcorr
4257               endif  ! num_conti.le.maxconts
4258             endif  ! fcont.gt.0
4259           endif    ! j.gt.i+1
4260           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4261             do k=1,4
4262               do l=1,3
4263                 ghalf=0.5d0*agg(l,k)
4264                 aggi(l,k)=aggi(l,k)+ghalf
4265                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4266                 aggj(l,k)=aggj(l,k)+ghalf
4267               enddo
4268             enddo
4269             if (j.eq.nres-1 .and. i.lt.j-2) then
4270               do k=1,4
4271                 do l=1,3
4272                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4273                 enddo
4274               enddo
4275             endif
4276           endif
4277 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4278       return
4279       end
4280 C-----------------------------------------------------------------------------
4281       subroutine eturn3(i,eello_turn3)
4282 C Third- and fourth-order contributions from turns
4283       implicit real*8 (a-h,o-z)
4284       include 'DIMENSIONS'
4285       include 'COMMON.IOUNITS'
4286       include 'COMMON.GEO'
4287       include 'COMMON.VAR'
4288       include 'COMMON.LOCAL'
4289       include 'COMMON.CHAIN'
4290       include 'COMMON.DERIV'
4291       include 'COMMON.INTERACT'
4292       include 'COMMON.CONTACTS'
4293       include 'COMMON.TORSION'
4294       include 'COMMON.VECTORS'
4295       include 'COMMON.FFIELD'
4296       include 'COMMON.CONTROL'
4297       dimension ggg(3)
4298       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4299      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4300      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4301      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4302      &  auxgmat2(2,2),auxgmatt2(2,2)
4303       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4304      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4305       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4306      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4307      &    num_conti,j1,j2
4308       j=i+2
4309 c      write (iout,*) "eturn3",i,j,j1,j2
4310       a_temp(1,1)=a22
4311       a_temp(1,2)=a23
4312       a_temp(2,1)=a32
4313       a_temp(2,2)=a33
4314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4315 C
4316 C               Third-order contributions
4317 C
4318 C                 (i+2)o----(i+3)
4319 C                      | |
4320 C                      | |
4321 C                 (i+1)o----i
4322 C
4323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4324 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4325         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4326 c auxalary matices for theta gradient
4327 c auxalary matrix for i+1 and constant i+2
4328         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4329 c auxalary matrix for i+2 and constant i+1
4330         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4331         call transpose2(auxmat(1,1),auxmat1(1,1))
4332         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4333         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4334         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4335         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4336         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4337         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4338 C Derivatives in theta
4339         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4340      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4341         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4342      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4343
4344         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4345      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4346 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4347 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4348 cd     &    ' eello_turn3_num',4*eello_turn3_num
4349 C Derivatives in gamma(i)
4350         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4351         call transpose2(auxmat2(1,1),auxmat3(1,1))
4352         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4353         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4354 C Derivatives in gamma(i+1)
4355         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4356         call transpose2(auxmat2(1,1),auxmat3(1,1))
4357         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4358         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4359      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4360 C Cartesian derivatives
4361         do l=1,3
4362 c            ghalf1=0.5d0*agg(l,1)
4363 c            ghalf2=0.5d0*agg(l,2)
4364 c            ghalf3=0.5d0*agg(l,3)
4365 c            ghalf4=0.5d0*agg(l,4)
4366           a_temp(1,1)=aggi(l,1)!+ghalf1
4367           a_temp(1,2)=aggi(l,2)!+ghalf2
4368           a_temp(2,1)=aggi(l,3)!+ghalf3
4369           a_temp(2,2)=aggi(l,4)!+ghalf4
4370           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4371           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4372      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4373           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4374           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4375           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4376           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4377           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4378           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4379      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4380           a_temp(1,1)=aggj(l,1)!+ghalf1
4381           a_temp(1,2)=aggj(l,2)!+ghalf2
4382           a_temp(2,1)=aggj(l,3)!+ghalf3
4383           a_temp(2,2)=aggj(l,4)!+ghalf4
4384           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4385           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4386      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4387           a_temp(1,1)=aggj1(l,1)
4388           a_temp(1,2)=aggj1(l,2)
4389           a_temp(2,1)=aggj1(l,3)
4390           a_temp(2,2)=aggj1(l,4)
4391           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4392           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4393      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4394         enddo
4395       return
4396       end
4397 C-------------------------------------------------------------------------------
4398       subroutine eturn4(i,eello_turn4)
4399 C Third- and fourth-order contributions from turns
4400       implicit real*8 (a-h,o-z)
4401       include 'DIMENSIONS'
4402       include 'COMMON.IOUNITS'
4403       include 'COMMON.GEO'
4404       include 'COMMON.VAR'
4405       include 'COMMON.LOCAL'
4406       include 'COMMON.CHAIN'
4407       include 'COMMON.DERIV'
4408       include 'COMMON.INTERACT'
4409       include 'COMMON.CONTACTS'
4410       include 'COMMON.TORSION'
4411       include 'COMMON.VECTORS'
4412       include 'COMMON.FFIELD'
4413       include 'COMMON.CONTROL'
4414       dimension ggg(3)
4415       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4416      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4417      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4418      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4419      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4420      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4421      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4422       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4423      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4424       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4425      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4426      &    num_conti,j1,j2
4427       j=i+3
4428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4429 C
4430 C               Fourth-order contributions
4431 C
4432 C                 (i+3)o----(i+4)
4433 C                     /  |
4434 C               (i+2)o   |
4435 C                     \  |
4436 C                 (i+1)o----i
4437 C
4438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4439 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4440 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4441 c        write(iout,*)"WCHODZE W PROGRAM"
4442         a_temp(1,1)=a22
4443         a_temp(1,2)=a23
4444         a_temp(2,1)=a32
4445         a_temp(2,2)=a33
4446         iti1=itortyp(itype(i+1))
4447         iti2=itortyp(itype(i+2))
4448         iti3=itortyp(itype(i+3))
4449 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4450         call transpose2(EUg(1,1,i+1),e1t(1,1))
4451         call transpose2(Eug(1,1,i+2),e2t(1,1))
4452         call transpose2(Eug(1,1,i+3),e3t(1,1))
4453 C Ematrix derivative in theta
4454         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4455         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4456         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4457         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4458 c       eta1 in derivative theta
4459         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4460         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4461 c       auxgvec is derivative of Ub2 so i+3 theta
4462         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4463 c       auxalary matrix of E i+1
4464         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4465 c        s1=0.0
4466 c        gs1=0.0
4467         s1=scalar2(b1(1,i+2),auxvec(1))
4468 c derivative of theta i+2 with constant i+3
4469         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4470 c derivative of theta i+2 with constant i+2
4471         gs32=scalar2(b1(1,i+2),auxgvec(1))
4472 c derivative of E matix in theta of i+1
4473         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4474
4475         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4476 c       ea31 in derivative theta
4477         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4478         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4479 c auxilary matrix auxgvec of Ub2 with constant E matirx
4480         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4481 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4482         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4483
4484 c        s2=0.0
4485 c        gs2=0.0
4486         s2=scalar2(b1(1,i+1),auxvec(1))
4487 c derivative of theta i+1 with constant i+3
4488         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4489 c derivative of theta i+2 with constant i+1
4490         gs21=scalar2(b1(1,i+1),auxgvec(1))
4491 c derivative of theta i+3 with constant i+1
4492         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4493 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4494 c     &  gtb1(1,i+1)
4495         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4496 c two derivatives over diffetent matrices
4497 c gtae3e2 is derivative over i+3
4498         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4499 c ae3gte2 is derivative over i+2
4500         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4501         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4502 c three possible derivative over theta E matices
4503 c i+1
4504         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4505 c i+2
4506         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4507 c i+3
4508         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4509         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4510
4511         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4512         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4513         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4514
4515         eello_turn4=eello_turn4-(s1+s2+s3)
4516 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4517         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4518      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4519 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4520 cd     &    ' eello_turn4_num',8*eello_turn4_num
4521 #ifdef NEWCORR
4522         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4523      &                  -(gs13+gsE13+gsEE1)*wturn4
4524         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4525      &                    -(gs23+gs21+gsEE2)*wturn4
4526         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4527      &                    -(gs32+gsE31+gsEE3)*wturn4
4528 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4529 c     &   gs2
4530 #endif
4531         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4532      &      'eturn4',i,j,-(s1+s2+s3)
4533 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4534 c     &    ' eello_turn4_num',8*eello_turn4_num
4535 C Derivatives in gamma(i)
4536         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4537         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4538         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4539         s1=scalar2(b1(1,i+2),auxvec(1))
4540         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4541         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4542         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4543 C Derivatives in gamma(i+1)
4544         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4545         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4546         s2=scalar2(b1(1,i+1),auxvec(1))
4547         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4548         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4549         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4550         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4551 C Derivatives in gamma(i+2)
4552         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4553         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4554         s1=scalar2(b1(1,i+2),auxvec(1))
4555         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4556         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4557         s2=scalar2(b1(1,i+1),auxvec(1))
4558         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4559         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4560         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4561         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4562 C Cartesian derivatives
4563 C Derivatives of this turn contributions in DC(i+2)
4564         if (j.lt.nres-1) then
4565           do l=1,3
4566             a_temp(1,1)=agg(l,1)
4567             a_temp(1,2)=agg(l,2)
4568             a_temp(2,1)=agg(l,3)
4569             a_temp(2,2)=agg(l,4)
4570             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4571             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4572             s1=scalar2(b1(1,i+2),auxvec(1))
4573             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4574             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4575             s2=scalar2(b1(1,i+1),auxvec(1))
4576             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4577             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4578             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579             ggg(l)=-(s1+s2+s3)
4580             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4581           enddo
4582         endif
4583 C Remaining derivatives of this turn contribution
4584         do l=1,3
4585           a_temp(1,1)=aggi(l,1)
4586           a_temp(1,2)=aggi(l,2)
4587           a_temp(2,1)=aggi(l,3)
4588           a_temp(2,2)=aggi(l,4)
4589           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4590           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4591           s1=scalar2(b1(1,i+2),auxvec(1))
4592           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4593           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4594           s2=scalar2(b1(1,i+1),auxvec(1))
4595           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4596           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4597           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4598           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4599           a_temp(1,1)=aggi1(l,1)
4600           a_temp(1,2)=aggi1(l,2)
4601           a_temp(2,1)=aggi1(l,3)
4602           a_temp(2,2)=aggi1(l,4)
4603           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4604           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4605           s1=scalar2(b1(1,i+2),auxvec(1))
4606           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4607           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4608           s2=scalar2(b1(1,i+1),auxvec(1))
4609           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4610           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4611           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4612           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4613           a_temp(1,1)=aggj(l,1)
4614           a_temp(1,2)=aggj(l,2)
4615           a_temp(2,1)=aggj(l,3)
4616           a_temp(2,2)=aggj(l,4)
4617           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4618           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4619           s1=scalar2(b1(1,i+2),auxvec(1))
4620           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4621           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4622           s2=scalar2(b1(1,i+1),auxvec(1))
4623           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4624           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4625           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4626           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4627           a_temp(1,1)=aggj1(l,1)
4628           a_temp(1,2)=aggj1(l,2)
4629           a_temp(2,1)=aggj1(l,3)
4630           a_temp(2,2)=aggj1(l,4)
4631           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4632           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4633           s1=scalar2(b1(1,i+2),auxvec(1))
4634           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4635           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4636           s2=scalar2(b1(1,i+1),auxvec(1))
4637           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4638           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4639           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4640 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4641           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4642         enddo
4643       return
4644       end
4645 C-----------------------------------------------------------------------------
4646       subroutine vecpr(u,v,w)
4647       implicit real*8(a-h,o-z)
4648       dimension u(3),v(3),w(3)
4649       w(1)=u(2)*v(3)-u(3)*v(2)
4650       w(2)=-u(1)*v(3)+u(3)*v(1)
4651       w(3)=u(1)*v(2)-u(2)*v(1)
4652       return
4653       end
4654 C-----------------------------------------------------------------------------
4655       subroutine unormderiv(u,ugrad,unorm,ungrad)
4656 C This subroutine computes the derivatives of a normalized vector u, given
4657 C the derivatives computed without normalization conditions, ugrad. Returns
4658 C ungrad.
4659       implicit none
4660       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4661       double precision vec(3)
4662       double precision scalar
4663       integer i,j
4664 c      write (2,*) 'ugrad',ugrad
4665 c      write (2,*) 'u',u
4666       do i=1,3
4667         vec(i)=scalar(ugrad(1,i),u(1))
4668       enddo
4669 c      write (2,*) 'vec',vec
4670       do i=1,3
4671         do j=1,3
4672           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4673         enddo
4674       enddo
4675 c      write (2,*) 'ungrad',ungrad
4676       return
4677       end
4678 C-----------------------------------------------------------------------------
4679       subroutine escp_soft_sphere(evdw2,evdw2_14)
4680 C
4681 C This subroutine calculates the excluded-volume interaction energy between
4682 C peptide-group centers and side chains and its gradient in virtual-bond and
4683 C side-chain vectors.
4684 C
4685       implicit real*8 (a-h,o-z)
4686       include 'DIMENSIONS'
4687       include 'COMMON.GEO'
4688       include 'COMMON.VAR'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.CHAIN'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.INTERACT'
4693       include 'COMMON.FFIELD'
4694       include 'COMMON.IOUNITS'
4695       include 'COMMON.CONTROL'
4696       dimension ggg(3)
4697       evdw2=0.0D0
4698       evdw2_14=0.0d0
4699       r0_scp=4.5d0
4700 cd    print '(a)','Enter ESCP'
4701 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4702 C      do xshift=-1,1
4703 C      do yshift=-1,1
4704 C      do zshift=-1,1
4705       do i=iatscp_s,iatscp_e
4706         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4707         iteli=itel(i)
4708         xi=0.5D0*(c(1,i)+c(1,i+1))
4709         yi=0.5D0*(c(2,i)+c(2,i+1))
4710         zi=0.5D0*(c(3,i)+c(3,i+1))
4711 C Return atom into box, boxxsize is size of box in x dimension
4712 c  134   continue
4713 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4714 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4715 C Condition for being inside the proper box
4716 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4717 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4718 c        go to 134
4719 c        endif
4720 c  135   continue
4721 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4722 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4723 C Condition for being inside the proper box
4724 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4725 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4726 c        go to 135
4727 c c       endif
4728 c  136   continue
4729 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4730 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4731 cC Condition for being inside the proper box
4732 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4733 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4734 c        go to 136
4735 c        endif
4736           xi=mod(xi,boxxsize)
4737           if (xi.lt.0) xi=xi+boxxsize
4738           yi=mod(yi,boxysize)
4739           if (yi.lt.0) yi=yi+boxysize
4740           zi=mod(zi,boxzsize)
4741           if (zi.lt.0) zi=zi+boxzsize
4742 C          xi=xi+xshift*boxxsize
4743 C          yi=yi+yshift*boxysize
4744 C          zi=zi+zshift*boxzsize
4745         do iint=1,nscp_gr(i)
4746
4747         do j=iscpstart(i,iint),iscpend(i,iint)
4748           if (itype(j).eq.ntyp1) cycle
4749           itypj=iabs(itype(j))
4750 C Uncomment following three lines for SC-p interactions
4751 c         xj=c(1,nres+j)-xi
4752 c         yj=c(2,nres+j)-yi
4753 c         zj=c(3,nres+j)-zi
4754 C Uncomment following three lines for Ca-p interactions
4755           xj=c(1,j)
4756           yj=c(2,j)
4757           zj=c(3,j)
4758 c  174   continue
4759 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4760 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4761 C Condition for being inside the proper box
4762 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4763 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4764 c        go to 174
4765 c        endif
4766 c  175   continue
4767 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4768 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4769 cC Condition for being inside the proper box
4770 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4771 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4772 c        go to 175
4773 c        endif
4774 c  176   continue
4775 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4776 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4777 C Condition for being inside the proper box
4778 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4779 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4780 c        go to 176
4781           xj=mod(xj,boxxsize)
4782           if (xj.lt.0) xj=xj+boxxsize
4783           yj=mod(yj,boxysize)
4784           if (yj.lt.0) yj=yj+boxysize
4785           zj=mod(zj,boxzsize)
4786           if (zj.lt.0) zj=zj+boxzsize
4787       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4788       xj_safe=xj
4789       yj_safe=yj
4790       zj_safe=zj
4791       subchap=0
4792       do xshift=-1,1
4793       do yshift=-1,1
4794       do zshift=-1,1
4795           xj=xj_safe+xshift*boxxsize
4796           yj=yj_safe+yshift*boxysize
4797           zj=zj_safe+zshift*boxzsize
4798           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4799           if(dist_temp.lt.dist_init) then
4800             dist_init=dist_temp
4801             xj_temp=xj
4802             yj_temp=yj
4803             zj_temp=zj
4804             subchap=1
4805           endif
4806        enddo
4807        enddo
4808        enddo
4809        if (subchap.eq.1) then
4810           xj=xj_temp-xi
4811           yj=yj_temp-yi
4812           zj=zj_temp-zi
4813        else
4814           xj=xj_safe-xi
4815           yj=yj_safe-yi
4816           zj=zj_safe-zi
4817        endif
4818 c c       endif
4819 C          xj=xj-xi
4820 C          yj=yj-yi
4821 C          zj=zj-zi
4822           rij=xj*xj+yj*yj+zj*zj
4823
4824           r0ij=r0_scp
4825           r0ijsq=r0ij*r0ij
4826           if (rij.lt.r0ijsq) then
4827             evdwij=0.25d0*(rij-r0ijsq)**2
4828             fac=rij-r0ijsq
4829           else
4830             evdwij=0.0d0
4831             fac=0.0d0
4832           endif
4833           evdw2=evdw2+evdwij
4834 C
4835 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4836 C
4837           ggg(1)=xj*fac
4838           ggg(2)=yj*fac
4839           ggg(3)=zj*fac
4840 cgrad          if (j.lt.i) then
4841 cd          write (iout,*) 'j<i'
4842 C Uncomment following three lines for SC-p interactions
4843 c           do k=1,3
4844 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4845 c           enddo
4846 cgrad          else
4847 cd          write (iout,*) 'j>i'
4848 cgrad            do k=1,3
4849 cgrad              ggg(k)=-ggg(k)
4850 C Uncomment following line for SC-p interactions
4851 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4852 cgrad            enddo
4853 cgrad          endif
4854 cgrad          do k=1,3
4855 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4856 cgrad          enddo
4857 cgrad          kstart=min0(i+1,j)
4858 cgrad          kend=max0(i-1,j-1)
4859 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4860 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4861 cgrad          do k=kstart,kend
4862 cgrad            do l=1,3
4863 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4864 cgrad            enddo
4865 cgrad          enddo
4866           do k=1,3
4867             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4868             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4869           enddo
4870         enddo
4871
4872         enddo ! iint
4873       enddo ! i
4874 C      enddo !zshift
4875 C      enddo !yshift
4876 C      enddo !xshift
4877       return
4878       end
4879 C-----------------------------------------------------------------------------
4880       subroutine escp(evdw2,evdw2_14)
4881 C
4882 C This subroutine calculates the excluded-volume interaction energy between
4883 C peptide-group centers and side chains and its gradient in virtual-bond and
4884 C side-chain vectors.
4885 C
4886       implicit real*8 (a-h,o-z)
4887       include 'DIMENSIONS'
4888       include 'COMMON.GEO'
4889       include 'COMMON.VAR'
4890       include 'COMMON.LOCAL'
4891       include 'COMMON.CHAIN'
4892       include 'COMMON.DERIV'
4893       include 'COMMON.INTERACT'
4894       include 'COMMON.FFIELD'
4895       include 'COMMON.IOUNITS'
4896       include 'COMMON.CONTROL'
4897       include 'COMMON.SPLITELE'
4898       dimension ggg(3)
4899       evdw2=0.0D0
4900       evdw2_14=0.0d0
4901 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4902 cd    print '(a)','Enter ESCP'
4903 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4904 C      do xshift=-1,1
4905 C      do yshift=-1,1
4906 C      do zshift=-1,1
4907       do i=iatscp_s,iatscp_e
4908         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4909         iteli=itel(i)
4910         xi=0.5D0*(c(1,i)+c(1,i+1))
4911         yi=0.5D0*(c(2,i)+c(2,i+1))
4912         zi=0.5D0*(c(3,i)+c(3,i+1))
4913           xi=mod(xi,boxxsize)
4914           if (xi.lt.0) xi=xi+boxxsize
4915           yi=mod(yi,boxysize)
4916           if (yi.lt.0) yi=yi+boxysize
4917           zi=mod(zi,boxzsize)
4918           if (zi.lt.0) zi=zi+boxzsize
4919 c          xi=xi+xshift*boxxsize
4920 c          yi=yi+yshift*boxysize
4921 c          zi=zi+zshift*boxzsize
4922 c        print *,xi,yi,zi,'polozenie i'
4923 C Return atom into box, boxxsize is size of box in x dimension
4924 c  134   continue
4925 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4926 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4927 C Condition for being inside the proper box
4928 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4929 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4930 c        go to 134
4931 c        endif
4932 c  135   continue
4933 c          print *,xi,boxxsize,"pierwszy"
4934
4935 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4936 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4937 C Condition for being inside the proper box
4938 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4939 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4940 c        go to 135
4941 c        endif
4942 c  136   continue
4943 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4944 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4945 C Condition for being inside the proper box
4946 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4947 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4948 c        go to 136
4949 c        endif
4950         do iint=1,nscp_gr(i)
4951
4952         do j=iscpstart(i,iint),iscpend(i,iint)
4953           itypj=iabs(itype(j))
4954           if (itypj.eq.ntyp1) cycle
4955 C Uncomment following three lines for SC-p interactions
4956 c         xj=c(1,nres+j)-xi
4957 c         yj=c(2,nres+j)-yi
4958 c         zj=c(3,nres+j)-zi
4959 C Uncomment following three lines for Ca-p interactions
4960           xj=c(1,j)
4961           yj=c(2,j)
4962           zj=c(3,j)
4963           xj=mod(xj,boxxsize)
4964           if (xj.lt.0) xj=xj+boxxsize
4965           yj=mod(yj,boxysize)
4966           if (yj.lt.0) yj=yj+boxysize
4967           zj=mod(zj,boxzsize)
4968           if (zj.lt.0) zj=zj+boxzsize
4969 c  174   continue
4970 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4971 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4972 C Condition for being inside the proper box
4973 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4974 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4975 c        go to 174
4976 c        endif
4977 c  175   continue
4978 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4979 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4980 cC Condition for being inside the proper box
4981 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4982 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4983 c        go to 175
4984 c        endif
4985 c  176   continue
4986 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4987 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4988 C Condition for being inside the proper box
4989 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4990 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4991 c        go to 176
4992 c        endif
4993 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4994       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4995       xj_safe=xj
4996       yj_safe=yj
4997       zj_safe=zj
4998       subchap=0
4999       do xshift=-1,1
5000       do yshift=-1,1
5001       do zshift=-1,1
5002           xj=xj_safe+xshift*boxxsize
5003           yj=yj_safe+yshift*boxysize
5004           zj=zj_safe+zshift*boxzsize
5005           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5006           if(dist_temp.lt.dist_init) then
5007             dist_init=dist_temp
5008             xj_temp=xj
5009             yj_temp=yj
5010             zj_temp=zj
5011             subchap=1
5012           endif
5013        enddo
5014        enddo
5015        enddo
5016        if (subchap.eq.1) then
5017           xj=xj_temp-xi
5018           yj=yj_temp-yi
5019           zj=zj_temp-zi
5020        else
5021           xj=xj_safe-xi
5022           yj=yj_safe-yi
5023           zj=zj_safe-zi
5024        endif
5025 c          print *,xj,yj,zj,'polozenie j'
5026           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5027 c          print *,rrij
5028           sss=sscale(1.0d0/(dsqrt(rrij)))
5029 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5030 c          if (sss.eq.0) print *,'czasem jest OK'
5031           if (sss.le.0.0d0) cycle
5032           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5033           fac=rrij**expon2
5034           e1=fac*fac*aad(itypj,iteli)
5035           e2=fac*bad(itypj,iteli)
5036           if (iabs(j-i) .le. 2) then
5037             e1=scal14*e1
5038             e2=scal14*e2
5039             evdw2_14=evdw2_14+(e1+e2)*sss
5040           endif
5041           evdwij=e1+e2
5042           evdw2=evdw2+evdwij*sss
5043           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5044      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5045      &       bad(itypj,iteli)
5046 C
5047 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5048 C
5049           fac=-(evdwij+e1)*rrij*sss
5050           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5051           ggg(1)=xj*fac
5052           ggg(2)=yj*fac
5053           ggg(3)=zj*fac
5054 cgrad          if (j.lt.i) then
5055 cd          write (iout,*) 'j<i'
5056 C Uncomment following three lines for SC-p interactions
5057 c           do k=1,3
5058 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5059 c           enddo
5060 cgrad          else
5061 cd          write (iout,*) 'j>i'
5062 cgrad            do k=1,3
5063 cgrad              ggg(k)=-ggg(k)
5064 C Uncomment following line for SC-p interactions
5065 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5066 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5067 cgrad            enddo
5068 cgrad          endif
5069 cgrad          do k=1,3
5070 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5071 cgrad          enddo
5072 cgrad          kstart=min0(i+1,j)
5073 cgrad          kend=max0(i-1,j-1)
5074 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5075 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5076 cgrad          do k=kstart,kend
5077 cgrad            do l=1,3
5078 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5079 cgrad            enddo
5080 cgrad          enddo
5081           do k=1,3
5082             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5083             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5084           enddo
5085 c        endif !endif for sscale cutoff
5086         enddo ! j
5087
5088         enddo ! iint
5089       enddo ! i
5090 c      enddo !zshift
5091 c      enddo !yshift
5092 c      enddo !xshift
5093       do i=1,nct
5094         do j=1,3
5095           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5096           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5097           gradx_scp(j,i)=expon*gradx_scp(j,i)
5098         enddo
5099       enddo
5100 C******************************************************************************
5101 C
5102 C                              N O T E !!!
5103 C
5104 C To save time the factor EXPON has been extracted from ALL components
5105 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5106 C use!
5107 C
5108 C******************************************************************************
5109       return
5110       end
5111 C--------------------------------------------------------------------------
5112       subroutine edis(ehpb)
5113 C
5114 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5115 C
5116       implicit real*8 (a-h,o-z)
5117       include 'DIMENSIONS'
5118       include 'COMMON.SBRIDGE'
5119       include 'COMMON.CHAIN'
5120       include 'COMMON.DERIV'
5121       include 'COMMON.VAR'
5122       include 'COMMON.INTERACT'
5123       include 'COMMON.IOUNITS'
5124       dimension ggg(3)
5125       ehpb=0.0D0
5126 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5127 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5128       if (link_end.eq.0) return
5129       do i=link_start,link_end
5130 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5131 C CA-CA distance used in regularization of structure.
5132         ii=ihpb(i)
5133         jj=jhpb(i)
5134 C iii and jjj point to the residues for which the distance is assigned.
5135         if (ii.gt.nres) then
5136           iii=ii-nres
5137           jjj=jj-nres
5138         else
5139           iii=ii
5140           jjj=jj
5141         endif
5142 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5143 c     &    dhpb(i),dhpb1(i),forcon(i)
5144 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5145 C    distance and angle dependent SS bond potential.
5146 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5147 C     & iabs(itype(jjj)).eq.1) then
5148 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5149 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5150         if (.not.dyn_ss .and. i.le.nss) then
5151 C 15/02/13 CC dynamic SSbond - additional check
5152          if (ii.gt.nres
5153      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5154           call ssbond_ene(iii,jjj,eij)
5155           ehpb=ehpb+2*eij
5156          endif
5157 cd          write (iout,*) "eij",eij
5158         else
5159 C Calculate the distance between the two points and its difference from the
5160 C target distance.
5161           dd=dist(ii,jj)
5162             rdis=dd-dhpb(i)
5163 C Get the force constant corresponding to this distance.
5164             waga=forcon(i)
5165 C Calculate the contribution to energy.
5166             ehpb=ehpb+waga*rdis*rdis
5167 C
5168 C Evaluate gradient.
5169 C
5170             fac=waga*rdis/dd
5171 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5172 cd   &   ' waga=',waga,' fac=',fac
5173             do j=1,3
5174               ggg(j)=fac*(c(j,jj)-c(j,ii))
5175             enddo
5176 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5177 C If this is a SC-SC distance, we need to calculate the contributions to the
5178 C Cartesian gradient in the SC vectors (ghpbx).
5179           if (iii.lt.ii) then
5180           do j=1,3
5181             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5182             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5183           enddo
5184           endif
5185 cgrad        do j=iii,jjj-1
5186 cgrad          do k=1,3
5187 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5188 cgrad          enddo
5189 cgrad        enddo
5190           do k=1,3
5191             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5192             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5193           enddo
5194         endif
5195       enddo
5196       ehpb=0.5D0*ehpb
5197       return
5198       end
5199 C--------------------------------------------------------------------------
5200       subroutine ssbond_ene(i,j,eij)
5201 C
5202 C Calculate the distance and angle dependent SS-bond potential energy
5203 C using a free-energy function derived based on RHF/6-31G** ab initio
5204 C calculations of diethyl disulfide.
5205 C
5206 C A. Liwo and U. Kozlowska, 11/24/03
5207 C
5208       implicit real*8 (a-h,o-z)
5209       include 'DIMENSIONS'
5210       include 'COMMON.SBRIDGE'
5211       include 'COMMON.CHAIN'
5212       include 'COMMON.DERIV'
5213       include 'COMMON.LOCAL'
5214       include 'COMMON.INTERACT'
5215       include 'COMMON.VAR'
5216       include 'COMMON.IOUNITS'
5217       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5218       itypi=iabs(itype(i))
5219       xi=c(1,nres+i)
5220       yi=c(2,nres+i)
5221       zi=c(3,nres+i)
5222       dxi=dc_norm(1,nres+i)
5223       dyi=dc_norm(2,nres+i)
5224       dzi=dc_norm(3,nres+i)
5225 c      dsci_inv=dsc_inv(itypi)
5226       dsci_inv=vbld_inv(nres+i)
5227       itypj=iabs(itype(j))
5228 c      dscj_inv=dsc_inv(itypj)
5229       dscj_inv=vbld_inv(nres+j)
5230       xj=c(1,nres+j)-xi
5231       yj=c(2,nres+j)-yi
5232       zj=c(3,nres+j)-zi
5233       dxj=dc_norm(1,nres+j)
5234       dyj=dc_norm(2,nres+j)
5235       dzj=dc_norm(3,nres+j)
5236       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5237       rij=dsqrt(rrij)
5238       erij(1)=xj*rij
5239       erij(2)=yj*rij
5240       erij(3)=zj*rij
5241       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5242       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5243       om12=dxi*dxj+dyi*dyj+dzi*dzj
5244       do k=1,3
5245         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5246         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5247       enddo
5248       rij=1.0d0/rij
5249       deltad=rij-d0cm
5250       deltat1=1.0d0-om1
5251       deltat2=1.0d0+om2
5252       deltat12=om2-om1+2.0d0
5253       cosphi=om12-om1*om2
5254       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5255      &  +akct*deltad*deltat12
5256      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5257 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5258 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5259 c     &  " deltat12",deltat12," eij",eij
5260       ed=2*akcm*deltad+akct*deltat12
5261       pom1=akct*deltad
5262       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5263       eom1=-2*akth*deltat1-pom1-om2*pom2
5264       eom2= 2*akth*deltat2+pom1-om1*pom2
5265       eom12=pom2
5266       do k=1,3
5267         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5268         ghpbx(k,i)=ghpbx(k,i)-ggk
5269      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5270      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5271         ghpbx(k,j)=ghpbx(k,j)+ggk
5272      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5273      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5274         ghpbc(k,i)=ghpbc(k,i)-ggk
5275         ghpbc(k,j)=ghpbc(k,j)+ggk
5276       enddo
5277 C
5278 C Calculate the components of the gradient in DC and X
5279 C
5280 cgrad      do k=i,j-1
5281 cgrad        do l=1,3
5282 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5283 cgrad        enddo
5284 cgrad      enddo
5285       return
5286       end
5287 C--------------------------------------------------------------------------
5288       subroutine ebond(estr)
5289 c
5290 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5291 c
5292       implicit real*8 (a-h,o-z)
5293       include 'DIMENSIONS'
5294       include 'COMMON.LOCAL'
5295       include 'COMMON.GEO'
5296       include 'COMMON.INTERACT'
5297       include 'COMMON.DERIV'
5298       include 'COMMON.VAR'
5299       include 'COMMON.CHAIN'
5300       include 'COMMON.IOUNITS'
5301       include 'COMMON.NAMES'
5302       include 'COMMON.FFIELD'
5303       include 'COMMON.CONTROL'
5304       include 'COMMON.SETUP'
5305       double precision u(3),ud(3)
5306       estr=0.0d0
5307       estr1=0.0d0
5308       do i=ibondp_start,ibondp_end
5309         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5310 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5311 c          do j=1,3
5312 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5313 c     &      *dc(j,i-1)/vbld(i)
5314 c          enddo
5315 c          if (energy_dec) write(iout,*)
5316 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5317 c        else
5318 C       Checking if it involves dummy (NH3+ or COO-) group
5319          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5320 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5321         diff = vbld(i)-vbldpDUM
5322          else
5323 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5324         diff = vbld(i)-vbldp0
5325          endif
5326         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5327      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5328         estr=estr+diff*diff
5329         do j=1,3
5330           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5331         enddo
5332 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5333 c        endif
5334       enddo
5335       estr=0.5d0*AKP*estr+estr1
5336 c
5337 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5338 c
5339       do i=ibond_start,ibond_end
5340         iti=iabs(itype(i))
5341         if (iti.ne.10 .and. iti.ne.ntyp1) then
5342           nbi=nbondterm(iti)
5343           if (nbi.eq.1) then
5344             diff=vbld(i+nres)-vbldsc0(1,iti)
5345             if (energy_dec)  write (iout,*)
5346      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5347      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5348             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5349             do j=1,3
5350               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5351             enddo
5352           else
5353             do j=1,nbi
5354               diff=vbld(i+nres)-vbldsc0(j,iti)
5355               ud(j)=aksc(j,iti)*diff
5356               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5357             enddo
5358             uprod=u(1)
5359             do j=2,nbi
5360               uprod=uprod*u(j)
5361             enddo
5362             usum=0.0d0
5363             usumsqder=0.0d0
5364             do j=1,nbi
5365               uprod1=1.0d0
5366               uprod2=1.0d0
5367               do k=1,nbi
5368                 if (k.ne.j) then
5369                   uprod1=uprod1*u(k)
5370                   uprod2=uprod2*u(k)*u(k)
5371                 endif
5372               enddo
5373               usum=usum+uprod1
5374               usumsqder=usumsqder+ud(j)*uprod2
5375             enddo
5376             estr=estr+uprod/usum
5377             do j=1,3
5378              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5379             enddo
5380           endif
5381         endif
5382       enddo
5383       return
5384       end
5385 #ifdef CRYST_THETA
5386 C--------------------------------------------------------------------------
5387       subroutine ebend(etheta)
5388 C
5389 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5390 C angles gamma and its derivatives in consecutive thetas and gammas.
5391 C
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.GEO'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.DERIV'
5398       include 'COMMON.VAR'
5399       include 'COMMON.CHAIN'
5400       include 'COMMON.IOUNITS'
5401       include 'COMMON.NAMES'
5402       include 'COMMON.FFIELD'
5403       include 'COMMON.CONTROL'
5404       common /calcthet/ term1,term2,termm,diffak,ratak,
5405      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5406      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5407       double precision y(2),z(2)
5408       delta=0.02d0*pi
5409 c      time11=dexp(-2*time)
5410 c      time12=1.0d0
5411       etheta=0.0D0
5412 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5413       do i=ithet_start,ithet_end
5414         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5415      &  .or.itype(i).eq.ntyp1) cycle
5416 C Zero the energy function and its derivative at 0 or pi.
5417         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5418         it=itype(i-1)
5419         ichir1=isign(1,itype(i-2))
5420         ichir2=isign(1,itype(i))
5421          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5422          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5423          if (itype(i-1).eq.10) then
5424           itype1=isign(10,itype(i-2))
5425           ichir11=isign(1,itype(i-2))
5426           ichir12=isign(1,itype(i-2))
5427           itype2=isign(10,itype(i))
5428           ichir21=isign(1,itype(i))
5429           ichir22=isign(1,itype(i))
5430          endif
5431
5432         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5433 #ifdef OSF
5434           phii=phi(i)
5435           if (phii.ne.phii) phii=150.0
5436 #else
5437           phii=phi(i)
5438 #endif
5439           y(1)=dcos(phii)
5440           y(2)=dsin(phii)
5441         else
5442           y(1)=0.0D0
5443           y(2)=0.0D0
5444         endif
5445         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5446 #ifdef OSF
5447           phii1=phi(i+1)
5448           if (phii1.ne.phii1) phii1=150.0
5449           phii1=pinorm(phii1)
5450           z(1)=cos(phii1)
5451 #else
5452           phii1=phi(i+1)
5453 #endif
5454           z(1)=dcos(phii1)
5455           z(2)=dsin(phii1)
5456         else
5457           z(1)=0.0D0
5458           z(2)=0.0D0
5459         endif
5460 C Calculate the "mean" value of theta from the part of the distribution
5461 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5462 C In following comments this theta will be referred to as t_c.
5463         thet_pred_mean=0.0d0
5464         do k=1,2
5465             athetk=athet(k,it,ichir1,ichir2)
5466             bthetk=bthet(k,it,ichir1,ichir2)
5467           if (it.eq.10) then
5468              athetk=athet(k,itype1,ichir11,ichir12)
5469              bthetk=bthet(k,itype2,ichir21,ichir22)
5470           endif
5471          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5472 c         write(iout,*) 'chuj tu', y(k),z(k)
5473         enddo
5474         dthett=thet_pred_mean*ssd
5475         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5476 C Derivatives of the "mean" values in gamma1 and gamma2.
5477         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5478      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5479          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5480      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5481          if (it.eq.10) then
5482       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5483      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5484         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5485      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5486          endif
5487         if (theta(i).gt.pi-delta) then
5488           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5489      &         E_tc0)
5490           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5491           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5492           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5493      &        E_theta)
5494           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5495      &        E_tc)
5496         else if (theta(i).lt.delta) then
5497           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5498           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5499           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5500      &        E_theta)
5501           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5502           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5503      &        E_tc)
5504         else
5505           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5506      &        E_theta,E_tc)
5507         endif
5508         etheta=etheta+ethetai
5509         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5510      &      'ebend',i,ethetai,theta(i),itype(i)
5511         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5512         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5513         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5514       enddo
5515 C Ufff.... We've done all this!!!
5516       return
5517       end
5518 C---------------------------------------------------------------------------
5519       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5520      &     E_tc)
5521       implicit real*8 (a-h,o-z)
5522       include 'DIMENSIONS'
5523       include 'COMMON.LOCAL'
5524       include 'COMMON.IOUNITS'
5525       common /calcthet/ term1,term2,termm,diffak,ratak,
5526      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5527      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5528 C Calculate the contributions to both Gaussian lobes.
5529 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5530 C The "polynomial part" of the "standard deviation" of this part of
5531 C the distributioni.
5532 ccc        write (iout,*) thetai,thet_pred_mean
5533         sig=polthet(3,it)
5534         do j=2,0,-1
5535           sig=sig*thet_pred_mean+polthet(j,it)
5536         enddo
5537 C Derivative of the "interior part" of the "standard deviation of the"
5538 C gamma-dependent Gaussian lobe in t_c.
5539         sigtc=3*polthet(3,it)
5540         do j=2,1,-1
5541           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5542         enddo
5543         sigtc=sig*sigtc
5544 C Set the parameters of both Gaussian lobes of the distribution.
5545 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5546         fac=sig*sig+sigc0(it)
5547         sigcsq=fac+fac
5548         sigc=1.0D0/sigcsq
5549 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5550         sigsqtc=-4.0D0*sigcsq*sigtc
5551 c       print *,i,sig,sigtc,sigsqtc
5552 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5553         sigtc=-sigtc/(fac*fac)
5554 C Following variable is sigma(t_c)**(-2)
5555         sigcsq=sigcsq*sigcsq
5556         sig0i=sig0(it)
5557         sig0inv=1.0D0/sig0i**2
5558         delthec=thetai-thet_pred_mean
5559         delthe0=thetai-theta0i
5560         term1=-0.5D0*sigcsq*delthec*delthec
5561         term2=-0.5D0*sig0inv*delthe0*delthe0
5562 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5563 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5564 C NaNs in taking the logarithm. We extract the largest exponent which is added
5565 C to the energy (this being the log of the distribution) at the end of energy
5566 C term evaluation for this virtual-bond angle.
5567         if (term1.gt.term2) then
5568           termm=term1
5569           term2=dexp(term2-termm)
5570           term1=1.0d0
5571         else
5572           termm=term2
5573           term1=dexp(term1-termm)
5574           term2=1.0d0
5575         endif
5576 C The ratio between the gamma-independent and gamma-dependent lobes of
5577 C the distribution is a Gaussian function of thet_pred_mean too.
5578         diffak=gthet(2,it)-thet_pred_mean
5579         ratak=diffak/gthet(3,it)**2
5580         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5581 C Let's differentiate it in thet_pred_mean NOW.
5582         aktc=ak*ratak
5583 C Now put together the distribution terms to make complete distribution.
5584         termexp=term1+ak*term2
5585         termpre=sigc+ak*sig0i
5586 C Contribution of the bending energy from this theta is just the -log of
5587 C the sum of the contributions from the two lobes and the pre-exponential
5588 C factor. Simple enough, isn't it?
5589         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5590 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5591 C NOW the derivatives!!!
5592 C 6/6/97 Take into account the deformation.
5593         E_theta=(delthec*sigcsq*term1
5594      &       +ak*delthe0*sig0inv*term2)/termexp
5595         E_tc=((sigtc+aktc*sig0i)/termpre
5596      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5597      &       aktc*term2)/termexp)
5598       return
5599       end
5600 c-----------------------------------------------------------------------------
5601       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'COMMON.LOCAL'
5605       include 'COMMON.IOUNITS'
5606       common /calcthet/ term1,term2,termm,diffak,ratak,
5607      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5608      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5609       delthec=thetai-thet_pred_mean
5610       delthe0=thetai-theta0i
5611 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5612       t3 = thetai-thet_pred_mean
5613       t6 = t3**2
5614       t9 = term1
5615       t12 = t3*sigcsq
5616       t14 = t12+t6*sigsqtc
5617       t16 = 1.0d0
5618       t21 = thetai-theta0i
5619       t23 = t21**2
5620       t26 = term2
5621       t27 = t21*t26
5622       t32 = termexp
5623       t40 = t32**2
5624       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5625      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5626      & *(-t12*t9-ak*sig0inv*t27)
5627       return
5628       end
5629 #else
5630 C--------------------------------------------------------------------------
5631       subroutine ebend(etheta)
5632 C
5633 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5634 C angles gamma and its derivatives in consecutive thetas and gammas.
5635 C ab initio-derived potentials from
5636 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5637 C
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'COMMON.LOCAL'
5641       include 'COMMON.GEO'
5642       include 'COMMON.INTERACT'
5643       include 'COMMON.DERIV'
5644       include 'COMMON.VAR'
5645       include 'COMMON.CHAIN'
5646       include 'COMMON.IOUNITS'
5647       include 'COMMON.NAMES'
5648       include 'COMMON.FFIELD'
5649       include 'COMMON.CONTROL'
5650       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5651      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5652      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5653      & sinph1ph2(maxdouble,maxdouble)
5654       logical lprn /.false./, lprn1 /.false./
5655       etheta=0.0D0
5656       do i=ithet_start,ithet_end
5657 c        print *,i,itype(i-1),itype(i),itype(i-2)
5658         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5659      &  .or.itype(i).eq.ntyp1) cycle
5660 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5661
5662         if (iabs(itype(i+1)).eq.20) iblock=2
5663         if (iabs(itype(i+1)).ne.20) iblock=1
5664         dethetai=0.0d0
5665         dephii=0.0d0
5666         dephii1=0.0d0
5667         theti2=0.5d0*theta(i)
5668         ityp2=ithetyp((itype(i-1)))
5669         do k=1,nntheterm
5670           coskt(k)=dcos(k*theti2)
5671           sinkt(k)=dsin(k*theti2)
5672         enddo
5673         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5674 #ifdef OSF
5675           phii=phi(i)
5676           if (phii.ne.phii) phii=150.0
5677 #else
5678           phii=phi(i)
5679 #endif
5680           ityp1=ithetyp((itype(i-2)))
5681 C propagation of chirality for glycine type
5682           do k=1,nsingle
5683             cosph1(k)=dcos(k*phii)
5684             sinph1(k)=dsin(k*phii)
5685           enddo
5686         else
5687           phii=0.0d0
5688           ityp1=nthetyp+1
5689           do k=1,nsingle
5690             cosph1(k)=0.0d0
5691             sinph1(k)=0.0d0
5692           enddo
5693         endif
5694         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5695 #ifdef OSF
5696           phii1=phi(i+1)
5697           if (phii1.ne.phii1) phii1=150.0
5698           phii1=pinorm(phii1)
5699 #else
5700           phii1=phi(i+1)
5701 #endif
5702           ityp3=ithetyp((itype(i)))
5703           do k=1,nsingle
5704             cosph2(k)=dcos(k*phii1)
5705             sinph2(k)=dsin(k*phii1)
5706           enddo
5707         else
5708           phii1=0.0d0
5709           ityp3=nthetyp+1
5710           do k=1,nsingle
5711             cosph2(k)=0.0d0
5712             sinph2(k)=0.0d0
5713           enddo
5714         endif
5715         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5716         do k=1,ndouble
5717           do l=1,k-1
5718             ccl=cosph1(l)*cosph2(k-l)
5719             ssl=sinph1(l)*sinph2(k-l)
5720             scl=sinph1(l)*cosph2(k-l)
5721             csl=cosph1(l)*sinph2(k-l)
5722             cosph1ph2(l,k)=ccl-ssl
5723             cosph1ph2(k,l)=ccl+ssl
5724             sinph1ph2(l,k)=scl+csl
5725             sinph1ph2(k,l)=scl-csl
5726           enddo
5727         enddo
5728         if (lprn) then
5729         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5730      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5731         write (iout,*) "coskt and sinkt"
5732         do k=1,nntheterm
5733           write (iout,*) k,coskt(k),sinkt(k)
5734         enddo
5735         endif
5736         do k=1,ntheterm
5737           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5738           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5739      &      *coskt(k)
5740           if (lprn)
5741      &    write (iout,*) "k",k,"
5742      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5743      &     " ethetai",ethetai
5744         enddo
5745         if (lprn) then
5746         write (iout,*) "cosph and sinph"
5747         do k=1,nsingle
5748           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5749         enddo
5750         write (iout,*) "cosph1ph2 and sinph2ph2"
5751         do k=2,ndouble
5752           do l=1,k-1
5753             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5754      &         sinph1ph2(l,k),sinph1ph2(k,l)
5755           enddo
5756         enddo
5757         write(iout,*) "ethetai",ethetai
5758         endif
5759         do m=1,ntheterm2
5760           do k=1,nsingle
5761             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5762      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5763      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5764      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5765             ethetai=ethetai+sinkt(m)*aux
5766             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5767             dephii=dephii+k*sinkt(m)*(
5768      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5769      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5770             dephii1=dephii1+k*sinkt(m)*(
5771      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5772      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5773             if (lprn)
5774      &      write (iout,*) "m",m," k",k," bbthet",
5775      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5776      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5777      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5778      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5779           enddo
5780         enddo
5781         if (lprn)
5782      &  write(iout,*) "ethetai",ethetai
5783         do m=1,ntheterm3
5784           do k=2,ndouble
5785             do l=1,k-1
5786               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5787      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5788      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5789      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5790               ethetai=ethetai+sinkt(m)*aux
5791               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5792               dephii=dephii+l*sinkt(m)*(
5793      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5794      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5795      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5796      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5797               dephii1=dephii1+(k-l)*sinkt(m)*(
5798      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5799      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5800      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5801      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5802               if (lprn) then
5803               write (iout,*) "m",m," k",k," l",l," ffthet",
5804      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5805      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5806      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5807      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5808      &            " ethetai",ethetai
5809               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5810      &            cosph1ph2(k,l)*sinkt(m),
5811      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5812               endif
5813             enddo
5814           enddo
5815         enddo
5816 10      continue
5817 c        lprn1=.true.
5818         if (lprn1)
5819      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5820      &   i,theta(i)*rad2deg,phii*rad2deg,
5821      &   phii1*rad2deg,ethetai
5822 c        lprn1=.false.
5823         etheta=etheta+ethetai
5824         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5825         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5826         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5827       enddo
5828       return
5829       end
5830 #endif
5831 #ifdef CRYST_SC
5832 c-----------------------------------------------------------------------------
5833       subroutine esc(escloc)
5834 C Calculate the local energy of a side chain and its derivatives in the
5835 C corresponding virtual-bond valence angles THETA and the spherical angles
5836 C ALPHA and OMEGA.
5837       implicit real*8 (a-h,o-z)
5838       include 'DIMENSIONS'
5839       include 'COMMON.GEO'
5840       include 'COMMON.LOCAL'
5841       include 'COMMON.VAR'
5842       include 'COMMON.INTERACT'
5843       include 'COMMON.DERIV'
5844       include 'COMMON.CHAIN'
5845       include 'COMMON.IOUNITS'
5846       include 'COMMON.NAMES'
5847       include 'COMMON.FFIELD'
5848       include 'COMMON.CONTROL'
5849       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5850      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5851       common /sccalc/ time11,time12,time112,theti,it,nlobit
5852       delta=0.02d0*pi
5853       escloc=0.0D0
5854 c     write (iout,'(a)') 'ESC'
5855       do i=loc_start,loc_end
5856         it=itype(i)
5857         if (it.eq.ntyp1) cycle
5858         if (it.eq.10) goto 1
5859         nlobit=nlob(iabs(it))
5860 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5861 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5862         theti=theta(i+1)-pipol
5863         x(1)=dtan(theti)
5864         x(2)=alph(i)
5865         x(3)=omeg(i)
5866
5867         if (x(2).gt.pi-delta) then
5868           xtemp(1)=x(1)
5869           xtemp(2)=pi-delta
5870           xtemp(3)=x(3)
5871           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5872           xtemp(2)=pi
5873           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5874           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5875      &        escloci,dersc(2))
5876           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5877      &        ddersc0(1),dersc(1))
5878           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5879      &        ddersc0(3),dersc(3))
5880           xtemp(2)=pi-delta
5881           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5882           xtemp(2)=pi
5883           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5884           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5885      &            dersc0(2),esclocbi,dersc02)
5886           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5887      &            dersc12,dersc01)
5888           call splinthet(x(2),0.5d0*delta,ss,ssd)
5889           dersc0(1)=dersc01
5890           dersc0(2)=dersc02
5891           dersc0(3)=0.0d0
5892           do k=1,3
5893             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5894           enddo
5895           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5896 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5897 c    &             esclocbi,ss,ssd
5898           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5899 c         escloci=esclocbi
5900 c         write (iout,*) escloci
5901         else if (x(2).lt.delta) then
5902           xtemp(1)=x(1)
5903           xtemp(2)=delta
5904           xtemp(3)=x(3)
5905           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5906           xtemp(2)=0.0d0
5907           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5908           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5909      &        escloci,dersc(2))
5910           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5911      &        ddersc0(1),dersc(1))
5912           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5913      &        ddersc0(3),dersc(3))
5914           xtemp(2)=delta
5915           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5916           xtemp(2)=0.0d0
5917           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5918           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5919      &            dersc0(2),esclocbi,dersc02)
5920           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5921      &            dersc12,dersc01)
5922           dersc0(1)=dersc01
5923           dersc0(2)=dersc02
5924           dersc0(3)=0.0d0
5925           call splinthet(x(2),0.5d0*delta,ss,ssd)
5926           do k=1,3
5927             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5928           enddo
5929           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5930 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5931 c    &             esclocbi,ss,ssd
5932           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5933 c         write (iout,*) escloci
5934         else
5935           call enesc(x,escloci,dersc,ddummy,.false.)
5936         endif
5937
5938         escloc=escloc+escloci
5939         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5940      &     'escloc',i,escloci
5941 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5942
5943         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5944      &   wscloc*dersc(1)
5945         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5946         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5947     1   continue
5948       enddo
5949       return
5950       end
5951 C---------------------------------------------------------------------------
5952       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5953       implicit real*8 (a-h,o-z)
5954       include 'DIMENSIONS'
5955       include 'COMMON.GEO'
5956       include 'COMMON.LOCAL'
5957       include 'COMMON.IOUNITS'
5958       common /sccalc/ time11,time12,time112,theti,it,nlobit
5959       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5960       double precision contr(maxlob,-1:1)
5961       logical mixed
5962 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5963         escloc_i=0.0D0
5964         do j=1,3
5965           dersc(j)=0.0D0
5966           if (mixed) ddersc(j)=0.0d0
5967         enddo
5968         x3=x(3)
5969
5970 C Because of periodicity of the dependence of the SC energy in omega we have
5971 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5972 C To avoid underflows, first compute & store the exponents.
5973
5974         do iii=-1,1
5975
5976           x(3)=x3+iii*dwapi
5977
5978           do j=1,nlobit
5979             do k=1,3
5980               z(k)=x(k)-censc(k,j,it)
5981             enddo
5982             do k=1,3
5983               Axk=0.0D0
5984               do l=1,3
5985                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5986               enddo
5987               Ax(k,j,iii)=Axk
5988             enddo
5989             expfac=0.0D0
5990             do k=1,3
5991               expfac=expfac+Ax(k,j,iii)*z(k)
5992             enddo
5993             contr(j,iii)=expfac
5994           enddo ! j
5995
5996         enddo ! iii
5997
5998         x(3)=x3
5999 C As in the case of ebend, we want to avoid underflows in exponentiation and
6000 C subsequent NaNs and INFs in energy calculation.
6001 C Find the largest exponent
6002         emin=contr(1,-1)
6003         do iii=-1,1
6004           do j=1,nlobit
6005             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6006           enddo
6007         enddo
6008         emin=0.5D0*emin
6009 cd      print *,'it=',it,' emin=',emin
6010
6011 C Compute the contribution to SC energy and derivatives
6012         do iii=-1,1
6013
6014           do j=1,nlobit
6015 #ifdef OSF
6016             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6017             if(adexp.ne.adexp) adexp=1.0
6018             expfac=dexp(adexp)
6019 #else
6020             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6021 #endif
6022 cd          print *,'j=',j,' expfac=',expfac
6023             escloc_i=escloc_i+expfac
6024             do k=1,3
6025               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6026             enddo
6027             if (mixed) then
6028               do k=1,3,2
6029                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6030      &            +gaussc(k,2,j,it))*expfac
6031               enddo
6032             endif
6033           enddo
6034
6035         enddo ! iii
6036
6037         dersc(1)=dersc(1)/cos(theti)**2
6038         ddersc(1)=ddersc(1)/cos(theti)**2
6039         ddersc(3)=ddersc(3)
6040
6041         escloci=-(dlog(escloc_i)-emin)
6042         do j=1,3
6043           dersc(j)=dersc(j)/escloc_i
6044         enddo
6045         if (mixed) then
6046           do j=1,3,2
6047             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6048           enddo
6049         endif
6050       return
6051       end
6052 C------------------------------------------------------------------------------
6053       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6054       implicit real*8 (a-h,o-z)
6055       include 'DIMENSIONS'
6056       include 'COMMON.GEO'
6057       include 'COMMON.LOCAL'
6058       include 'COMMON.IOUNITS'
6059       common /sccalc/ time11,time12,time112,theti,it,nlobit
6060       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6061       double precision contr(maxlob)
6062       logical mixed
6063
6064       escloc_i=0.0D0
6065
6066       do j=1,3
6067         dersc(j)=0.0D0
6068       enddo
6069
6070       do j=1,nlobit
6071         do k=1,2
6072           z(k)=x(k)-censc(k,j,it)
6073         enddo
6074         z(3)=dwapi
6075         do k=1,3
6076           Axk=0.0D0
6077           do l=1,3
6078             Axk=Axk+gaussc(l,k,j,it)*z(l)
6079           enddo
6080           Ax(k,j)=Axk
6081         enddo
6082         expfac=0.0D0
6083         do k=1,3
6084           expfac=expfac+Ax(k,j)*z(k)
6085         enddo
6086         contr(j)=expfac
6087       enddo ! j
6088
6089 C As in the case of ebend, we want to avoid underflows in exponentiation and
6090 C subsequent NaNs and INFs in energy calculation.
6091 C Find the largest exponent
6092       emin=contr(1)
6093       do j=1,nlobit
6094         if (emin.gt.contr(j)) emin=contr(j)
6095       enddo
6096       emin=0.5D0*emin
6097
6098 C Compute the contribution to SC energy and derivatives
6099
6100       dersc12=0.0d0
6101       do j=1,nlobit
6102         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6103         escloc_i=escloc_i+expfac
6104         do k=1,2
6105           dersc(k)=dersc(k)+Ax(k,j)*expfac
6106         enddo
6107         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6108      &            +gaussc(1,2,j,it))*expfac
6109         dersc(3)=0.0d0
6110       enddo
6111
6112       dersc(1)=dersc(1)/cos(theti)**2
6113       dersc12=dersc12/cos(theti)**2
6114       escloci=-(dlog(escloc_i)-emin)
6115       do j=1,2
6116         dersc(j)=dersc(j)/escloc_i
6117       enddo
6118       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6119       return
6120       end
6121 #else
6122 c----------------------------------------------------------------------------------
6123       subroutine esc(escloc)
6124 C Calculate the local energy of a side chain and its derivatives in the
6125 C corresponding virtual-bond valence angles THETA and the spherical angles
6126 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6127 C added by Urszula Kozlowska. 07/11/2007
6128 C
6129       implicit real*8 (a-h,o-z)
6130       include 'DIMENSIONS'
6131       include 'COMMON.GEO'
6132       include 'COMMON.LOCAL'
6133       include 'COMMON.VAR'
6134       include 'COMMON.SCROT'
6135       include 'COMMON.INTERACT'
6136       include 'COMMON.DERIV'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.IOUNITS'
6139       include 'COMMON.NAMES'
6140       include 'COMMON.FFIELD'
6141       include 'COMMON.CONTROL'
6142       include 'COMMON.VECTORS'
6143       double precision x_prime(3),y_prime(3),z_prime(3)
6144      &    , sumene,dsc_i,dp2_i,x(65),
6145      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6146      &    de_dxx,de_dyy,de_dzz,de_dt
6147       double precision s1_t,s1_6_t,s2_t,s2_6_t
6148       double precision
6149      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6150      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6151      & dt_dCi(3),dt_dCi1(3)
6152       common /sccalc/ time11,time12,time112,theti,it,nlobit
6153       delta=0.02d0*pi
6154       escloc=0.0D0
6155       do i=loc_start,loc_end
6156         if (itype(i).eq.ntyp1) cycle
6157         costtab(i+1) =dcos(theta(i+1))
6158         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6159         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6160         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6161         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6162         cosfac=dsqrt(cosfac2)
6163         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6164         sinfac=dsqrt(sinfac2)
6165         it=iabs(itype(i))
6166         if (it.eq.10) goto 1
6167 c
6168 C  Compute the axes of tghe local cartesian coordinates system; store in
6169 c   x_prime, y_prime and z_prime
6170 c
6171         do j=1,3
6172           x_prime(j) = 0.00
6173           y_prime(j) = 0.00
6174           z_prime(j) = 0.00
6175         enddo
6176 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6177 C     &   dc_norm(3,i+nres)
6178         do j = 1,3
6179           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6180           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6181         enddo
6182         do j = 1,3
6183           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6184         enddo
6185 c       write (2,*) "i",i
6186 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6187 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6188 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6189 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6190 c      & " xy",scalar(x_prime(1),y_prime(1)),
6191 c      & " xz",scalar(x_prime(1),z_prime(1)),
6192 c      & " yy",scalar(y_prime(1),y_prime(1)),
6193 c      & " yz",scalar(y_prime(1),z_prime(1)),
6194 c      & " zz",scalar(z_prime(1),z_prime(1))
6195 c
6196 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6197 C to local coordinate system. Store in xx, yy, zz.
6198 c
6199         xx=0.0d0
6200         yy=0.0d0
6201         zz=0.0d0
6202         do j = 1,3
6203           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6204           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6205           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6206         enddo
6207
6208         xxtab(i)=xx
6209         yytab(i)=yy
6210         zztab(i)=zz
6211 C
6212 C Compute the energy of the ith side cbain
6213 C
6214 c        write (2,*) "xx",xx," yy",yy," zz",zz
6215         it=iabs(itype(i))
6216         do j = 1,65
6217           x(j) = sc_parmin(j,it)
6218         enddo
6219 #ifdef CHECK_COORD
6220 Cc diagnostics - remove later
6221         xx1 = dcos(alph(2))
6222         yy1 = dsin(alph(2))*dcos(omeg(2))
6223         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6224         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6225      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6226      &    xx1,yy1,zz1
6227 C,"  --- ", xx_w,yy_w,zz_w
6228 c end diagnostics
6229 #endif
6230         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6231      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6232      &   + x(10)*yy*zz
6233         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6234      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6235      & + x(20)*yy*zz
6236         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6237      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6238      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6239      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6240      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6241      &  +x(40)*xx*yy*zz
6242         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6243      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6244      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6245      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6246      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6247      &  +x(60)*xx*yy*zz
6248         dsc_i   = 0.743d0+x(61)
6249         dp2_i   = 1.9d0+x(62)
6250         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6251      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6252         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6253      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6254         s1=(1+x(63))/(0.1d0 + dscp1)
6255         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6256         s2=(1+x(65))/(0.1d0 + dscp2)
6257         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6258         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6259      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6260 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6261 c     &   sumene4,
6262 c     &   dscp1,dscp2,sumene
6263 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6264         escloc = escloc + sumene
6265 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6266 c     & ,zz,xx,yy
6267 c#define DEBUG
6268 #ifdef DEBUG
6269 C
6270 C This section to check the numerical derivatives of the energy of ith side
6271 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6272 C #define DEBUG in the code to turn it on.
6273 C
6274         write (2,*) "sumene               =",sumene
6275         aincr=1.0d-7
6276         xxsave=xx
6277         xx=xx+aincr
6278         write (2,*) xx,yy,zz
6279         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6280         de_dxx_num=(sumenep-sumene)/aincr
6281         xx=xxsave
6282         write (2,*) "xx+ sumene from enesc=",sumenep
6283         yysave=yy
6284         yy=yy+aincr
6285         write (2,*) xx,yy,zz
6286         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6287         de_dyy_num=(sumenep-sumene)/aincr
6288         yy=yysave
6289         write (2,*) "yy+ sumene from enesc=",sumenep
6290         zzsave=zz
6291         zz=zz+aincr
6292         write (2,*) xx,yy,zz
6293         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6294         de_dzz_num=(sumenep-sumene)/aincr
6295         zz=zzsave
6296         write (2,*) "zz+ sumene from enesc=",sumenep
6297         costsave=cost2tab(i+1)
6298         sintsave=sint2tab(i+1)
6299         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6300         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6301         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6302         de_dt_num=(sumenep-sumene)/aincr
6303         write (2,*) " t+ sumene from enesc=",sumenep
6304         cost2tab(i+1)=costsave
6305         sint2tab(i+1)=sintsave
6306 C End of diagnostics section.
6307 #endif
6308 C
6309 C Compute the gradient of esc
6310 C
6311 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6312         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6313         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6314         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6315         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6316         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6317         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6318         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6319         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6320         pom1=(sumene3*sint2tab(i+1)+sumene1)
6321      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6322         pom2=(sumene4*cost2tab(i+1)+sumene2)
6323      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6324         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6325         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6326      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6327      &  +x(40)*yy*zz
6328         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6329         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6330      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6331      &  +x(60)*yy*zz
6332         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6333      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6334      &        +(pom1+pom2)*pom_dx
6335 #ifdef DEBUG
6336         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6337 #endif
6338 C
6339         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6340         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6341      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6342      &  +x(40)*xx*zz
6343         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6344         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6345      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6346      &  +x(59)*zz**2 +x(60)*xx*zz
6347         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6348      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6349      &        +(pom1-pom2)*pom_dy
6350 #ifdef DEBUG
6351         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6352 #endif
6353 C
6354         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6355      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6356      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6357      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6358      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6359      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6360      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6361      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6362 #ifdef DEBUG
6363         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6364 #endif
6365 C
6366         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6367      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6368      &  +pom1*pom_dt1+pom2*pom_dt2
6369 #ifdef DEBUG
6370         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6371 #endif
6372 c#undef DEBUG
6373 c
6374 C
6375        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6376        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6377        cosfac2xx=cosfac2*xx
6378        sinfac2yy=sinfac2*yy
6379        do k = 1,3
6380          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6381      &      vbld_inv(i+1)
6382          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6383      &      vbld_inv(i)
6384          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6385          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6386 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6387 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6388 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6389 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6390          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6391          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6392          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6393          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6394          dZZ_Ci1(k)=0.0d0
6395          dZZ_Ci(k)=0.0d0
6396          do j=1,3
6397            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6398      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6399            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6400      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6401          enddo
6402
6403          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6404          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6405          dZZ_XYZ(k)=vbld_inv(i+nres)*
6406      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6407 c
6408          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6409          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6410        enddo
6411
6412        do k=1,3
6413          dXX_Ctab(k,i)=dXX_Ci(k)
6414          dXX_C1tab(k,i)=dXX_Ci1(k)
6415          dYY_Ctab(k,i)=dYY_Ci(k)
6416          dYY_C1tab(k,i)=dYY_Ci1(k)
6417          dZZ_Ctab(k,i)=dZZ_Ci(k)
6418          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6419          dXX_XYZtab(k,i)=dXX_XYZ(k)
6420          dYY_XYZtab(k,i)=dYY_XYZ(k)
6421          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6422        enddo
6423
6424        do k = 1,3
6425 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6426 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6427 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6428 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6429 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6430 c     &    dt_dci(k)
6431 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6432 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6433          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6434      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6435          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6436      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6437          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6438      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6439        enddo
6440 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6441 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6442
6443 C to check gradient call subroutine check_grad
6444
6445     1 continue
6446       enddo
6447       return
6448       end
6449 c------------------------------------------------------------------------------
6450       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6451       implicit none
6452       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6453      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6454       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6455      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6456      &   + x(10)*yy*zz
6457       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6458      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6459      & + x(20)*yy*zz
6460       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6461      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6462      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6463      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6464      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6465      &  +x(40)*xx*yy*zz
6466       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6467      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6468      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6469      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6470      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6471      &  +x(60)*xx*yy*zz
6472       dsc_i   = 0.743d0+x(61)
6473       dp2_i   = 1.9d0+x(62)
6474       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6475      &          *(xx*cost2+yy*sint2))
6476       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6477      &          *(xx*cost2-yy*sint2))
6478       s1=(1+x(63))/(0.1d0 + dscp1)
6479       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6480       s2=(1+x(65))/(0.1d0 + dscp2)
6481       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6482       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6483      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6484       enesc=sumene
6485       return
6486       end
6487 #endif
6488 c------------------------------------------------------------------------------
6489       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6490 C
6491 C This procedure calculates two-body contact function g(rij) and its derivative:
6492 C
6493 C           eps0ij                                     !       x < -1
6494 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6495 C            0                                         !       x > 1
6496 C
6497 C where x=(rij-r0ij)/delta
6498 C
6499 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6500 C
6501       implicit none
6502       double precision rij,r0ij,eps0ij,fcont,fprimcont
6503       double precision x,x2,x4,delta
6504 c     delta=0.02D0*r0ij
6505 c      delta=0.2D0*r0ij
6506       x=(rij-r0ij)/delta
6507       if (x.lt.-1.0D0) then
6508         fcont=eps0ij
6509         fprimcont=0.0D0
6510       else if (x.le.1.0D0) then
6511         x2=x*x
6512         x4=x2*x2
6513         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6514         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6515       else
6516         fcont=0.0D0
6517         fprimcont=0.0D0
6518       endif
6519       return
6520       end
6521 c------------------------------------------------------------------------------
6522       subroutine splinthet(theti,delta,ss,ssder)
6523       implicit real*8 (a-h,o-z)
6524       include 'DIMENSIONS'
6525       include 'COMMON.VAR'
6526       include 'COMMON.GEO'
6527       thetup=pi-delta
6528       thetlow=delta
6529       if (theti.gt.pipol) then
6530         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6531       else
6532         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6533         ssder=-ssder
6534       endif
6535       return
6536       end
6537 c------------------------------------------------------------------------------
6538       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6539       implicit none
6540       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6541       double precision ksi,ksi2,ksi3,a1,a2,a3
6542       a1=fprim0*delta/(f1-f0)
6543       a2=3.0d0-2.0d0*a1
6544       a3=a1-2.0d0
6545       ksi=(x-x0)/delta
6546       ksi2=ksi*ksi
6547       ksi3=ksi2*ksi
6548       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6549       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6550       return
6551       end
6552 c------------------------------------------------------------------------------
6553       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6554       implicit none
6555       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6556       double precision ksi,ksi2,ksi3,a1,a2,a3
6557       ksi=(x-x0)/delta
6558       ksi2=ksi*ksi
6559       ksi3=ksi2*ksi
6560       a1=fprim0x*delta
6561       a2=3*(f1x-f0x)-2*fprim0x*delta
6562       a3=fprim0x*delta-2*(f1x-f0x)
6563       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6564       return
6565       end
6566 C-----------------------------------------------------------------------------
6567 #ifdef CRYST_TOR
6568 C-----------------------------------------------------------------------------
6569       subroutine etor(etors,edihcnstr)
6570       implicit real*8 (a-h,o-z)
6571       include 'DIMENSIONS'
6572       include 'COMMON.VAR'
6573       include 'COMMON.GEO'
6574       include 'COMMON.LOCAL'
6575       include 'COMMON.TORSION'
6576       include 'COMMON.INTERACT'
6577       include 'COMMON.DERIV'
6578       include 'COMMON.CHAIN'
6579       include 'COMMON.NAMES'
6580       include 'COMMON.IOUNITS'
6581       include 'COMMON.FFIELD'
6582       include 'COMMON.TORCNSTR'
6583       include 'COMMON.CONTROL'
6584       logical lprn
6585 C Set lprn=.true. for debugging
6586       lprn=.false.
6587 c      lprn=.true.
6588       etors=0.0D0
6589       do i=iphi_start,iphi_end
6590       etors_ii=0.0D0
6591         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6592      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6593         itori=itortyp(itype(i-2))
6594         itori1=itortyp(itype(i-1))
6595         phii=phi(i)
6596         gloci=0.0D0
6597 C Proline-Proline pair is a special case...
6598         if (itori.eq.3 .and. itori1.eq.3) then
6599           if (phii.gt.-dwapi3) then
6600             cosphi=dcos(3*phii)
6601             fac=1.0D0/(1.0D0-cosphi)
6602             etorsi=v1(1,3,3)*fac
6603             etorsi=etorsi+etorsi
6604             etors=etors+etorsi-v1(1,3,3)
6605             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6606             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6607           endif
6608           do j=1,3
6609             v1ij=v1(j+1,itori,itori1)
6610             v2ij=v2(j+1,itori,itori1)
6611             cosphi=dcos(j*phii)
6612             sinphi=dsin(j*phii)
6613             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6614             if (energy_dec) etors_ii=etors_ii+
6615      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6616             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6617           enddo
6618         else
6619           do j=1,nterm_old
6620             v1ij=v1(j,itori,itori1)
6621             v2ij=v2(j,itori,itori1)
6622             cosphi=dcos(j*phii)
6623             sinphi=dsin(j*phii)
6624             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6625             if (energy_dec) etors_ii=etors_ii+
6626      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6627             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6628           enddo
6629         endif
6630         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6631              'etor',i,etors_ii
6632         if (lprn)
6633      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6634      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6635      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6636         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6637 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6638       enddo
6639 ! 6/20/98 - dihedral angle constraints
6640       edihcnstr=0.0d0
6641       do i=1,ndih_constr
6642         itori=idih_constr(i)
6643         phii=phi(itori)
6644         difi=phii-phi0(i)
6645         if (difi.gt.drange(i)) then
6646           difi=difi-drange(i)
6647           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6648           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6649         else if (difi.lt.-drange(i)) then
6650           difi=difi+drange(i)
6651           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6652           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6653         endif
6654 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6655 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6656       enddo
6657 !      write (iout,*) 'edihcnstr',edihcnstr
6658       return
6659       end
6660 c------------------------------------------------------------------------------
6661       subroutine etor_d(etors_d)
6662       etors_d=0.0d0
6663       return
6664       end
6665 c----------------------------------------------------------------------------
6666 #else
6667       subroutine etor(etors,edihcnstr)
6668       implicit real*8 (a-h,o-z)
6669       include 'DIMENSIONS'
6670       include 'COMMON.VAR'
6671       include 'COMMON.GEO'
6672       include 'COMMON.LOCAL'
6673       include 'COMMON.TORSION'
6674       include 'COMMON.INTERACT'
6675       include 'COMMON.DERIV'
6676       include 'COMMON.CHAIN'
6677       include 'COMMON.NAMES'
6678       include 'COMMON.IOUNITS'
6679       include 'COMMON.FFIELD'
6680       include 'COMMON.TORCNSTR'
6681       include 'COMMON.CONTROL'
6682       logical lprn
6683 C Set lprn=.true. for debugging
6684       lprn=.false.
6685 c     lprn=.true.
6686       etors=0.0D0
6687       do i=iphi_start,iphi_end
6688 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6689 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6690 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6691 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6692         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6693      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6694 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6695 C For introducing the NH3+ and COO- group please check the etor_d for reference
6696 C and guidance
6697         etors_ii=0.0D0
6698          if (iabs(itype(i)).eq.20) then
6699          iblock=2
6700          else
6701          iblock=1
6702          endif
6703         itori=itortyp(itype(i-2))
6704         itori1=itortyp(itype(i-1))
6705         phii=phi(i)
6706         gloci=0.0D0
6707 C Regular cosine and sine terms
6708         do j=1,nterm(itori,itori1,iblock)
6709           v1ij=v1(j,itori,itori1,iblock)
6710           v2ij=v2(j,itori,itori1,iblock)
6711           cosphi=dcos(j*phii)
6712           sinphi=dsin(j*phii)
6713           etors=etors+v1ij*cosphi+v2ij*sinphi
6714           if (energy_dec) etors_ii=etors_ii+
6715      &                v1ij*cosphi+v2ij*sinphi
6716           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6717         enddo
6718 C Lorentz terms
6719 C                         v1
6720 C  E = SUM ----------------------------------- - v1
6721 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6722 C
6723         cosphi=dcos(0.5d0*phii)
6724         sinphi=dsin(0.5d0*phii)
6725         do j=1,nlor(itori,itori1,iblock)
6726           vl1ij=vlor1(j,itori,itori1)
6727           vl2ij=vlor2(j,itori,itori1)
6728           vl3ij=vlor3(j,itori,itori1)
6729           pom=vl2ij*cosphi+vl3ij*sinphi
6730           pom1=1.0d0/(pom*pom+1.0d0)
6731           etors=etors+vl1ij*pom1
6732           if (energy_dec) etors_ii=etors_ii+
6733      &                vl1ij*pom1
6734           pom=-pom*pom1*pom1
6735           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6736         enddo
6737 C Subtract the constant term
6738         etors=etors-v0(itori,itori1,iblock)
6739           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6740      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6741         if (lprn)
6742      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6743      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6744      &  (v1(j,itori,itori1,iblock),j=1,6),
6745      &  (v2(j,itori,itori1,iblock),j=1,6)
6746         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6747 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6748       enddo
6749 ! 6/20/98 - dihedral angle constraints
6750       edihcnstr=0.0d0
6751 c      do i=1,ndih_constr
6752       do i=idihconstr_start,idihconstr_end
6753         itori=idih_constr(i)
6754         phii=phi(itori)
6755         difi=pinorm(phii-phi0(i))
6756         if (difi.gt.drange(i)) then
6757           difi=difi-drange(i)
6758           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6759           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6760         else if (difi.lt.-drange(i)) then
6761           difi=difi+drange(i)
6762           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6763           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6764         else
6765           difi=0.0
6766         endif
6767 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6768 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6769 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6770       enddo
6771 cd       write (iout,*) 'edihcnstr',edihcnstr
6772       return
6773       end
6774 c----------------------------------------------------------------------------
6775       subroutine etor_d(etors_d)
6776 C 6/23/01 Compute double torsional energy
6777       implicit real*8 (a-h,o-z)
6778       include 'DIMENSIONS'
6779       include 'COMMON.VAR'
6780       include 'COMMON.GEO'
6781       include 'COMMON.LOCAL'
6782       include 'COMMON.TORSION'
6783       include 'COMMON.INTERACT'
6784       include 'COMMON.DERIV'
6785       include 'COMMON.CHAIN'
6786       include 'COMMON.NAMES'
6787       include 'COMMON.IOUNITS'
6788       include 'COMMON.FFIELD'
6789       include 'COMMON.TORCNSTR'
6790       logical lprn
6791 C Set lprn=.true. for debugging
6792       lprn=.false.
6793 c     lprn=.true.
6794       etors_d=0.0D0
6795 c      write(iout,*) "a tu??"
6796       do i=iphid_start,iphid_end
6797 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6798 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6799 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6800 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6801 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6802          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6803      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6804      &  (itype(i+1).eq.ntyp1)) cycle
6805 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6806         itori=itortyp(itype(i-2))
6807         itori1=itortyp(itype(i-1))
6808         itori2=itortyp(itype(i))
6809         phii=phi(i)
6810         phii1=phi(i+1)
6811         gloci1=0.0D0
6812         gloci2=0.0D0
6813         iblock=1
6814         if (iabs(itype(i+1)).eq.20) iblock=2
6815 C Iblock=2 Proline type
6816 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6817 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6818 C        if (itype(i+1).eq.ntyp1) iblock=3
6819 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6820 C IS or IS NOT need for this
6821 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6822 C        is (itype(i-3).eq.ntyp1) ntblock=2
6823 C        ntblock is N-terminal blocking group
6824
6825 C Regular cosine and sine terms
6826         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6827 C Example of changes for NH3+ blocking group
6828 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6829 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6830           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6831           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6832           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6833           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6834           cosphi1=dcos(j*phii)
6835           sinphi1=dsin(j*phii)
6836           cosphi2=dcos(j*phii1)
6837           sinphi2=dsin(j*phii1)
6838           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6839      &     v2cij*cosphi2+v2sij*sinphi2
6840           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6841           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6842         enddo
6843         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6844           do l=1,k-1
6845             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6846             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6847             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6848             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6849             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6850             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6851             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6852             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6853             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6854      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6855             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6856      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6857             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6858      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6859           enddo
6860         enddo
6861         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6862         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6863       enddo
6864       return
6865       end
6866 #endif
6867 c------------------------------------------------------------------------------
6868       subroutine eback_sc_corr(esccor)
6869 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6870 c        conformational states; temporarily implemented as differences
6871 c        between UNRES torsional potentials (dependent on three types of
6872 c        residues) and the torsional potentials dependent on all 20 types
6873 c        of residues computed from AM1  energy surfaces of terminally-blocked
6874 c        amino-acid residues.
6875       implicit real*8 (a-h,o-z)
6876       include 'DIMENSIONS'
6877       include 'COMMON.VAR'
6878       include 'COMMON.GEO'
6879       include 'COMMON.LOCAL'
6880       include 'COMMON.TORSION'
6881       include 'COMMON.SCCOR'
6882       include 'COMMON.INTERACT'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.CHAIN'
6885       include 'COMMON.NAMES'
6886       include 'COMMON.IOUNITS'
6887       include 'COMMON.FFIELD'
6888       include 'COMMON.CONTROL'
6889       logical lprn
6890 C Set lprn=.true. for debugging
6891       lprn=.false.
6892 c      lprn=.true.
6893 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6894       esccor=0.0D0
6895       do i=itau_start,itau_end
6896         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6897         esccor_ii=0.0D0
6898         isccori=isccortyp(itype(i-2))
6899         isccori1=isccortyp(itype(i-1))
6900 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6901         phii=phi(i)
6902         do intertyp=1,3 !intertyp
6903 cc Added 09 May 2012 (Adasko)
6904 cc  Intertyp means interaction type of backbone mainchain correlation:
6905 c   1 = SC...Ca...Ca...Ca
6906 c   2 = Ca...Ca...Ca...SC
6907 c   3 = SC...Ca...Ca...SCi
6908         gloci=0.0D0
6909         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6910      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6911      &      (itype(i-1).eq.ntyp1)))
6912      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6913      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6914      &     .or.(itype(i).eq.ntyp1)))
6915      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6916      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6917      &      (itype(i-3).eq.ntyp1)))) cycle
6918         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6919         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6920      & cycle
6921        do j=1,nterm_sccor(isccori,isccori1)
6922           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6923           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6924           cosphi=dcos(j*tauangle(intertyp,i))
6925           sinphi=dsin(j*tauangle(intertyp,i))
6926           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6927           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6928         enddo
6929 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6930         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6931         if (lprn)
6932      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6933      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6934      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6935      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6936         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6937        enddo !intertyp
6938       enddo
6939
6940       return
6941       end
6942 c----------------------------------------------------------------------------
6943       subroutine multibody(ecorr)
6944 C This subroutine calculates multi-body contributions to energy following
6945 C the idea of Skolnick et al. If side chains I and J make a contact and
6946 C at the same time side chains I+1 and J+1 make a contact, an extra
6947 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6948       implicit real*8 (a-h,o-z)
6949       include 'DIMENSIONS'
6950       include 'COMMON.IOUNITS'
6951       include 'COMMON.DERIV'
6952       include 'COMMON.INTERACT'
6953       include 'COMMON.CONTACTS'
6954       double precision gx(3),gx1(3)
6955       logical lprn
6956
6957 C Set lprn=.true. for debugging
6958       lprn=.false.
6959
6960       if (lprn) then
6961         write (iout,'(a)') 'Contact function values:'
6962         do i=nnt,nct-2
6963           write (iout,'(i2,20(1x,i2,f10.5))')
6964      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6965         enddo
6966       endif
6967       ecorr=0.0D0
6968       do i=nnt,nct
6969         do j=1,3
6970           gradcorr(j,i)=0.0D0
6971           gradxorr(j,i)=0.0D0
6972         enddo
6973       enddo
6974       do i=nnt,nct-2
6975
6976         DO ISHIFT = 3,4
6977
6978         i1=i+ishift
6979         num_conti=num_cont(i)
6980         num_conti1=num_cont(i1)
6981         do jj=1,num_conti
6982           j=jcont(jj,i)
6983           do kk=1,num_conti1
6984             j1=jcont(kk,i1)
6985             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6986 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6987 cd   &                   ' ishift=',ishift
6988 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6989 C The system gains extra energy.
6990               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6991             endif   ! j1==j+-ishift
6992           enddo     ! kk
6993         enddo       ! jj
6994
6995         ENDDO ! ISHIFT
6996
6997       enddo         ! i
6998       return
6999       end
7000 c------------------------------------------------------------------------------
7001       double precision function esccorr(i,j,k,l,jj,kk)
7002       implicit real*8 (a-h,o-z)
7003       include 'DIMENSIONS'
7004       include 'COMMON.IOUNITS'
7005       include 'COMMON.DERIV'
7006       include 'COMMON.INTERACT'
7007       include 'COMMON.CONTACTS'
7008       double precision gx(3),gx1(3)
7009       logical lprn
7010       lprn=.false.
7011       eij=facont(jj,i)
7012       ekl=facont(kk,k)
7013 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7014 C Calculate the multi-body contribution to energy.
7015 C Calculate multi-body contributions to the gradient.
7016 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7017 cd   & k,l,(gacont(m,kk,k),m=1,3)
7018       do m=1,3
7019         gx(m) =ekl*gacont(m,jj,i)
7020         gx1(m)=eij*gacont(m,kk,k)
7021         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7022         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7023         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7024         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7025       enddo
7026       do m=i,j-1
7027         do ll=1,3
7028           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7029         enddo
7030       enddo
7031       do m=k,l-1
7032         do ll=1,3
7033           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7034         enddo
7035       enddo
7036       esccorr=-eij*ekl
7037       return
7038       end
7039 c------------------------------------------------------------------------------
7040       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7041 C This subroutine calculates multi-body contributions to hydrogen-bonding
7042       implicit real*8 (a-h,o-z)
7043       include 'DIMENSIONS'
7044       include 'COMMON.IOUNITS'
7045 #ifdef MPI
7046       include "mpif.h"
7047       parameter (max_cont=maxconts)
7048       parameter (max_dim=26)
7049       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7050       double precision zapas(max_dim,maxconts,max_fg_procs),
7051      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7052       common /przechowalnia/ zapas
7053       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7054      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7055 #endif
7056       include 'COMMON.SETUP'
7057       include 'COMMON.FFIELD'
7058       include 'COMMON.DERIV'
7059       include 'COMMON.INTERACT'
7060       include 'COMMON.CONTACTS'
7061       include 'COMMON.CONTROL'
7062       include 'COMMON.LOCAL'
7063       double precision gx(3),gx1(3),time00
7064       logical lprn,ldone
7065
7066 C Set lprn=.true. for debugging
7067       lprn=.false.
7068 #ifdef MPI
7069       n_corr=0
7070       n_corr1=0
7071       if (nfgtasks.le.1) goto 30
7072       if (lprn) then
7073         write (iout,'(a)') 'Contact function values before RECEIVE:'
7074         do i=nnt,nct-2
7075           write (iout,'(2i3,50(1x,i2,f5.2))')
7076      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7077      &    j=1,num_cont_hb(i))
7078         enddo
7079       endif
7080       call flush(iout)
7081       do i=1,ntask_cont_from
7082         ncont_recv(i)=0
7083       enddo
7084       do i=1,ntask_cont_to
7085         ncont_sent(i)=0
7086       enddo
7087 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7088 c     & ntask_cont_to
7089 C Make the list of contacts to send to send to other procesors
7090 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7091 c      call flush(iout)
7092       do i=iturn3_start,iturn3_end
7093 c        write (iout,*) "make contact list turn3",i," num_cont",
7094 c     &    num_cont_hb(i)
7095         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7096       enddo
7097       do i=iturn4_start,iturn4_end
7098 c        write (iout,*) "make contact list turn4",i," num_cont",
7099 c     &   num_cont_hb(i)
7100         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7101       enddo
7102       do ii=1,nat_sent
7103         i=iat_sent(ii)
7104 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7105 c     &    num_cont_hb(i)
7106         do j=1,num_cont_hb(i)
7107         do k=1,4
7108           jjc=jcont_hb(j,i)
7109           iproc=iint_sent_local(k,jjc,ii)
7110 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7111           if (iproc.gt.0) then
7112             ncont_sent(iproc)=ncont_sent(iproc)+1
7113             nn=ncont_sent(iproc)
7114             zapas(1,nn,iproc)=i
7115             zapas(2,nn,iproc)=jjc
7116             zapas(3,nn,iproc)=facont_hb(j,i)
7117             zapas(4,nn,iproc)=ees0p(j,i)
7118             zapas(5,nn,iproc)=ees0m(j,i)
7119             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7120             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7121             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7122             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7123             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7124             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7125             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7126             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7127             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7128             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7129             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7130             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7131             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7132             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7133             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7134             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7135             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7136             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7137             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7138             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7139             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7140           endif
7141         enddo
7142         enddo
7143       enddo
7144       if (lprn) then
7145       write (iout,*)
7146      &  "Numbers of contacts to be sent to other processors",
7147      &  (ncont_sent(i),i=1,ntask_cont_to)
7148       write (iout,*) "Contacts sent"
7149       do ii=1,ntask_cont_to
7150         nn=ncont_sent(ii)
7151         iproc=itask_cont_to(ii)
7152         write (iout,*) nn," contacts to processor",iproc,
7153      &   " of CONT_TO_COMM group"
7154         do i=1,nn
7155           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7156         enddo
7157       enddo
7158       call flush(iout)
7159       endif
7160       CorrelType=477
7161       CorrelID=fg_rank+1
7162       CorrelType1=478
7163       CorrelID1=nfgtasks+fg_rank+1
7164       ireq=0
7165 C Receive the numbers of needed contacts from other processors
7166       do ii=1,ntask_cont_from
7167         iproc=itask_cont_from(ii)
7168         ireq=ireq+1
7169         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7170      &    FG_COMM,req(ireq),IERR)
7171       enddo
7172 c      write (iout,*) "IRECV ended"
7173 c      call flush(iout)
7174 C Send the number of contacts needed by other processors
7175       do ii=1,ntask_cont_to
7176         iproc=itask_cont_to(ii)
7177         ireq=ireq+1
7178         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7179      &    FG_COMM,req(ireq),IERR)
7180       enddo
7181 c      write (iout,*) "ISEND ended"
7182 c      write (iout,*) "number of requests (nn)",ireq
7183       call flush(iout)
7184       if (ireq.gt.0)
7185      &  call MPI_Waitall(ireq,req,status_array,ierr)
7186 c      write (iout,*)
7187 c     &  "Numbers of contacts to be received from other processors",
7188 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7189 c      call flush(iout)
7190 C Receive contacts
7191       ireq=0
7192       do ii=1,ntask_cont_from
7193         iproc=itask_cont_from(ii)
7194         nn=ncont_recv(ii)
7195 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7196 c     &   " of CONT_TO_COMM group"
7197         call flush(iout)
7198         if (nn.gt.0) then
7199           ireq=ireq+1
7200           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7201      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7202 c          write (iout,*) "ireq,req",ireq,req(ireq)
7203         endif
7204       enddo
7205 C Send the contacts to processors that need them
7206       do ii=1,ntask_cont_to
7207         iproc=itask_cont_to(ii)
7208         nn=ncont_sent(ii)
7209 c        write (iout,*) nn," contacts to processor",iproc,
7210 c     &   " of CONT_TO_COMM group"
7211         if (nn.gt.0) then
7212           ireq=ireq+1
7213           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7214      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7215 c          write (iout,*) "ireq,req",ireq,req(ireq)
7216 c          do i=1,nn
7217 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7218 c          enddo
7219         endif
7220       enddo
7221 c      write (iout,*) "number of requests (contacts)",ireq
7222 c      write (iout,*) "req",(req(i),i=1,4)
7223 c      call flush(iout)
7224       if (ireq.gt.0)
7225      & call MPI_Waitall(ireq,req,status_array,ierr)
7226       do iii=1,ntask_cont_from
7227         iproc=itask_cont_from(iii)
7228         nn=ncont_recv(iii)
7229         if (lprn) then
7230         write (iout,*) "Received",nn," contacts from processor",iproc,
7231      &   " of CONT_FROM_COMM group"
7232         call flush(iout)
7233         do i=1,nn
7234           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7235         enddo
7236         call flush(iout)
7237         endif
7238         do i=1,nn
7239           ii=zapas_recv(1,i,iii)
7240 c Flag the received contacts to prevent double-counting
7241           jj=-zapas_recv(2,i,iii)
7242 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7243 c          call flush(iout)
7244           nnn=num_cont_hb(ii)+1
7245           num_cont_hb(ii)=nnn
7246           jcont_hb(nnn,ii)=jj
7247           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7248           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7249           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7250           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7251           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7252           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7253           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7254           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7255           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7256           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7257           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7258           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7259           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7260           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7261           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7262           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7263           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7264           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7265           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7266           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7267           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7268           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7269           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7270           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7271         enddo
7272       enddo
7273       call flush(iout)
7274       if (lprn) then
7275         write (iout,'(a)') 'Contact function values after receive:'
7276         do i=nnt,nct-2
7277           write (iout,'(2i3,50(1x,i3,f5.2))')
7278      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7279      &    j=1,num_cont_hb(i))
7280         enddo
7281         call flush(iout)
7282       endif
7283    30 continue
7284 #endif
7285       if (lprn) then
7286         write (iout,'(a)') 'Contact function values:'
7287         do i=nnt,nct-2
7288           write (iout,'(2i3,50(1x,i3,f5.2))')
7289      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7290      &    j=1,num_cont_hb(i))
7291         enddo
7292       endif
7293       ecorr=0.0D0
7294 C Remove the loop below after debugging !!!
7295       do i=nnt,nct
7296         do j=1,3
7297           gradcorr(j,i)=0.0D0
7298           gradxorr(j,i)=0.0D0
7299         enddo
7300       enddo
7301 C Calculate the local-electrostatic correlation terms
7302       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7303         i1=i+1
7304         num_conti=num_cont_hb(i)
7305         num_conti1=num_cont_hb(i+1)
7306         do jj=1,num_conti
7307           j=jcont_hb(jj,i)
7308           jp=iabs(j)
7309           do kk=1,num_conti1
7310             j1=jcont_hb(kk,i1)
7311             jp1=iabs(j1)
7312 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7313 c     &         ' jj=',jj,' kk=',kk
7314             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7315      &          .or. j.lt.0 .and. j1.gt.0) .and.
7316      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7317 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7318 C The system gains extra energy.
7319               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7320               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7321      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7322               n_corr=n_corr+1
7323             else if (j1.eq.j) then
7324 C Contacts I-J and I-(J+1) occur simultaneously.
7325 C The system loses extra energy.
7326 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7327             endif
7328           enddo ! kk
7329           do kk=1,num_conti
7330             j1=jcont_hb(kk,i)
7331 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7332 c    &         ' jj=',jj,' kk=',kk
7333             if (j1.eq.j+1) then
7334 C Contacts I-J and (I+1)-J occur simultaneously.
7335 C The system loses extra energy.
7336 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7337             endif ! j1==j+1
7338           enddo ! kk
7339         enddo ! jj
7340       enddo ! i
7341       return
7342       end
7343 c------------------------------------------------------------------------------
7344       subroutine add_hb_contact(ii,jj,itask)
7345       implicit real*8 (a-h,o-z)
7346       include "DIMENSIONS"
7347       include "COMMON.IOUNITS"
7348       integer max_cont
7349       integer max_dim
7350       parameter (max_cont=maxconts)
7351       parameter (max_dim=26)
7352       include "COMMON.CONTACTS"
7353       double precision zapas(max_dim,maxconts,max_fg_procs),
7354      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7355       common /przechowalnia/ zapas
7356       integer i,j,ii,jj,iproc,itask(4),nn
7357 c      write (iout,*) "itask",itask
7358       do i=1,2
7359         iproc=itask(i)
7360         if (iproc.gt.0) then
7361           do j=1,num_cont_hb(ii)
7362             jjc=jcont_hb(j,ii)
7363 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7364             if (jjc.eq.jj) then
7365               ncont_sent(iproc)=ncont_sent(iproc)+1
7366               nn=ncont_sent(iproc)
7367               zapas(1,nn,iproc)=ii
7368               zapas(2,nn,iproc)=jjc
7369               zapas(3,nn,iproc)=facont_hb(j,ii)
7370               zapas(4,nn,iproc)=ees0p(j,ii)
7371               zapas(5,nn,iproc)=ees0m(j,ii)
7372               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7373               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7374               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7375               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7376               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7377               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7378               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7379               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7380               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7381               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7382               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7383               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7384               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7385               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7386               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7387               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7388               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7389               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7390               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7391               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7392               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7393               exit
7394             endif
7395           enddo
7396         endif
7397       enddo
7398       return
7399       end
7400 c------------------------------------------------------------------------------
7401       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7402      &  n_corr1)
7403 C This subroutine calculates multi-body contributions to hydrogen-bonding
7404       implicit real*8 (a-h,o-z)
7405       include 'DIMENSIONS'
7406       include 'COMMON.IOUNITS'
7407 #ifdef MPI
7408       include "mpif.h"
7409       parameter (max_cont=maxconts)
7410       parameter (max_dim=70)
7411       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7412       double precision zapas(max_dim,maxconts,max_fg_procs),
7413      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7414       common /przechowalnia/ zapas
7415       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7416      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7417 #endif
7418       include 'COMMON.SETUP'
7419       include 'COMMON.FFIELD'
7420       include 'COMMON.DERIV'
7421       include 'COMMON.LOCAL'
7422       include 'COMMON.INTERACT'
7423       include 'COMMON.CONTACTS'
7424       include 'COMMON.CHAIN'
7425       include 'COMMON.CONTROL'
7426       double precision gx(3),gx1(3)
7427       integer num_cont_hb_old(maxres)
7428       logical lprn,ldone
7429       double precision eello4,eello5,eelo6,eello_turn6
7430       external eello4,eello5,eello6,eello_turn6
7431 C Set lprn=.true. for debugging
7432       lprn=.false.
7433       eturn6=0.0d0
7434 #ifdef MPI
7435       do i=1,nres
7436         num_cont_hb_old(i)=num_cont_hb(i)
7437       enddo
7438       n_corr=0
7439       n_corr1=0
7440       if (nfgtasks.le.1) goto 30
7441       if (lprn) then
7442         write (iout,'(a)') 'Contact function values before RECEIVE:'
7443         do i=nnt,nct-2
7444           write (iout,'(2i3,50(1x,i2,f5.2))')
7445      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7446      &    j=1,num_cont_hb(i))
7447         enddo
7448       endif
7449       call flush(iout)
7450       do i=1,ntask_cont_from
7451         ncont_recv(i)=0
7452       enddo
7453       do i=1,ntask_cont_to
7454         ncont_sent(i)=0
7455       enddo
7456 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7457 c     & ntask_cont_to
7458 C Make the list of contacts to send to send to other procesors
7459       do i=iturn3_start,iturn3_end
7460 c        write (iout,*) "make contact list turn3",i," num_cont",
7461 c     &    num_cont_hb(i)
7462         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7463       enddo
7464       do i=iturn4_start,iturn4_end
7465 c        write (iout,*) "make contact list turn4",i," num_cont",
7466 c     &   num_cont_hb(i)
7467         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7468       enddo
7469       do ii=1,nat_sent
7470         i=iat_sent(ii)
7471 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7472 c     &    num_cont_hb(i)
7473         do j=1,num_cont_hb(i)
7474         do k=1,4
7475           jjc=jcont_hb(j,i)
7476           iproc=iint_sent_local(k,jjc,ii)
7477 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7478           if (iproc.ne.0) then
7479             ncont_sent(iproc)=ncont_sent(iproc)+1
7480             nn=ncont_sent(iproc)
7481             zapas(1,nn,iproc)=i
7482             zapas(2,nn,iproc)=jjc
7483             zapas(3,nn,iproc)=d_cont(j,i)
7484             ind=3
7485             do kk=1,3
7486               ind=ind+1
7487               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7488             enddo
7489             do kk=1,2
7490               do ll=1,2
7491                 ind=ind+1
7492                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7493               enddo
7494             enddo
7495             do jj=1,5
7496               do kk=1,3
7497                 do ll=1,2
7498                   do mm=1,2
7499                     ind=ind+1
7500                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7501                   enddo
7502                 enddo
7503               enddo
7504             enddo
7505           endif
7506         enddo
7507         enddo
7508       enddo
7509       if (lprn) then
7510       write (iout,*)
7511      &  "Numbers of contacts to be sent to other processors",
7512      &  (ncont_sent(i),i=1,ntask_cont_to)
7513       write (iout,*) "Contacts sent"
7514       do ii=1,ntask_cont_to
7515         nn=ncont_sent(ii)
7516         iproc=itask_cont_to(ii)
7517         write (iout,*) nn," contacts to processor",iproc,
7518      &   " of CONT_TO_COMM group"
7519         do i=1,nn
7520           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7521         enddo
7522       enddo
7523       call flush(iout)
7524       endif
7525       CorrelType=477
7526       CorrelID=fg_rank+1
7527       CorrelType1=478
7528       CorrelID1=nfgtasks+fg_rank+1
7529       ireq=0
7530 C Receive the numbers of needed contacts from other processors
7531       do ii=1,ntask_cont_from
7532         iproc=itask_cont_from(ii)
7533         ireq=ireq+1
7534         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7535      &    FG_COMM,req(ireq),IERR)
7536       enddo
7537 c      write (iout,*) "IRECV ended"
7538 c      call flush(iout)
7539 C Send the number of contacts needed by other processors
7540       do ii=1,ntask_cont_to
7541         iproc=itask_cont_to(ii)
7542         ireq=ireq+1
7543         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7544      &    FG_COMM,req(ireq),IERR)
7545       enddo
7546 c      write (iout,*) "ISEND ended"
7547 c      write (iout,*) "number of requests (nn)",ireq
7548       call flush(iout)
7549       if (ireq.gt.0)
7550      &  call MPI_Waitall(ireq,req,status_array,ierr)
7551 c      write (iout,*)
7552 c     &  "Numbers of contacts to be received from other processors",
7553 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7554 c      call flush(iout)
7555 C Receive contacts
7556       ireq=0
7557       do ii=1,ntask_cont_from
7558         iproc=itask_cont_from(ii)
7559         nn=ncont_recv(ii)
7560 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7561 c     &   " of CONT_TO_COMM group"
7562         call flush(iout)
7563         if (nn.gt.0) then
7564           ireq=ireq+1
7565           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7566      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7567 c          write (iout,*) "ireq,req",ireq,req(ireq)
7568         endif
7569       enddo
7570 C Send the contacts to processors that need them
7571       do ii=1,ntask_cont_to
7572         iproc=itask_cont_to(ii)
7573         nn=ncont_sent(ii)
7574 c        write (iout,*) nn," contacts to processor",iproc,
7575 c     &   " of CONT_TO_COMM group"
7576         if (nn.gt.0) then
7577           ireq=ireq+1
7578           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7579      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7580 c          write (iout,*) "ireq,req",ireq,req(ireq)
7581 c          do i=1,nn
7582 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7583 c          enddo
7584         endif
7585       enddo
7586 c      write (iout,*) "number of requests (contacts)",ireq
7587 c      write (iout,*) "req",(req(i),i=1,4)
7588 c      call flush(iout)
7589       if (ireq.gt.0)
7590      & call MPI_Waitall(ireq,req,status_array,ierr)
7591       do iii=1,ntask_cont_from
7592         iproc=itask_cont_from(iii)
7593         nn=ncont_recv(iii)
7594         if (lprn) then
7595         write (iout,*) "Received",nn," contacts from processor",iproc,
7596      &   " of CONT_FROM_COMM group"
7597         call flush(iout)
7598         do i=1,nn
7599           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7600         enddo
7601         call flush(iout)
7602         endif
7603         do i=1,nn
7604           ii=zapas_recv(1,i,iii)
7605 c Flag the received contacts to prevent double-counting
7606           jj=-zapas_recv(2,i,iii)
7607 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7608 c          call flush(iout)
7609           nnn=num_cont_hb(ii)+1
7610           num_cont_hb(ii)=nnn
7611           jcont_hb(nnn,ii)=jj
7612           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7613           ind=3
7614           do kk=1,3
7615             ind=ind+1
7616             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7617           enddo
7618           do kk=1,2
7619             do ll=1,2
7620               ind=ind+1
7621               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7622             enddo
7623           enddo
7624           do jj=1,5
7625             do kk=1,3
7626               do ll=1,2
7627                 do mm=1,2
7628                   ind=ind+1
7629                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7630                 enddo
7631               enddo
7632             enddo
7633           enddo
7634         enddo
7635       enddo
7636       call flush(iout)
7637       if (lprn) then
7638         write (iout,'(a)') 'Contact function values after receive:'
7639         do i=nnt,nct-2
7640           write (iout,'(2i3,50(1x,i3,5f6.3))')
7641      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7642      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7643         enddo
7644         call flush(iout)
7645       endif
7646    30 continue
7647 #endif
7648       if (lprn) then
7649         write (iout,'(a)') 'Contact function values:'
7650         do i=nnt,nct-2
7651           write (iout,'(2i3,50(1x,i2,5f6.3))')
7652      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7653      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7654         enddo
7655       endif
7656       ecorr=0.0D0
7657       ecorr5=0.0d0
7658       ecorr6=0.0d0
7659 C Remove the loop below after debugging !!!
7660       do i=nnt,nct
7661         do j=1,3
7662           gradcorr(j,i)=0.0D0
7663           gradxorr(j,i)=0.0D0
7664         enddo
7665       enddo
7666 C Calculate the dipole-dipole interaction energies
7667       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7668       do i=iatel_s,iatel_e+1
7669         num_conti=num_cont_hb(i)
7670         do jj=1,num_conti
7671           j=jcont_hb(jj,i)
7672 #ifdef MOMENT
7673           call dipole(i,j,jj)
7674 #endif
7675         enddo
7676       enddo
7677       endif
7678 C Calculate the local-electrostatic correlation terms
7679 c                write (iout,*) "gradcorr5 in eello5 before loop"
7680 c                do iii=1,nres
7681 c                  write (iout,'(i5,3f10.5)')
7682 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7683 c                enddo
7684       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7685 c        write (iout,*) "corr loop i",i
7686         i1=i+1
7687         num_conti=num_cont_hb(i)
7688         num_conti1=num_cont_hb(i+1)
7689         do jj=1,num_conti
7690           j=jcont_hb(jj,i)
7691           jp=iabs(j)
7692           do kk=1,num_conti1
7693             j1=jcont_hb(kk,i1)
7694             jp1=iabs(j1)
7695 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7696 c     &         ' jj=',jj,' kk=',kk
7697 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7698             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7699      &          .or. j.lt.0 .and. j1.gt.0) .and.
7700      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7701 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7702 C The system gains extra energy.
7703               n_corr=n_corr+1
7704               sqd1=dsqrt(d_cont(jj,i))
7705               sqd2=dsqrt(d_cont(kk,i1))
7706               sred_geom = sqd1*sqd2
7707               IF (sred_geom.lt.cutoff_corr) THEN
7708                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7709      &            ekont,fprimcont)
7710 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7711 cd     &         ' jj=',jj,' kk=',kk
7712                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7713                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7714                 do l=1,3
7715                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7716                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7717                 enddo
7718                 n_corr1=n_corr1+1
7719 cd               write (iout,*) 'sred_geom=',sred_geom,
7720 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7721 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7722 cd               write (iout,*) "g_contij",g_contij
7723 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7724 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7725                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7726                 if (wcorr4.gt.0.0d0)
7727      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7728                   if (energy_dec.and.wcorr4.gt.0.0d0)
7729      1                 write (iout,'(a6,4i5,0pf7.3)')
7730      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7731 c                write (iout,*) "gradcorr5 before eello5"
7732 c                do iii=1,nres
7733 c                  write (iout,'(i5,3f10.5)')
7734 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7735 c                enddo
7736                 if (wcorr5.gt.0.0d0)
7737      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7738 c                write (iout,*) "gradcorr5 after eello5"
7739 c                do iii=1,nres
7740 c                  write (iout,'(i5,3f10.5)')
7741 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7742 c                enddo
7743                   if (energy_dec.and.wcorr5.gt.0.0d0)
7744      1                 write (iout,'(a6,4i5,0pf7.3)')
7745      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7746 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7747 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7748                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7749      &               .or. wturn6.eq.0.0d0))then
7750 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7751                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7752                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7753      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7754 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7755 cd     &            'ecorr6=',ecorr6
7756 cd                write (iout,'(4e15.5)') sred_geom,
7757 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7758 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7759 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7760                 else if (wturn6.gt.0.0d0
7761      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7762 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7763                   eturn6=eturn6+eello_turn6(i,jj,kk)
7764                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7765      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7766 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7767                 endif
7768               ENDIF
7769 1111          continue
7770             endif
7771           enddo ! kk
7772         enddo ! jj
7773       enddo ! i
7774       do i=1,nres
7775         num_cont_hb(i)=num_cont_hb_old(i)
7776       enddo
7777 c                write (iout,*) "gradcorr5 in eello5"
7778 c                do iii=1,nres
7779 c                  write (iout,'(i5,3f10.5)')
7780 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7781 c                enddo
7782       return
7783       end
7784 c------------------------------------------------------------------------------
7785       subroutine add_hb_contact_eello(ii,jj,itask)
7786       implicit real*8 (a-h,o-z)
7787       include "DIMENSIONS"
7788       include "COMMON.IOUNITS"
7789       integer max_cont
7790       integer max_dim
7791       parameter (max_cont=maxconts)
7792       parameter (max_dim=70)
7793       include "COMMON.CONTACTS"
7794       double precision zapas(max_dim,maxconts,max_fg_procs),
7795      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7796       common /przechowalnia/ zapas
7797       integer i,j,ii,jj,iproc,itask(4),nn
7798 c      write (iout,*) "itask",itask
7799       do i=1,2
7800         iproc=itask(i)
7801         if (iproc.gt.0) then
7802           do j=1,num_cont_hb(ii)
7803             jjc=jcont_hb(j,ii)
7804 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7805             if (jjc.eq.jj) then
7806               ncont_sent(iproc)=ncont_sent(iproc)+1
7807               nn=ncont_sent(iproc)
7808               zapas(1,nn,iproc)=ii
7809               zapas(2,nn,iproc)=jjc
7810               zapas(3,nn,iproc)=d_cont(j,ii)
7811               ind=3
7812               do kk=1,3
7813                 ind=ind+1
7814                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7815               enddo
7816               do kk=1,2
7817                 do ll=1,2
7818                   ind=ind+1
7819                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7820                 enddo
7821               enddo
7822               do jj=1,5
7823                 do kk=1,3
7824                   do ll=1,2
7825                     do mm=1,2
7826                       ind=ind+1
7827                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7828                     enddo
7829                   enddo
7830                 enddo
7831               enddo
7832               exit
7833             endif
7834           enddo
7835         endif
7836       enddo
7837       return
7838       end
7839 c------------------------------------------------------------------------------
7840       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7841       implicit real*8 (a-h,o-z)
7842       include 'DIMENSIONS'
7843       include 'COMMON.IOUNITS'
7844       include 'COMMON.DERIV'
7845       include 'COMMON.INTERACT'
7846       include 'COMMON.CONTACTS'
7847       double precision gx(3),gx1(3)
7848       logical lprn
7849       lprn=.false.
7850       eij=facont_hb(jj,i)
7851       ekl=facont_hb(kk,k)
7852       ees0pij=ees0p(jj,i)
7853       ees0pkl=ees0p(kk,k)
7854       ees0mij=ees0m(jj,i)
7855       ees0mkl=ees0m(kk,k)
7856       ekont=eij*ekl
7857       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7858 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7859 C Following 4 lines for diagnostics.
7860 cd    ees0pkl=0.0D0
7861 cd    ees0pij=1.0D0
7862 cd    ees0mkl=0.0D0
7863 cd    ees0mij=1.0D0
7864 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7865 c     & 'Contacts ',i,j,
7866 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7867 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7868 c     & 'gradcorr_long'
7869 C Calculate the multi-body contribution to energy.
7870 c      ecorr=ecorr+ekont*ees
7871 C Calculate multi-body contributions to the gradient.
7872       coeffpees0pij=coeffp*ees0pij
7873       coeffmees0mij=coeffm*ees0mij
7874       coeffpees0pkl=coeffp*ees0pkl
7875       coeffmees0mkl=coeffm*ees0mkl
7876       do ll=1,3
7877 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7878         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7879      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7880      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7881         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7882      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7883      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7884 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7885         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7886      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7887      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7888         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7889      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7890      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7891         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7892      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7893      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7894         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7895         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7896         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7897      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7898      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7899         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7900         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7901 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7902       enddo
7903 c      write (iout,*)
7904 cgrad      do m=i+1,j-1
7905 cgrad        do ll=1,3
7906 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7907 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7908 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7909 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7910 cgrad        enddo
7911 cgrad      enddo
7912 cgrad      do m=k+1,l-1
7913 cgrad        do ll=1,3
7914 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7915 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7916 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7917 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7918 cgrad        enddo
7919 cgrad      enddo
7920 c      write (iout,*) "ehbcorr",ekont*ees
7921       ehbcorr=ekont*ees
7922       return
7923       end
7924 #ifdef MOMENT
7925 C---------------------------------------------------------------------------
7926       subroutine dipole(i,j,jj)
7927       implicit real*8 (a-h,o-z)
7928       include 'DIMENSIONS'
7929       include 'COMMON.IOUNITS'
7930       include 'COMMON.CHAIN'
7931       include 'COMMON.FFIELD'
7932       include 'COMMON.DERIV'
7933       include 'COMMON.INTERACT'
7934       include 'COMMON.CONTACTS'
7935       include 'COMMON.TORSION'
7936       include 'COMMON.VAR'
7937       include 'COMMON.GEO'
7938       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7939      &  auxmat(2,2)
7940       iti1 = itortyp(itype(i+1))
7941       if (j.lt.nres-1) then
7942         itj1 = itortyp(itype(j+1))
7943       else
7944         itj1=ntortyp
7945       endif
7946       do iii=1,2
7947         dipi(iii,1)=Ub2(iii,i)
7948         dipderi(iii)=Ub2der(iii,i)
7949         dipi(iii,2)=b1(iii,i+1)
7950         dipj(iii,1)=Ub2(iii,j)
7951         dipderj(iii)=Ub2der(iii,j)
7952         dipj(iii,2)=b1(iii,j+1)
7953       enddo
7954       kkk=0
7955       do iii=1,2
7956         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7957         do jjj=1,2
7958           kkk=kkk+1
7959           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7960         enddo
7961       enddo
7962       do kkk=1,5
7963         do lll=1,3
7964           mmm=0
7965           do iii=1,2
7966             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7967      &        auxvec(1))
7968             do jjj=1,2
7969               mmm=mmm+1
7970               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7971             enddo
7972           enddo
7973         enddo
7974       enddo
7975       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7976       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7977       do iii=1,2
7978         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7979       enddo
7980       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7981       do iii=1,2
7982         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7983       enddo
7984       return
7985       end
7986 #endif
7987 C---------------------------------------------------------------------------
7988       subroutine calc_eello(i,j,k,l,jj,kk)
7989 C
7990 C This subroutine computes matrices and vectors needed to calculate
7991 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7992 C
7993       implicit real*8 (a-h,o-z)
7994       include 'DIMENSIONS'
7995       include 'COMMON.IOUNITS'
7996       include 'COMMON.CHAIN'
7997       include 'COMMON.DERIV'
7998       include 'COMMON.INTERACT'
7999       include 'COMMON.CONTACTS'
8000       include 'COMMON.TORSION'
8001       include 'COMMON.VAR'
8002       include 'COMMON.GEO'
8003       include 'COMMON.FFIELD'
8004       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8005      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8006       logical lprn
8007       common /kutas/ lprn
8008 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8009 cd     & ' jj=',jj,' kk=',kk
8010 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8011 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8012 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8013       do iii=1,2
8014         do jjj=1,2
8015           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8016           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8017         enddo
8018       enddo
8019       call transpose2(aa1(1,1),aa1t(1,1))
8020       call transpose2(aa2(1,1),aa2t(1,1))
8021       do kkk=1,5
8022         do lll=1,3
8023           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8024      &      aa1tder(1,1,lll,kkk))
8025           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8026      &      aa2tder(1,1,lll,kkk))
8027         enddo
8028       enddo
8029       if (l.eq.j+1) then
8030 C parallel orientation of the two CA-CA-CA frames.
8031         if (i.gt.1) then
8032           iti=itortyp(itype(i))
8033         else
8034           iti=ntortyp
8035         endif
8036         itk1=itortyp(itype(k+1))
8037         itj=itortyp(itype(j))
8038         if (l.lt.nres-1) then
8039           itl1=itortyp(itype(l+1))
8040         else
8041           itl1=ntortyp
8042         endif
8043 C A1 kernel(j+1) A2T
8044 cd        do iii=1,2
8045 cd          write (iout,'(3f10.5,5x,3f10.5)')
8046 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8047 cd        enddo
8048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8049      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8050      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8051 C Following matrices are needed only for 6-th order cumulants
8052         IF (wcorr6.gt.0.0d0) THEN
8053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8054      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8055      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8056         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8057      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8058      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8059      &   ADtEAderx(1,1,1,1,1,1))
8060         lprn=.false.
8061         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8062      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8063      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8064      &   ADtEA1derx(1,1,1,1,1,1))
8065         ENDIF
8066 C End 6-th order cumulants
8067 cd        lprn=.false.
8068 cd        if (lprn) then
8069 cd        write (2,*) 'In calc_eello6'
8070 cd        do iii=1,2
8071 cd          write (2,*) 'iii=',iii
8072 cd          do kkk=1,5
8073 cd            write (2,*) 'kkk=',kkk
8074 cd            do jjj=1,2
8075 cd              write (2,'(3(2f10.5),5x)')
8076 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8077 cd            enddo
8078 cd          enddo
8079 cd        enddo
8080 cd        endif
8081         call transpose2(EUgder(1,1,k),auxmat(1,1))
8082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8083         call transpose2(EUg(1,1,k),auxmat(1,1))
8084         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8085         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8086         do iii=1,2
8087           do kkk=1,5
8088             do lll=1,3
8089               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8090      &          EAEAderx(1,1,lll,kkk,iii,1))
8091             enddo
8092           enddo
8093         enddo
8094 C A1T kernel(i+1) A2
8095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8096      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8097      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8098 C Following matrices are needed only for 6-th order cumulants
8099         IF (wcorr6.gt.0.0d0) THEN
8100         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8101      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8102      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8103         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8104      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8105      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8106      &   ADtEAderx(1,1,1,1,1,2))
8107         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8108      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8109      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8110      &   ADtEA1derx(1,1,1,1,1,2))
8111         ENDIF
8112 C End 6-th order cumulants
8113         call transpose2(EUgder(1,1,l),auxmat(1,1))
8114         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8115         call transpose2(EUg(1,1,l),auxmat(1,1))
8116         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8117         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8118         do iii=1,2
8119           do kkk=1,5
8120             do lll=1,3
8121               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8122      &          EAEAderx(1,1,lll,kkk,iii,2))
8123             enddo
8124           enddo
8125         enddo
8126 C AEAb1 and AEAb2
8127 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8128 C They are needed only when the fifth- or the sixth-order cumulants are
8129 C indluded.
8130         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8131         call transpose2(AEA(1,1,1),auxmat(1,1))
8132         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8134         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8135         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8136         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8137         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8138         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8139         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8140         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8141         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8142         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8143         call transpose2(AEA(1,1,2),auxmat(1,1))
8144         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8145         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8146         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8147         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8148         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8149         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8150         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8151         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8152         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8153         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8154         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8155 C Calculate the Cartesian derivatives of the vectors.
8156         do iii=1,2
8157           do kkk=1,5
8158             do lll=1,3
8159               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8160               call matvec2(auxmat(1,1),b1(1,i),
8161      &          AEAb1derx(1,lll,kkk,iii,1,1))
8162               call matvec2(auxmat(1,1),Ub2(1,i),
8163      &          AEAb2derx(1,lll,kkk,iii,1,1))
8164               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8165      &          AEAb1derx(1,lll,kkk,iii,2,1))
8166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8167      &          AEAb2derx(1,lll,kkk,iii,2,1))
8168               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8169               call matvec2(auxmat(1,1),b1(1,j),
8170      &          AEAb1derx(1,lll,kkk,iii,1,2))
8171               call matvec2(auxmat(1,1),Ub2(1,j),
8172      &          AEAb2derx(1,lll,kkk,iii,1,2))
8173               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8174      &          AEAb1derx(1,lll,kkk,iii,2,2))
8175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8176      &          AEAb2derx(1,lll,kkk,iii,2,2))
8177             enddo
8178           enddo
8179         enddo
8180         ENDIF
8181 C End vectors
8182       else
8183 C Antiparallel orientation of the two CA-CA-CA frames.
8184         if (i.gt.1) then
8185           iti=itortyp(itype(i))
8186         else
8187           iti=ntortyp
8188         endif
8189         itk1=itortyp(itype(k+1))
8190         itl=itortyp(itype(l))
8191         itj=itortyp(itype(j))
8192         if (j.lt.nres-1) then
8193           itj1=itortyp(itype(j+1))
8194         else
8195           itj1=ntortyp
8196         endif
8197 C A2 kernel(j-1)T A1T
8198         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8199      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8200      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8201 C Following matrices are needed only for 6-th order cumulants
8202         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8203      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8204         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8205      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8206      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8207         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8208      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8209      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8210      &   ADtEAderx(1,1,1,1,1,1))
8211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8212      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8213      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8214      &   ADtEA1derx(1,1,1,1,1,1))
8215         ENDIF
8216 C End 6-th order cumulants
8217         call transpose2(EUgder(1,1,k),auxmat(1,1))
8218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8219         call transpose2(EUg(1,1,k),auxmat(1,1))
8220         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8221         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8222         do iii=1,2
8223           do kkk=1,5
8224             do lll=1,3
8225               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8226      &          EAEAderx(1,1,lll,kkk,iii,1))
8227             enddo
8228           enddo
8229         enddo
8230 C A2T kernel(i+1)T A1
8231         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8232      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8233      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8234 C Following matrices are needed only for 6-th order cumulants
8235         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8236      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8237         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8238      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8239      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8240         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8241      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8242      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8243      &   ADtEAderx(1,1,1,1,1,2))
8244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8245      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8246      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8247      &   ADtEA1derx(1,1,1,1,1,2))
8248         ENDIF
8249 C End 6-th order cumulants
8250         call transpose2(EUgder(1,1,j),auxmat(1,1))
8251         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8252         call transpose2(EUg(1,1,j),auxmat(1,1))
8253         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8254         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8255         do iii=1,2
8256           do kkk=1,5
8257             do lll=1,3
8258               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8259      &          EAEAderx(1,1,lll,kkk,iii,2))
8260             enddo
8261           enddo
8262         enddo
8263 C AEAb1 and AEAb2
8264 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8265 C They are needed only when the fifth- or the sixth-order cumulants are
8266 C indluded.
8267         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8268      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8269         call transpose2(AEA(1,1,1),auxmat(1,1))
8270         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8271         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8272         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8273         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8274         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8275         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8276         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8277         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8278         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8279         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8280         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8281         call transpose2(AEA(1,1,2),auxmat(1,1))
8282         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8283         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8284         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8285         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8286         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8287         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8288         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8289         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8290         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8291         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8292         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8293 C Calculate the Cartesian derivatives of the vectors.
8294         do iii=1,2
8295           do kkk=1,5
8296             do lll=1,3
8297               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8298               call matvec2(auxmat(1,1),b1(1,i),
8299      &          AEAb1derx(1,lll,kkk,iii,1,1))
8300               call matvec2(auxmat(1,1),Ub2(1,i),
8301      &          AEAb2derx(1,lll,kkk,iii,1,1))
8302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8303      &          AEAb1derx(1,lll,kkk,iii,2,1))
8304               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8305      &          AEAb2derx(1,lll,kkk,iii,2,1))
8306               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8307               call matvec2(auxmat(1,1),b1(1,l),
8308      &          AEAb1derx(1,lll,kkk,iii,1,2))
8309               call matvec2(auxmat(1,1),Ub2(1,l),
8310      &          AEAb2derx(1,lll,kkk,iii,1,2))
8311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8312      &          AEAb1derx(1,lll,kkk,iii,2,2))
8313               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8314      &          AEAb2derx(1,lll,kkk,iii,2,2))
8315             enddo
8316           enddo
8317         enddo
8318         ENDIF
8319 C End vectors
8320       endif
8321       return
8322       end
8323 C---------------------------------------------------------------------------
8324       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8325      &  KK,KKderg,AKA,AKAderg,AKAderx)
8326       implicit none
8327       integer nderg
8328       logical transp
8329       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8330      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8331      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8332       integer iii,kkk,lll
8333       integer jjj,mmm
8334       logical lprn
8335       common /kutas/ lprn
8336       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8337       do iii=1,nderg
8338         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8339      &    AKAderg(1,1,iii))
8340       enddo
8341 cd      if (lprn) write (2,*) 'In kernel'
8342       do kkk=1,5
8343 cd        if (lprn) write (2,*) 'kkk=',kkk
8344         do lll=1,3
8345           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8346      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8347 cd          if (lprn) then
8348 cd            write (2,*) 'lll=',lll
8349 cd            write (2,*) 'iii=1'
8350 cd            do jjj=1,2
8351 cd              write (2,'(3(2f10.5),5x)')
8352 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8353 cd            enddo
8354 cd          endif
8355           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8356      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8357 cd          if (lprn) then
8358 cd            write (2,*) 'lll=',lll
8359 cd            write (2,*) 'iii=2'
8360 cd            do jjj=1,2
8361 cd              write (2,'(3(2f10.5),5x)')
8362 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8363 cd            enddo
8364 cd          endif
8365         enddo
8366       enddo
8367       return
8368       end
8369 C---------------------------------------------------------------------------
8370       double precision function eello4(i,j,k,l,jj,kk)
8371       implicit real*8 (a-h,o-z)
8372       include 'DIMENSIONS'
8373       include 'COMMON.IOUNITS'
8374       include 'COMMON.CHAIN'
8375       include 'COMMON.DERIV'
8376       include 'COMMON.INTERACT'
8377       include 'COMMON.CONTACTS'
8378       include 'COMMON.TORSION'
8379       include 'COMMON.VAR'
8380       include 'COMMON.GEO'
8381       double precision pizda(2,2),ggg1(3),ggg2(3)
8382 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8383 cd        eello4=0.0d0
8384 cd        return
8385 cd      endif
8386 cd      print *,'eello4:',i,j,k,l,jj,kk
8387 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8388 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8389 cold      eij=facont_hb(jj,i)
8390 cold      ekl=facont_hb(kk,k)
8391 cold      ekont=eij*ekl
8392       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8393 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8394       gcorr_loc(k-1)=gcorr_loc(k-1)
8395      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8396       if (l.eq.j+1) then
8397         gcorr_loc(l-1)=gcorr_loc(l-1)
8398      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8399       else
8400         gcorr_loc(j-1)=gcorr_loc(j-1)
8401      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8402       endif
8403       do iii=1,2
8404         do kkk=1,5
8405           do lll=1,3
8406             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8407      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8408 cd            derx(lll,kkk,iii)=0.0d0
8409           enddo
8410         enddo
8411       enddo
8412 cd      gcorr_loc(l-1)=0.0d0
8413 cd      gcorr_loc(j-1)=0.0d0
8414 cd      gcorr_loc(k-1)=0.0d0
8415 cd      eel4=1.0d0
8416 cd      write (iout,*)'Contacts have occurred for peptide groups',
8417 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8418 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8419       if (j.lt.nres-1) then
8420         j1=j+1
8421         j2=j-1
8422       else
8423         j1=j-1
8424         j2=j-2
8425       endif
8426       if (l.lt.nres-1) then
8427         l1=l+1
8428         l2=l-1
8429       else
8430         l1=l-1
8431         l2=l-2
8432       endif
8433       do ll=1,3
8434 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8435 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8436         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8437         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8438 cgrad        ghalf=0.5d0*ggg1(ll)
8439         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8440         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8441         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8442         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8443         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8444         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8445 cgrad        ghalf=0.5d0*ggg2(ll)
8446         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8447         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8448         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8449         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8450         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8451         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8452       enddo
8453 cgrad      do m=i+1,j-1
8454 cgrad        do ll=1,3
8455 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8456 cgrad        enddo
8457 cgrad      enddo
8458 cgrad      do m=k+1,l-1
8459 cgrad        do ll=1,3
8460 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8461 cgrad        enddo
8462 cgrad      enddo
8463 cgrad      do m=i+2,j2
8464 cgrad        do ll=1,3
8465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8466 cgrad        enddo
8467 cgrad      enddo
8468 cgrad      do m=k+2,l2
8469 cgrad        do ll=1,3
8470 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8471 cgrad        enddo
8472 cgrad      enddo
8473 cd      do iii=1,nres-3
8474 cd        write (2,*) iii,gcorr_loc(iii)
8475 cd      enddo
8476       eello4=ekont*eel4
8477 cd      write (2,*) 'ekont',ekont
8478 cd      write (iout,*) 'eello4',ekont*eel4
8479       return
8480       end
8481 C---------------------------------------------------------------------------
8482       double precision function eello5(i,j,k,l,jj,kk)
8483       implicit real*8 (a-h,o-z)
8484       include 'DIMENSIONS'
8485       include 'COMMON.IOUNITS'
8486       include 'COMMON.CHAIN'
8487       include 'COMMON.DERIV'
8488       include 'COMMON.INTERACT'
8489       include 'COMMON.CONTACTS'
8490       include 'COMMON.TORSION'
8491       include 'COMMON.VAR'
8492       include 'COMMON.GEO'
8493       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8494       double precision ggg1(3),ggg2(3)
8495 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8496 C                                                                              C
8497 C                            Parallel chains                                   C
8498 C                                                                              C
8499 C          o             o                   o             o                   C
8500 C         /l\           / \             \   / \           / \   /              C
8501 C        /   \         /   \             \ /   \         /   \ /               C
8502 C       j| o |l1       | o |              o| o |         | o |o                C
8503 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8504 C      \i/   \         /   \ /             /   \         /   \                 C
8505 C       o    k1             o                                                  C
8506 C         (I)          (II)                (III)          (IV)                 C
8507 C                                                                              C
8508 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8509 C                                                                              C
8510 C                            Antiparallel chains                               C
8511 C                                                                              C
8512 C          o             o                   o             o                   C
8513 C         /j\           / \             \   / \           / \   /              C
8514 C        /   \         /   \             \ /   \         /   \ /               C
8515 C      j1| o |l        | o |              o| o |         | o |o                C
8516 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8517 C      \i/   \         /   \ /             /   \         /   \                 C
8518 C       o     k1            o                                                  C
8519 C         (I)          (II)                (III)          (IV)                 C
8520 C                                                                              C
8521 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8522 C                                                                              C
8523 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8524 C                                                                              C
8525 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8526 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8527 cd        eello5=0.0d0
8528 cd        return
8529 cd      endif
8530 cd      write (iout,*)
8531 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8532 cd     &   ' and',k,l
8533       itk=itortyp(itype(k))
8534       itl=itortyp(itype(l))
8535       itj=itortyp(itype(j))
8536       eello5_1=0.0d0
8537       eello5_2=0.0d0
8538       eello5_3=0.0d0
8539       eello5_4=0.0d0
8540 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8541 cd     &   eel5_3_num,eel5_4_num)
8542       do iii=1,2
8543         do kkk=1,5
8544           do lll=1,3
8545             derx(lll,kkk,iii)=0.0d0
8546           enddo
8547         enddo
8548       enddo
8549 cd      eij=facont_hb(jj,i)
8550 cd      ekl=facont_hb(kk,k)
8551 cd      ekont=eij*ekl
8552 cd      write (iout,*)'Contacts have occurred for peptide groups',
8553 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8554 cd      goto 1111
8555 C Contribution from the graph I.
8556 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8557 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8558       call transpose2(EUg(1,1,k),auxmat(1,1))
8559       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8560       vv(1)=pizda(1,1)-pizda(2,2)
8561       vv(2)=pizda(1,2)+pizda(2,1)
8562       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8563      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8564 C Explicit gradient in virtual-dihedral angles.
8565       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8566      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8567      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8568       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8569       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8570       vv(1)=pizda(1,1)-pizda(2,2)
8571       vv(2)=pizda(1,2)+pizda(2,1)
8572       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8573      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8574      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8575       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8576       vv(1)=pizda(1,1)-pizda(2,2)
8577       vv(2)=pizda(1,2)+pizda(2,1)
8578       if (l.eq.j+1) then
8579         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8580      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8581      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8582       else
8583         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8584      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8585      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8586       endif
8587 C Cartesian gradient
8588       do iii=1,2
8589         do kkk=1,5
8590           do lll=1,3
8591             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8592      &        pizda(1,1))
8593             vv(1)=pizda(1,1)-pizda(2,2)
8594             vv(2)=pizda(1,2)+pizda(2,1)
8595             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8596      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8597      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8598           enddo
8599         enddo
8600       enddo
8601 c      goto 1112
8602 c1111  continue
8603 C Contribution from graph II
8604       call transpose2(EE(1,1,itk),auxmat(1,1))
8605       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8606       vv(1)=pizda(1,1)+pizda(2,2)
8607       vv(2)=pizda(2,1)-pizda(1,2)
8608       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8609      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8610 C Explicit gradient in virtual-dihedral angles.
8611       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8612      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8613       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8614       vv(1)=pizda(1,1)+pizda(2,2)
8615       vv(2)=pizda(2,1)-pizda(1,2)
8616       if (l.eq.j+1) then
8617         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8618      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8619      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8620       else
8621         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8622      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8623      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8624       endif
8625 C Cartesian gradient
8626       do iii=1,2
8627         do kkk=1,5
8628           do lll=1,3
8629             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8630      &        pizda(1,1))
8631             vv(1)=pizda(1,1)+pizda(2,2)
8632             vv(2)=pizda(2,1)-pizda(1,2)
8633             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8634      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8635      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8636           enddo
8637         enddo
8638       enddo
8639 cd      goto 1112
8640 cd1111  continue
8641       if (l.eq.j+1) then
8642 cd        goto 1110
8643 C Parallel orientation
8644 C Contribution from graph III
8645         call transpose2(EUg(1,1,l),auxmat(1,1))
8646         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8647         vv(1)=pizda(1,1)-pizda(2,2)
8648         vv(2)=pizda(1,2)+pizda(2,1)
8649         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8651 C Explicit gradient in virtual-dihedral angles.
8652         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8653      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8654      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8655         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8656         vv(1)=pizda(1,1)-pizda(2,2)
8657         vv(2)=pizda(1,2)+pizda(2,1)
8658         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8659      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8661         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8662         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8663         vv(1)=pizda(1,1)-pizda(2,2)
8664         vv(2)=pizda(1,2)+pizda(2,1)
8665         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8666      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8667      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8668 C Cartesian gradient
8669         do iii=1,2
8670           do kkk=1,5
8671             do lll=1,3
8672               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8673      &          pizda(1,1))
8674               vv(1)=pizda(1,1)-pizda(2,2)
8675               vv(2)=pizda(1,2)+pizda(2,1)
8676               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8677      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8678      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8679             enddo
8680           enddo
8681         enddo
8682 cd        goto 1112
8683 C Contribution from graph IV
8684 cd1110    continue
8685         call transpose2(EE(1,1,itl),auxmat(1,1))
8686         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8687         vv(1)=pizda(1,1)+pizda(2,2)
8688         vv(2)=pizda(2,1)-pizda(1,2)
8689         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8690      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8691 C Explicit gradient in virtual-dihedral angles.
8692         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8693      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8694         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8695         vv(1)=pizda(1,1)+pizda(2,2)
8696         vv(2)=pizda(2,1)-pizda(1,2)
8697         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8698      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8699      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8700 C Cartesian gradient
8701         do iii=1,2
8702           do kkk=1,5
8703             do lll=1,3
8704               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8705      &          pizda(1,1))
8706               vv(1)=pizda(1,1)+pizda(2,2)
8707               vv(2)=pizda(2,1)-pizda(1,2)
8708               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8709      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8710      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8711             enddo
8712           enddo
8713         enddo
8714       else
8715 C Antiparallel orientation
8716 C Contribution from graph III
8717 c        goto 1110
8718         call transpose2(EUg(1,1,j),auxmat(1,1))
8719         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8720         vv(1)=pizda(1,1)-pizda(2,2)
8721         vv(2)=pizda(1,2)+pizda(2,1)
8722         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8723      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8724 C Explicit gradient in virtual-dihedral angles.
8725         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8726      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8727      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8728         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8729         vv(1)=pizda(1,1)-pizda(2,2)
8730         vv(2)=pizda(1,2)+pizda(2,1)
8731         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8732      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8734         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8735         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8736         vv(1)=pizda(1,1)-pizda(2,2)
8737         vv(2)=pizda(1,2)+pizda(2,1)
8738         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8739      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8740      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8741 C Cartesian gradient
8742         do iii=1,2
8743           do kkk=1,5
8744             do lll=1,3
8745               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8746      &          pizda(1,1))
8747               vv(1)=pizda(1,1)-pizda(2,2)
8748               vv(2)=pizda(1,2)+pizda(2,1)
8749               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8750      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8751      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8752             enddo
8753           enddo
8754         enddo
8755 cd        goto 1112
8756 C Contribution from graph IV
8757 1110    continue
8758         call transpose2(EE(1,1,itj),auxmat(1,1))
8759         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8760         vv(1)=pizda(1,1)+pizda(2,2)
8761         vv(2)=pizda(2,1)-pizda(1,2)
8762         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8763      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8764 C Explicit gradient in virtual-dihedral angles.
8765         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8766      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8767         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8768         vv(1)=pizda(1,1)+pizda(2,2)
8769         vv(2)=pizda(2,1)-pizda(1,2)
8770         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8771      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8772      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8773 C Cartesian gradient
8774         do iii=1,2
8775           do kkk=1,5
8776             do lll=1,3
8777               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8778      &          pizda(1,1))
8779               vv(1)=pizda(1,1)+pizda(2,2)
8780               vv(2)=pizda(2,1)-pizda(1,2)
8781               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8782      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8783      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8784             enddo
8785           enddo
8786         enddo
8787       endif
8788 1112  continue
8789       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8790 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8791 cd        write (2,*) 'ijkl',i,j,k,l
8792 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8793 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8794 cd      endif
8795 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8796 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8797 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8798 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8799       if (j.lt.nres-1) then
8800         j1=j+1
8801         j2=j-1
8802       else
8803         j1=j-1
8804         j2=j-2
8805       endif
8806       if (l.lt.nres-1) then
8807         l1=l+1
8808         l2=l-1
8809       else
8810         l1=l-1
8811         l2=l-2
8812       endif
8813 cd      eij=1.0d0
8814 cd      ekl=1.0d0
8815 cd      ekont=1.0d0
8816 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8817 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8818 C        summed up outside the subrouine as for the other subroutines
8819 C        handling long-range interactions. The old code is commented out
8820 C        with "cgrad" to keep track of changes.
8821       do ll=1,3
8822 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8823 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8824         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8825         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8826 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8827 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8828 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8829 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8830 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8831 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8832 c     &   gradcorr5ij,
8833 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8834 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8835 cgrad        ghalf=0.5d0*ggg1(ll)
8836 cd        ghalf=0.0d0
8837         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8838         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8839         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8840         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8841         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8842         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8843 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8844 cgrad        ghalf=0.5d0*ggg2(ll)
8845 cd        ghalf=0.0d0
8846         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8847         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8848         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8849         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8850         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8851         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8852       enddo
8853 cd      goto 1112
8854 cgrad      do m=i+1,j-1
8855 cgrad        do ll=1,3
8856 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8857 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8858 cgrad        enddo
8859 cgrad      enddo
8860 cgrad      do m=k+1,l-1
8861 cgrad        do ll=1,3
8862 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8863 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8864 cgrad        enddo
8865 cgrad      enddo
8866 c1112  continue
8867 cgrad      do m=i+2,j2
8868 cgrad        do ll=1,3
8869 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8870 cgrad        enddo
8871 cgrad      enddo
8872 cgrad      do m=k+2,l2
8873 cgrad        do ll=1,3
8874 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8875 cgrad        enddo
8876 cgrad      enddo
8877 cd      do iii=1,nres-3
8878 cd        write (2,*) iii,g_corr5_loc(iii)
8879 cd      enddo
8880       eello5=ekont*eel5
8881 cd      write (2,*) 'ekont',ekont
8882 cd      write (iout,*) 'eello5',ekont*eel5
8883       return
8884       end
8885 c--------------------------------------------------------------------------
8886       double precision function eello6(i,j,k,l,jj,kk)
8887       implicit real*8 (a-h,o-z)
8888       include 'DIMENSIONS'
8889       include 'COMMON.IOUNITS'
8890       include 'COMMON.CHAIN'
8891       include 'COMMON.DERIV'
8892       include 'COMMON.INTERACT'
8893       include 'COMMON.CONTACTS'
8894       include 'COMMON.TORSION'
8895       include 'COMMON.VAR'
8896       include 'COMMON.GEO'
8897       include 'COMMON.FFIELD'
8898       double precision ggg1(3),ggg2(3)
8899 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8900 cd        eello6=0.0d0
8901 cd        return
8902 cd      endif
8903 cd      write (iout,*)
8904 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8905 cd     &   ' and',k,l
8906       eello6_1=0.0d0
8907       eello6_2=0.0d0
8908       eello6_3=0.0d0
8909       eello6_4=0.0d0
8910       eello6_5=0.0d0
8911       eello6_6=0.0d0
8912 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8913 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8914       do iii=1,2
8915         do kkk=1,5
8916           do lll=1,3
8917             derx(lll,kkk,iii)=0.0d0
8918           enddo
8919         enddo
8920       enddo
8921 cd      eij=facont_hb(jj,i)
8922 cd      ekl=facont_hb(kk,k)
8923 cd      ekont=eij*ekl
8924 cd      eij=1.0d0
8925 cd      ekl=1.0d0
8926 cd      ekont=1.0d0
8927       if (l.eq.j+1) then
8928         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8929         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8930         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8931         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8932         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8933         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8934       else
8935         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8936         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8937         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8938         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8939         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8940           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8941         else
8942           eello6_5=0.0d0
8943         endif
8944         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8945       endif
8946 C If turn contributions are considered, they will be handled separately.
8947       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8948 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8949 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8950 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8951 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8952 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8953 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8954 cd      goto 1112
8955       if (j.lt.nres-1) then
8956         j1=j+1
8957         j2=j-1
8958       else
8959         j1=j-1
8960         j2=j-2
8961       endif
8962       if (l.lt.nres-1) then
8963         l1=l+1
8964         l2=l-1
8965       else
8966         l1=l-1
8967         l2=l-2
8968       endif
8969       do ll=1,3
8970 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8971 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8972 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8973 cgrad        ghalf=0.5d0*ggg1(ll)
8974 cd        ghalf=0.0d0
8975         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8976         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8977         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8978         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8979         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8980         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8981         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8982         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8983 cgrad        ghalf=0.5d0*ggg2(ll)
8984 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8985 cd        ghalf=0.0d0
8986         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8987         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8988         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8989         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8990         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8991         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8992       enddo
8993 cd      goto 1112
8994 cgrad      do m=i+1,j-1
8995 cgrad        do ll=1,3
8996 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8997 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8998 cgrad        enddo
8999 cgrad      enddo
9000 cgrad      do m=k+1,l-1
9001 cgrad        do ll=1,3
9002 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9003 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9004 cgrad        enddo
9005 cgrad      enddo
9006 cgrad1112  continue
9007 cgrad      do m=i+2,j2
9008 cgrad        do ll=1,3
9009 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9010 cgrad        enddo
9011 cgrad      enddo
9012 cgrad      do m=k+2,l2
9013 cgrad        do ll=1,3
9014 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9015 cgrad        enddo
9016 cgrad      enddo
9017 cd      do iii=1,nres-3
9018 cd        write (2,*) iii,g_corr6_loc(iii)
9019 cd      enddo
9020       eello6=ekont*eel6
9021 cd      write (2,*) 'ekont',ekont
9022 cd      write (iout,*) 'eello6',ekont*eel6
9023       return
9024       end
9025 c--------------------------------------------------------------------------
9026       double precision function eello6_graph1(i,j,k,l,imat,swap)
9027       implicit real*8 (a-h,o-z)
9028       include 'DIMENSIONS'
9029       include 'COMMON.IOUNITS'
9030       include 'COMMON.CHAIN'
9031       include 'COMMON.DERIV'
9032       include 'COMMON.INTERACT'
9033       include 'COMMON.CONTACTS'
9034       include 'COMMON.TORSION'
9035       include 'COMMON.VAR'
9036       include 'COMMON.GEO'
9037       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9038       logical swap
9039       logical lprn
9040       common /kutas/ lprn
9041 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9042 C                                                                              C
9043 C      Parallel       Antiparallel                                             C
9044 C                                                                              C
9045 C          o             o                                                     C
9046 C         /l\           /j\                                                    C
9047 C        /   \         /   \                                                   C
9048 C       /| o |         | o |\                                                  C
9049 C     \ j|/k\|  /   \  |/k\|l /                                                C
9050 C      \ /   \ /     \ /   \ /                                                 C
9051 C       o     o       o     o                                                  C
9052 C       i             i                                                        C
9053 C                                                                              C
9054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9055       itk=itortyp(itype(k))
9056       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9057       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9058       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9059       call transpose2(EUgC(1,1,k),auxmat(1,1))
9060       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9061       vv1(1)=pizda1(1,1)-pizda1(2,2)
9062       vv1(2)=pizda1(1,2)+pizda1(2,1)
9063       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9064       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9065       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9066       s5=scalar2(vv(1),Dtobr2(1,i))
9067 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9068       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9069       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9070      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9071      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9072      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9073      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9074      & +scalar2(vv(1),Dtobr2der(1,i)))
9075       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9076       vv1(1)=pizda1(1,1)-pizda1(2,2)
9077       vv1(2)=pizda1(1,2)+pizda1(2,1)
9078       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9079       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9080       if (l.eq.j+1) then
9081         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9082      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9083      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9084      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9085      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9086       else
9087         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9088      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9089      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9090      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9091      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9092       endif
9093       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9094       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9095       vv1(1)=pizda1(1,1)-pizda1(2,2)
9096       vv1(2)=pizda1(1,2)+pizda1(2,1)
9097       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9098      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9099      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9100      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9101       do iii=1,2
9102         if (swap) then
9103           ind=3-iii
9104         else
9105           ind=iii
9106         endif
9107         do kkk=1,5
9108           do lll=1,3
9109             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9110             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9111             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9112             call transpose2(EUgC(1,1,k),auxmat(1,1))
9113             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9114      &        pizda1(1,1))
9115             vv1(1)=pizda1(1,1)-pizda1(2,2)
9116             vv1(2)=pizda1(1,2)+pizda1(2,1)
9117             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9118             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9119      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9120             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9121      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9122             s5=scalar2(vv(1),Dtobr2(1,i))
9123             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9124           enddo
9125         enddo
9126       enddo
9127       return
9128       end
9129 c----------------------------------------------------------------------------
9130       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9131       implicit real*8 (a-h,o-z)
9132       include 'DIMENSIONS'
9133       include 'COMMON.IOUNITS'
9134       include 'COMMON.CHAIN'
9135       include 'COMMON.DERIV'
9136       include 'COMMON.INTERACT'
9137       include 'COMMON.CONTACTS'
9138       include 'COMMON.TORSION'
9139       include 'COMMON.VAR'
9140       include 'COMMON.GEO'
9141       logical swap
9142       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9143      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9144       logical lprn
9145       common /kutas/ lprn
9146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9147 C                                                                              C
9148 C      Parallel       Antiparallel                                             C
9149 C                                                                              C
9150 C          o             o                                                     C
9151 C     \   /l\           /j\   /                                                C
9152 C      \ /   \         /   \ /                                                 C
9153 C       o| o |         | o |o                                                  C
9154 C     \ j|/k\|      \  |/k\|l                                                  C
9155 C      \ /   \       \ /   \                                                   C
9156 C       o             o                                                        C
9157 C       i             i                                                        C
9158 C                                                                              C
9159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9160 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9161 C AL 7/4/01 s1 would occur in the sixth-order moment,
9162 C           but not in a cluster cumulant
9163 #ifdef MOMENT
9164       s1=dip(1,jj,i)*dip(1,kk,k)
9165 #endif
9166       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9167       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9168       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9169       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9170       call transpose2(EUg(1,1,k),auxmat(1,1))
9171       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9172       vv(1)=pizda(1,1)-pizda(2,2)
9173       vv(2)=pizda(1,2)+pizda(2,1)
9174       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9175 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9176 #ifdef MOMENT
9177       eello6_graph2=-(s1+s2+s3+s4)
9178 #else
9179       eello6_graph2=-(s2+s3+s4)
9180 #endif
9181 c      eello6_graph2=-s3
9182 C Derivatives in gamma(i-1)
9183       if (i.gt.1) then
9184 #ifdef MOMENT
9185         s1=dipderg(1,jj,i)*dip(1,kk,k)
9186 #endif
9187         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9188         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9189         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9190         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9191 #ifdef MOMENT
9192         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9193 #else
9194         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9195 #endif
9196 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9197       endif
9198 C Derivatives in gamma(k-1)
9199 #ifdef MOMENT
9200       s1=dip(1,jj,i)*dipderg(1,kk,k)
9201 #endif
9202       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9203       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9204       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9205       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9206       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9207       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9208       vv(1)=pizda(1,1)-pizda(2,2)
9209       vv(2)=pizda(1,2)+pizda(2,1)
9210       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9211 #ifdef MOMENT
9212       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9213 #else
9214       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9215 #endif
9216 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9217 C Derivatives in gamma(j-1) or gamma(l-1)
9218       if (j.gt.1) then
9219 #ifdef MOMENT
9220         s1=dipderg(3,jj,i)*dip(1,kk,k)
9221 #endif
9222         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9223         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9224         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9225         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9226         vv(1)=pizda(1,1)-pizda(2,2)
9227         vv(2)=pizda(1,2)+pizda(2,1)
9228         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9229 #ifdef MOMENT
9230         if (swap) then
9231           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9232         else
9233           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9234         endif
9235 #endif
9236         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9237 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9238       endif
9239 C Derivatives in gamma(l-1) or gamma(j-1)
9240       if (l.gt.1) then
9241 #ifdef MOMENT
9242         s1=dip(1,jj,i)*dipderg(3,kk,k)
9243 #endif
9244         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9245         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9246         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9247         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9248         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9249         vv(1)=pizda(1,1)-pizda(2,2)
9250         vv(2)=pizda(1,2)+pizda(2,1)
9251         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9252 #ifdef MOMENT
9253         if (swap) then
9254           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9255         else
9256           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9257         endif
9258 #endif
9259         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9260 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9261       endif
9262 C Cartesian derivatives.
9263       if (lprn) then
9264         write (2,*) 'In eello6_graph2'
9265         do iii=1,2
9266           write (2,*) 'iii=',iii
9267           do kkk=1,5
9268             write (2,*) 'kkk=',kkk
9269             do jjj=1,2
9270               write (2,'(3(2f10.5),5x)')
9271      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9272             enddo
9273           enddo
9274         enddo
9275       endif
9276       do iii=1,2
9277         do kkk=1,5
9278           do lll=1,3
9279 #ifdef MOMENT
9280             if (iii.eq.1) then
9281               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9282             else
9283               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9284             endif
9285 #endif
9286             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9287      &        auxvec(1))
9288             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9289             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9290      &        auxvec(1))
9291             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9292             call transpose2(EUg(1,1,k),auxmat(1,1))
9293             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9294      &        pizda(1,1))
9295             vv(1)=pizda(1,1)-pizda(2,2)
9296             vv(2)=pizda(1,2)+pizda(2,1)
9297             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9298 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9299 #ifdef MOMENT
9300             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9301 #else
9302             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9303 #endif
9304             if (swap) then
9305               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9306             else
9307               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9308             endif
9309           enddo
9310         enddo
9311       enddo
9312       return
9313       end
9314 c----------------------------------------------------------------------------
9315       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9316       implicit real*8 (a-h,o-z)
9317       include 'DIMENSIONS'
9318       include 'COMMON.IOUNITS'
9319       include 'COMMON.CHAIN'
9320       include 'COMMON.DERIV'
9321       include 'COMMON.INTERACT'
9322       include 'COMMON.CONTACTS'
9323       include 'COMMON.TORSION'
9324       include 'COMMON.VAR'
9325       include 'COMMON.GEO'
9326       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9327       logical swap
9328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9329 C                                                                              C
9330 C      Parallel       Antiparallel                                             C
9331 C                                                                              C
9332 C          o             o                                                     C
9333 C         /l\   /   \   /j\                                                    C
9334 C        /   \ /     \ /   \                                                   C
9335 C       /| o |o       o| o |\                                                  C
9336 C       j|/k\|  /      |/k\|l /                                                C
9337 C        /   \ /       /   \ /                                                 C
9338 C       /     o       /     o                                                  C
9339 C       i             i                                                        C
9340 C                                                                              C
9341 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9342 C
9343 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9344 C           energy moment and not to the cluster cumulant.
9345       iti=itortyp(itype(i))
9346       if (j.lt.nres-1) then
9347         itj1=itortyp(itype(j+1))
9348       else
9349         itj1=ntortyp
9350       endif
9351       itk=itortyp(itype(k))
9352       itk1=itortyp(itype(k+1))
9353       if (l.lt.nres-1) then
9354         itl1=itortyp(itype(l+1))
9355       else
9356         itl1=ntortyp
9357       endif
9358 #ifdef MOMENT
9359       s1=dip(4,jj,i)*dip(4,kk,k)
9360 #endif
9361       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9362       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9363       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9364       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9365       call transpose2(EE(1,1,itk),auxmat(1,1))
9366       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9367       vv(1)=pizda(1,1)+pizda(2,2)
9368       vv(2)=pizda(2,1)-pizda(1,2)
9369       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9370 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9371 cd     & "sum",-(s2+s3+s4)
9372 #ifdef MOMENT
9373       eello6_graph3=-(s1+s2+s3+s4)
9374 #else
9375       eello6_graph3=-(s2+s3+s4)
9376 #endif
9377 c      eello6_graph3=-s4
9378 C Derivatives in gamma(k-1)
9379       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9380       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9381       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9382       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9383 C Derivatives in gamma(l-1)
9384       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9385       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9386       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9387       vv(1)=pizda(1,1)+pizda(2,2)
9388       vv(2)=pizda(2,1)-pizda(1,2)
9389       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9390       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9391 C Cartesian derivatives.
9392       do iii=1,2
9393         do kkk=1,5
9394           do lll=1,3
9395 #ifdef MOMENT
9396             if (iii.eq.1) then
9397               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9398             else
9399               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9400             endif
9401 #endif
9402             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9403      &        auxvec(1))
9404             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9405             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9406      &        auxvec(1))
9407             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9408             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9409      &        pizda(1,1))
9410             vv(1)=pizda(1,1)+pizda(2,2)
9411             vv(2)=pizda(2,1)-pizda(1,2)
9412             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9413 #ifdef MOMENT
9414             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9415 #else
9416             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9417 #endif
9418             if (swap) then
9419               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9420             else
9421               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9422             endif
9423 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9424           enddo
9425         enddo
9426       enddo
9427       return
9428       end
9429 c----------------------------------------------------------------------------
9430       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9431       implicit real*8 (a-h,o-z)
9432       include 'DIMENSIONS'
9433       include 'COMMON.IOUNITS'
9434       include 'COMMON.CHAIN'
9435       include 'COMMON.DERIV'
9436       include 'COMMON.INTERACT'
9437       include 'COMMON.CONTACTS'
9438       include 'COMMON.TORSION'
9439       include 'COMMON.VAR'
9440       include 'COMMON.GEO'
9441       include 'COMMON.FFIELD'
9442       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9443      & auxvec1(2),auxmat1(2,2)
9444       logical swap
9445 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9446 C                                                                              C
9447 C      Parallel       Antiparallel                                             C
9448 C                                                                              C
9449 C          o             o                                                     C
9450 C         /l\   /   \   /j\                                                    C
9451 C        /   \ /     \ /   \                                                   C
9452 C       /| o |o       o| o |\                                                  C
9453 C     \ j|/k\|      \  |/k\|l                                                  C
9454 C      \ /   \       \ /   \                                                   C
9455 C       o     \       o     \                                                  C
9456 C       i             i                                                        C
9457 C                                                                              C
9458 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9459 C
9460 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9461 C           energy moment and not to the cluster cumulant.
9462 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9463       iti=itortyp(itype(i))
9464       itj=itortyp(itype(j))
9465       if (j.lt.nres-1) then
9466         itj1=itortyp(itype(j+1))
9467       else
9468         itj1=ntortyp
9469       endif
9470       itk=itortyp(itype(k))
9471       if (k.lt.nres-1) then
9472         itk1=itortyp(itype(k+1))
9473       else
9474         itk1=ntortyp
9475       endif
9476       itl=itortyp(itype(l))
9477       if (l.lt.nres-1) then
9478         itl1=itortyp(itype(l+1))
9479       else
9480         itl1=ntortyp
9481       endif
9482 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9483 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9484 cd     & ' itl',itl,' itl1',itl1
9485 #ifdef MOMENT
9486       if (imat.eq.1) then
9487         s1=dip(3,jj,i)*dip(3,kk,k)
9488       else
9489         s1=dip(2,jj,j)*dip(2,kk,l)
9490       endif
9491 #endif
9492       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9493       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9494       if (j.eq.l+1) then
9495         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9496         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9497       else
9498         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9499         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9500       endif
9501       call transpose2(EUg(1,1,k),auxmat(1,1))
9502       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9503       vv(1)=pizda(1,1)-pizda(2,2)
9504       vv(2)=pizda(2,1)+pizda(1,2)
9505       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9506 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9507 #ifdef MOMENT
9508       eello6_graph4=-(s1+s2+s3+s4)
9509 #else
9510       eello6_graph4=-(s2+s3+s4)
9511 #endif
9512 C Derivatives in gamma(i-1)
9513       if (i.gt.1) then
9514 #ifdef MOMENT
9515         if (imat.eq.1) then
9516           s1=dipderg(2,jj,i)*dip(3,kk,k)
9517         else
9518           s1=dipderg(4,jj,j)*dip(2,kk,l)
9519         endif
9520 #endif
9521         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9522         if (j.eq.l+1) then
9523           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9524           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9525         else
9526           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9527           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9528         endif
9529         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9530         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9531 cd          write (2,*) 'turn6 derivatives'
9532 #ifdef MOMENT
9533           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9534 #else
9535           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9536 #endif
9537         else
9538 #ifdef MOMENT
9539           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9540 #else
9541           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9542 #endif
9543         endif
9544       endif
9545 C Derivatives in gamma(k-1)
9546 #ifdef MOMENT
9547       if (imat.eq.1) then
9548         s1=dip(3,jj,i)*dipderg(2,kk,k)
9549       else
9550         s1=dip(2,jj,j)*dipderg(4,kk,l)
9551       endif
9552 #endif
9553       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9554       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9555       if (j.eq.l+1) then
9556         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9557         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9558       else
9559         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9560         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9561       endif
9562       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9563       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9564       vv(1)=pizda(1,1)-pizda(2,2)
9565       vv(2)=pizda(2,1)+pizda(1,2)
9566       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9567       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9568 #ifdef MOMENT
9569         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9570 #else
9571         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9572 #endif
9573       else
9574 #ifdef MOMENT
9575         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9576 #else
9577         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9578 #endif
9579       endif
9580 C Derivatives in gamma(j-1) or gamma(l-1)
9581       if (l.eq.j+1 .and. l.gt.1) then
9582         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9583         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9584         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9585         vv(1)=pizda(1,1)-pizda(2,2)
9586         vv(2)=pizda(2,1)+pizda(1,2)
9587         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9588         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9589       else if (j.gt.1) then
9590         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9591         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9592         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9593         vv(1)=pizda(1,1)-pizda(2,2)
9594         vv(2)=pizda(2,1)+pizda(1,2)
9595         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9596         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9597           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9598         else
9599           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9600         endif
9601       endif
9602 C Cartesian derivatives.
9603       do iii=1,2
9604         do kkk=1,5
9605           do lll=1,3
9606 #ifdef MOMENT
9607             if (iii.eq.1) then
9608               if (imat.eq.1) then
9609                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9610               else
9611                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9612               endif
9613             else
9614               if (imat.eq.1) then
9615                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9616               else
9617                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9618               endif
9619             endif
9620 #endif
9621             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9622      &        auxvec(1))
9623             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9624             if (j.eq.l+1) then
9625               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9626      &          b1(1,j+1),auxvec(1))
9627               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9628             else
9629               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9630      &          b1(1,l+1),auxvec(1))
9631               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9632             endif
9633             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9634      &        pizda(1,1))
9635             vv(1)=pizda(1,1)-pizda(2,2)
9636             vv(2)=pizda(2,1)+pizda(1,2)
9637             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9638             if (swap) then
9639               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9640 #ifdef MOMENT
9641                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9642      &             -(s1+s2+s4)
9643 #else
9644                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9645      &             -(s2+s4)
9646 #endif
9647                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9648               else
9649 #ifdef MOMENT
9650                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9651 #else
9652                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9653 #endif
9654                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9655               endif
9656             else
9657 #ifdef MOMENT
9658               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9659 #else
9660               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9661 #endif
9662               if (l.eq.j+1) then
9663                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9664               else
9665                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9666               endif
9667             endif
9668           enddo
9669         enddo
9670       enddo
9671       return
9672       end
9673 c----------------------------------------------------------------------------
9674       double precision function eello_turn6(i,jj,kk)
9675       implicit real*8 (a-h,o-z)
9676       include 'DIMENSIONS'
9677       include 'COMMON.IOUNITS'
9678       include 'COMMON.CHAIN'
9679       include 'COMMON.DERIV'
9680       include 'COMMON.INTERACT'
9681       include 'COMMON.CONTACTS'
9682       include 'COMMON.TORSION'
9683       include 'COMMON.VAR'
9684       include 'COMMON.GEO'
9685       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9686      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9687      &  ggg1(3),ggg2(3)
9688       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9689      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9690 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9691 C           the respective energy moment and not to the cluster cumulant.
9692       s1=0.0d0
9693       s8=0.0d0
9694       s13=0.0d0
9695 c
9696       eello_turn6=0.0d0
9697       j=i+4
9698       k=i+1
9699       l=i+3
9700       iti=itortyp(itype(i))
9701       itk=itortyp(itype(k))
9702       itk1=itortyp(itype(k+1))
9703       itl=itortyp(itype(l))
9704       itj=itortyp(itype(j))
9705 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9706 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9707 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9708 cd        eello6=0.0d0
9709 cd        return
9710 cd      endif
9711 cd      write (iout,*)
9712 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9713 cd     &   ' and',k,l
9714 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9715       do iii=1,2
9716         do kkk=1,5
9717           do lll=1,3
9718             derx_turn(lll,kkk,iii)=0.0d0
9719           enddo
9720         enddo
9721       enddo
9722 cd      eij=1.0d0
9723 cd      ekl=1.0d0
9724 cd      ekont=1.0d0
9725       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9726 cd      eello6_5=0.0d0
9727 cd      write (2,*) 'eello6_5',eello6_5
9728 #ifdef MOMENT
9729       call transpose2(AEA(1,1,1),auxmat(1,1))
9730       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9731       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9732       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9733 #endif
9734       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9735       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9736       s2 = scalar2(b1(1,k),vtemp1(1))
9737 #ifdef MOMENT
9738       call transpose2(AEA(1,1,2),atemp(1,1))
9739       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9740       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9741       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9742 #endif
9743       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9744       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9745       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9746 #ifdef MOMENT
9747       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9748       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9749       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9750       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9751       ss13 = scalar2(b1(1,k),vtemp4(1))
9752       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9753 #endif
9754 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9755 c      s1=0.0d0
9756 c      s2=0.0d0
9757 c      s8=0.0d0
9758 c      s12=0.0d0
9759 c      s13=0.0d0
9760       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9761 C Derivatives in gamma(i+2)
9762       s1d =0.0d0
9763       s8d =0.0d0
9764 #ifdef MOMENT
9765       call transpose2(AEA(1,1,1),auxmatd(1,1))
9766       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9767       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9768       call transpose2(AEAderg(1,1,2),atempd(1,1))
9769       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9770       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9771 #endif
9772       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9773       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9774       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9775 c      s1d=0.0d0
9776 c      s2d=0.0d0
9777 c      s8d=0.0d0
9778 c      s12d=0.0d0
9779 c      s13d=0.0d0
9780       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9781 C Derivatives in gamma(i+3)
9782 #ifdef MOMENT
9783       call transpose2(AEA(1,1,1),auxmatd(1,1))
9784       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9785       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9786       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9787 #endif
9788       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9789       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9790       s2d = scalar2(b1(1,k),vtemp1d(1))
9791 #ifdef MOMENT
9792       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9793       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9794 #endif
9795       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9796 #ifdef MOMENT
9797       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9798       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9799       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9800 #endif
9801 c      s1d=0.0d0
9802 c      s2d=0.0d0
9803 c      s8d=0.0d0
9804 c      s12d=0.0d0
9805 c      s13d=0.0d0
9806 #ifdef MOMENT
9807       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9808      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9809 #else
9810       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9811      &               -0.5d0*ekont*(s2d+s12d)
9812 #endif
9813 C Derivatives in gamma(i+4)
9814       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9815       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9816       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9817 #ifdef MOMENT
9818       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9819       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9820       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9821 #endif
9822 c      s1d=0.0d0
9823 c      s2d=0.0d0
9824 c      s8d=0.0d0
9825 C      s12d=0.0d0
9826 c      s13d=0.0d0
9827 #ifdef MOMENT
9828       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9829 #else
9830       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9831 #endif
9832 C Derivatives in gamma(i+5)
9833 #ifdef MOMENT
9834       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9835       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9836       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9837 #endif
9838       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9839       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9840       s2d = scalar2(b1(1,k),vtemp1d(1))
9841 #ifdef MOMENT
9842       call transpose2(AEA(1,1,2),atempd(1,1))
9843       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9844       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9845 #endif
9846       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9847       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9848 #ifdef MOMENT
9849       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9850       ss13d = scalar2(b1(1,k),vtemp4d(1))
9851       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9852 #endif
9853 c      s1d=0.0d0
9854 c      s2d=0.0d0
9855 c      s8d=0.0d0
9856 c      s12d=0.0d0
9857 c      s13d=0.0d0
9858 #ifdef MOMENT
9859       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9860      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9861 #else
9862       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9863      &               -0.5d0*ekont*(s2d+s12d)
9864 #endif
9865 C Cartesian derivatives
9866       do iii=1,2
9867         do kkk=1,5
9868           do lll=1,3
9869 #ifdef MOMENT
9870             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9871             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9872             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9873 #endif
9874             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9875             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9876      &          vtemp1d(1))
9877             s2d = scalar2(b1(1,k),vtemp1d(1))
9878 #ifdef MOMENT
9879             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9880             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9881             s8d = -(atempd(1,1)+atempd(2,2))*
9882      &           scalar2(cc(1,1,itl),vtemp2(1))
9883 #endif
9884             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9885      &           auxmatd(1,1))
9886             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9887             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9888 c      s1d=0.0d0
9889 c      s2d=0.0d0
9890 c      s8d=0.0d0
9891 c      s12d=0.0d0
9892 c      s13d=0.0d0
9893 #ifdef MOMENT
9894             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9895      &        - 0.5d0*(s1d+s2d)
9896 #else
9897             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9898      &        - 0.5d0*s2d
9899 #endif
9900 #ifdef MOMENT
9901             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9902      &        - 0.5d0*(s8d+s12d)
9903 #else
9904             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9905      &        - 0.5d0*s12d
9906 #endif
9907           enddo
9908         enddo
9909       enddo
9910 #ifdef MOMENT
9911       do kkk=1,5
9912         do lll=1,3
9913           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9914      &      achuj_tempd(1,1))
9915           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9916           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9917           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9918           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9919           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9920      &      vtemp4d(1))
9921           ss13d = scalar2(b1(1,k),vtemp4d(1))
9922           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9923           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9924         enddo
9925       enddo
9926 #endif
9927 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9928 cd     &  16*eel_turn6_num
9929 cd      goto 1112
9930       if (j.lt.nres-1) then
9931         j1=j+1
9932         j2=j-1
9933       else
9934         j1=j-1
9935         j2=j-2
9936       endif
9937       if (l.lt.nres-1) then
9938         l1=l+1
9939         l2=l-1
9940       else
9941         l1=l-1
9942         l2=l-2
9943       endif
9944       do ll=1,3
9945 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9946 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9947 cgrad        ghalf=0.5d0*ggg1(ll)
9948 cd        ghalf=0.0d0
9949         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9950         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9951         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9952      &    +ekont*derx_turn(ll,2,1)
9953         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9954         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9955      &    +ekont*derx_turn(ll,4,1)
9956         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9957         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9958         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9959 cgrad        ghalf=0.5d0*ggg2(ll)
9960 cd        ghalf=0.0d0
9961         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9962      &    +ekont*derx_turn(ll,2,2)
9963         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9964         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9965      &    +ekont*derx_turn(ll,4,2)
9966         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9967         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9968         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9969       enddo
9970 cd      goto 1112
9971 cgrad      do m=i+1,j-1
9972 cgrad        do ll=1,3
9973 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9974 cgrad        enddo
9975 cgrad      enddo
9976 cgrad      do m=k+1,l-1
9977 cgrad        do ll=1,3
9978 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9979 cgrad        enddo
9980 cgrad      enddo
9981 cgrad1112  continue
9982 cgrad      do m=i+2,j2
9983 cgrad        do ll=1,3
9984 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9985 cgrad        enddo
9986 cgrad      enddo
9987 cgrad      do m=k+2,l2
9988 cgrad        do ll=1,3
9989 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9990 cgrad        enddo
9991 cgrad      enddo
9992 cd      do iii=1,nres-3
9993 cd        write (2,*) iii,g_corr6_loc(iii)
9994 cd      enddo
9995       eello_turn6=ekont*eel_turn6
9996 cd      write (2,*) 'ekont',ekont
9997 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9998       return
9999       end
10000
10001 C-----------------------------------------------------------------------------
10002       double precision function scalar(u,v)
10003 !DIR$ INLINEALWAYS scalar
10004 #ifndef OSF
10005 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10006 #endif
10007       implicit none
10008       double precision u(3),v(3)
10009 cd      double precision sc
10010 cd      integer i
10011 cd      sc=0.0d0
10012 cd      do i=1,3
10013 cd        sc=sc+u(i)*v(i)
10014 cd      enddo
10015 cd      scalar=sc
10016
10017       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10018       return
10019       end
10020 crc-------------------------------------------------
10021       SUBROUTINE MATVEC2(A1,V1,V2)
10022 !DIR$ INLINEALWAYS MATVEC2
10023 #ifndef OSF
10024 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10025 #endif
10026       implicit real*8 (a-h,o-z)
10027       include 'DIMENSIONS'
10028       DIMENSION A1(2,2),V1(2),V2(2)
10029 c      DO 1 I=1,2
10030 c        VI=0.0
10031 c        DO 3 K=1,2
10032 c    3     VI=VI+A1(I,K)*V1(K)
10033 c        Vaux(I)=VI
10034 c    1 CONTINUE
10035
10036       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10037       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10038
10039       v2(1)=vaux1
10040       v2(2)=vaux2
10041       END
10042 C---------------------------------------
10043       SUBROUTINE MATMAT2(A1,A2,A3)
10044 #ifndef OSF
10045 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10046 #endif
10047       implicit real*8 (a-h,o-z)
10048       include 'DIMENSIONS'
10049       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10050 c      DIMENSION AI3(2,2)
10051 c        DO  J=1,2
10052 c          A3IJ=0.0
10053 c          DO K=1,2
10054 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10055 c          enddo
10056 c          A3(I,J)=A3IJ
10057 c       enddo
10058 c      enddo
10059
10060       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10061       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10062       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10063       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10064
10065       A3(1,1)=AI3_11
10066       A3(2,1)=AI3_21
10067       A3(1,2)=AI3_12
10068       A3(2,2)=AI3_22
10069       END
10070
10071 c-------------------------------------------------------------------------
10072       double precision function scalar2(u,v)
10073 !DIR$ INLINEALWAYS scalar2
10074       implicit none
10075       double precision u(2),v(2)
10076       double precision sc
10077       integer i
10078       scalar2=u(1)*v(1)+u(2)*v(2)
10079       return
10080       end
10081
10082 C-----------------------------------------------------------------------------
10083
10084       subroutine transpose2(a,at)
10085 !DIR$ INLINEALWAYS transpose2
10086 #ifndef OSF
10087 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10088 #endif
10089       implicit none
10090       double precision a(2,2),at(2,2)
10091       at(1,1)=a(1,1)
10092       at(1,2)=a(2,1)
10093       at(2,1)=a(1,2)
10094       at(2,2)=a(2,2)
10095       return
10096       end
10097 c--------------------------------------------------------------------------
10098       subroutine transpose(n,a,at)
10099       implicit none
10100       integer n,i,j
10101       double precision a(n,n),at(n,n)
10102       do i=1,n
10103         do j=1,n
10104           at(j,i)=a(i,j)
10105         enddo
10106       enddo
10107       return
10108       end
10109 C---------------------------------------------------------------------------
10110       subroutine prodmat3(a1,a2,kk,transp,prod)
10111 !DIR$ INLINEALWAYS prodmat3
10112 #ifndef OSF
10113 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10114 #endif
10115       implicit none
10116       integer i,j
10117       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10118       logical transp
10119 crc      double precision auxmat(2,2),prod_(2,2)
10120
10121       if (transp) then
10122 crc        call transpose2(kk(1,1),auxmat(1,1))
10123 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10124 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10125
10126            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10127      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10128            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10129      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10130            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10131      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10132            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10133      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10134
10135       else
10136 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10137 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10138
10139            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10140      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10141            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10142      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10143            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10144      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10145            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10146      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10147
10148       endif
10149 c      call transpose2(a2(1,1),a2t(1,1))
10150
10151 crc      print *,transp
10152 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10153 crc      print *,((prod(i,j),i=1,2),j=1,2)
10154
10155       return
10156       end
10157 CCC----------------------------------------------
10158       subroutine Eliptransfer(eliptran)
10159       implicit real*8 (a-h,o-z)
10160       include 'DIMENSIONS'
10161       include 'COMMON.GEO'
10162       include 'COMMON.VAR'
10163       include 'COMMON.LOCAL'
10164       include 'COMMON.CHAIN'
10165       include 'COMMON.DERIV'
10166       include 'COMMON.NAMES'
10167       include 'COMMON.INTERACT'
10168       include 'COMMON.IOUNITS'
10169       include 'COMMON.CALC'
10170       include 'COMMON.CONTROL'
10171       include 'COMMON.SPLITELE'
10172       include 'COMMON.SBRIDGE'
10173 C this is done by Adasko
10174 C      print *,"wchodze"
10175 C structure of box:
10176 C      water
10177 C--bordliptop-- buffore starts
10178 C--bufliptop--- here true lipid starts
10179 C      lipid
10180 C--buflipbot--- lipid ends buffore starts
10181 C--bordlipbot--buffore ends
10182       eliptran=0.0
10183       do i=ilip_start,ilip_end
10184 C       do i=1,1
10185         if (itype(i).eq.ntyp1) cycle
10186
10187         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10188         if (positi.le.0) positi=positi+boxzsize
10189 C        print *,i
10190 C first for peptide groups
10191 c for each residue check if it is in lipid or lipid water border area
10192        if ((positi.gt.bordlipbot)
10193      &.and.(positi.lt.bordliptop)) then
10194 C the energy transfer exist
10195         if (positi.lt.buflipbot) then
10196 C what fraction I am in
10197          fracinbuf=1.0d0-
10198      &        ((positi-bordlipbot)/lipbufthick)
10199 C lipbufthick is thickenes of lipid buffore
10200          sslip=sscalelip(fracinbuf)
10201          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10202          eliptran=eliptran+sslip*pepliptran
10203          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10204          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10205 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10206
10207 C        print *,"doing sccale for lower part"
10208 C         print *,i,sslip,fracinbuf,ssgradlip
10209         elseif (positi.gt.bufliptop) then
10210          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10211          sslip=sscalelip(fracinbuf)
10212          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10213          eliptran=eliptran+sslip*pepliptran
10214          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10215          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10216 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10217 C          print *, "doing sscalefor top part"
10218 C         print *,i,sslip,fracinbuf,ssgradlip
10219         else
10220          eliptran=eliptran+pepliptran
10221 C         print *,"I am in true lipid"
10222         endif
10223 C       else
10224 C       eliptran=elpitran+0.0 ! I am in water
10225        endif
10226        enddo
10227 C       print *, "nic nie bylo w lipidzie?"
10228 C now multiply all by the peptide group transfer factor
10229 C       eliptran=eliptran*pepliptran
10230 C now the same for side chains
10231 CV       do i=1,1
10232        do i=ilip_start,ilip_end
10233         if (itype(i).eq.ntyp1) cycle
10234         positi=(mod(c(3,i+nres),boxzsize))
10235         if (positi.le.0) positi=positi+boxzsize
10236 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10237 c for each residue check if it is in lipid or lipid water border area
10238 C       respos=mod(c(3,i+nres),boxzsize)
10239 C       print *,positi,bordlipbot,buflipbot
10240        if ((positi.gt.bordlipbot)
10241      & .and.(positi.lt.bordliptop)) then
10242 C the energy transfer exist
10243         if (positi.lt.buflipbot) then
10244          fracinbuf=1.0d0-
10245      &     ((positi-bordlipbot)/lipbufthick)
10246 C lipbufthick is thickenes of lipid buffore
10247          sslip=sscalelip(fracinbuf)
10248          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10249          eliptran=eliptran+sslip*liptranene(itype(i))
10250          gliptranx(3,i)=gliptranx(3,i)
10251      &+ssgradlip*liptranene(itype(i))
10252          gliptranc(3,i-1)= gliptranc(3,i-1)
10253      &+ssgradlip*liptranene(itype(i))
10254 C         print *,"doing sccale for lower part"
10255         elseif (positi.gt.bufliptop) then
10256          fracinbuf=1.0d0-
10257      &((bordliptop-positi)/lipbufthick)
10258          sslip=sscalelip(fracinbuf)
10259          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10260          eliptran=eliptran+sslip*liptranene(itype(i))
10261          gliptranx(3,i)=gliptranx(3,i)
10262      &+ssgradlip*liptranene(itype(i))
10263          gliptranc(3,i-1)= gliptranc(3,i-1)
10264      &+ssgradlip*liptranene(itype(i))
10265 C          print *, "doing sscalefor top part",sslip,fracinbuf
10266         else
10267          eliptran=eliptran+liptranene(itype(i))
10268 C         print *,"I am in true lipid"
10269         endif
10270         endif ! if in lipid or buffor
10271 C       else
10272 C       eliptran=elpitran+0.0 ! I am in water
10273        enddo
10274        return
10275        end
10276 C---------------------------------------------------------
10277 C AFM soubroutine for constant force
10278        subroutine AFMforce(Eafmforce)
10279        implicit real*8 (a-h,o-z)
10280       include 'DIMENSIONS'
10281       include 'COMMON.GEO'
10282       include 'COMMON.VAR'
10283       include 'COMMON.LOCAL'
10284       include 'COMMON.CHAIN'
10285       include 'COMMON.DERIV'
10286       include 'COMMON.NAMES'
10287       include 'COMMON.INTERACT'
10288       include 'COMMON.IOUNITS'
10289       include 'COMMON.CALC'
10290       include 'COMMON.CONTROL'
10291       include 'COMMON.SPLITELE'
10292       include 'COMMON.SBRIDGE'
10293       real*8 diffafm(3)
10294       dist=0.0d0
10295       Eafmforce=0.0d0
10296       do i=1,3
10297       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10298       dist=dist+diffafm(i)**2
10299       enddo
10300       dist=dsqrt(dist)
10301       Eafmforce=-forceAFMconst*(dist-distafminit)
10302       do i=1,3
10303       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10304       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10305       enddo
10306 C      print *,'AFM',Eafmforce
10307       return
10308       end
10309 C---------------------------------------------------------
10310 C AFM subroutine with pseudoconstant velocity
10311        subroutine AFMvel(Eafmforce)
10312        implicit real*8 (a-h,o-z)
10313       include 'DIMENSIONS'
10314       include 'COMMON.GEO'
10315       include 'COMMON.VAR'
10316       include 'COMMON.LOCAL'
10317       include 'COMMON.CHAIN'
10318       include 'COMMON.DERIV'
10319       include 'COMMON.NAMES'
10320       include 'COMMON.INTERACT'
10321       include 'COMMON.IOUNITS'
10322       include 'COMMON.CALC'
10323       include 'COMMON.CONTROL'
10324       include 'COMMON.SPLITELE'
10325       include 'COMMON.SBRIDGE'
10326       real*8 diffafm(3)
10327 C Only for check grad COMMENT if not used for checkgrad
10328 C      totT=3.0d0
10329 C--------------------------------------------------------
10330 C      print *,"wchodze"
10331       dist=0.0d0
10332       Eafmforce=0.0d0
10333       do i=1,3
10334       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10335       dist=dist+diffafm(i)**2
10336       enddo
10337       dist=dsqrt(dist)
10338       Eafmforce=0.5d0*forceAFMconst
10339      & *(distafminit+totTafm*velAFMconst-dist)**2
10340 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10341       do i=1,3
10342       gradafm(i,afmend-1)=-forceAFMconst*
10343      &(distafminit+totTafm*velAFMconst-dist)
10344      &*diffafm(i)/dist
10345       gradafm(i,afmbeg-1)=forceAFMconst*
10346      &(distafminit+totTafm*velAFMconst-dist)
10347      &*diffafm(i)/dist
10348       enddo
10349 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10350       return
10351       end
10352