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         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164      &   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
 218       if (constr_homology.ge.1) then
 219         call e_modeller(ehomology_constr)
 220 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 221 c     &  'Processor',fg_rank,' CG group',kolor,
 222 c     &  ' absolute rank',MyRank
 223       else
 224         ehomology_constr=0.0d0
 225       endif
 226
 227
 228 c      write(iout,*) ehomology_constr
 229 c      print *,"Processor",myrank," computed Utor"
 230 C
 231 C 6/23/01 Calculate double-torsional energy
 232 C
 233       if (wtor_d.gt.0) then
 234        call etor_d(etors_d)
 235       else
 236        etors_d=0
 237       endif
 238 c      print *,"Processor",myrank," computed Utord"
 239 C
 240 C 21/5/07 Calculate local sicdechain correlation energy
 241 C
 242       if (wsccor.gt.0.0d0) then
 243         call eback_sc_corr(esccor)
 244       else
 245         esccor=0.0d0
 246       endif
 247 C      print *,"PRZED MULIt"
 248 c      print *,"Processor",myrank," computed Usccorr"
 249 C
 250 C 12/1/95 Multi-body terms
 251 C
 252       n_corr=0
 253       n_corr1=0
 254       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 255      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 256          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 257 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 258 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 259       else
 260          ecorr=0.0d0
 261          ecorr5=0.0d0
 262          ecorr6=0.0d0
 263          eturn6=0.0d0
 264       endif
 265       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 266          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 267 cd         write (iout,*) "multibody_hb ecorr",ecorr
 268       endif
 269 c      print *,"Processor",myrank," computed Ucorr"
 270 C
 271 C If performing constraint dynamics, call the constraint energy
 272 C  after the equilibration time
 273       if(usampl.and.totT.gt.eq_time) then
 274          call EconstrQ
 275          call Econstr_back
 276       else
 277          Uconst=0.0d0
 278          Uconst_back=0.0d0
 279       endif
 280 C 01/27/2015 added by adasko
 281 C the energy component below is energy transfer into lipid environment
 282 C based on partition function
 283 C      print *,"przed lipidami"
 284       if (wliptran.gt.0) then
 285         call Eliptransfer(eliptran)
 286       endif
 287 C      print *,"za lipidami"
 288       if (AFMlog.gt.0) then
 289         call AFMforce(Eafmforce)
 290       else if (selfguide.gt.0) then
 291         call AFMvel(Eafmforce)
 292       endif
 293 #ifdef TIMING
 294       time_enecalc=time_enecalc+MPI_Wtime()-time00
 295 #endif
 296 c      print *,"Processor",myrank," computed Uconstr"
 297 #ifdef TIMING
 298       time00=MPI_Wtime()
 299 #endif
 300 c
 301 C Sum the energies
 302 C
 303       energia(1)=evdw
 304 #ifdef SCP14
 305       energia(2)=evdw2-evdw2_14
 306       energia(18)=evdw2_14
 307 #else
 308       energia(2)=evdw2
 309       energia(18)=0.0d0
 310 #endif
 311 #ifdef SPLITELE
 312       energia(3)=ees
 313       energia(16)=evdw1
 314 #else
 315       energia(3)=ees+evdw1
 316       energia(16)=0.0d0
 317 #endif
 318       energia(4)=ecorr
 319       energia(5)=ecorr5
 320       energia(6)=ecorr6
 321       energia(7)=eel_loc
 322       energia(8)=eello_turn3
 323       energia(9)=eello_turn4
 324       energia(10)=eturn6
 325       energia(11)=ebe
 326       energia(12)=escloc
 327       energia(13)=etors
 328       energia(14)=etors_d
 329       energia(15)=ehpb
 330       energia(19)=edihcnstr
 331       energia(17)=estr
 332       energia(20)=Uconst+Uconst_back
 333       energia(21)=esccor
 334       energia(22)=eliptran
 335       energia(23)=Eafmforce
 336       energia(24)=ehomology_constr
 337 c    Here are the energies showed per procesor if the are more processors
 338 c    per molecule then we sum it up in sum_energy subroutine
 339 c      print *," Processor",myrank," calls SUM_ENERGY"
 340       call sum_energy(energia,.true.)
 341       if (dyn_ss) call dyn_set_nss
 342 c      print *," Processor",myrank," left SUM_ENERGY"
 343 #ifdef TIMING
 344       time_sumene=time_sumene+MPI_Wtime()-time00
 345 #endif
 346       return
 347       end
 348 c-------------------------------------------------------------------------------
 349       subroutine sum_energy(energia,reduce)
 350       implicit real*8 (a-h,o-z)
 351       include 'DIMENSIONS'
 352 #ifndef ISNAN
 353       external proc_proc
 354 #ifdef WINPGI
 355 cMS$ATTRIBUTES C ::  proc_proc
 356 #endif
 357 #endif
 358 #ifdef MPI
 359       include "mpif.h"
 360 #endif
 361       include 'COMMON.SETUP'
 362       include 'COMMON.IOUNITS'
 363       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 364       include 'COMMON.FFIELD'
 365       include 'COMMON.DERIV'
 366       include 'COMMON.INTERACT'
 367       include 'COMMON.SBRIDGE'
 368       include 'COMMON.CHAIN'
 369       include 'COMMON.VAR'
 370       include 'COMMON.CONTROL'
 371       include 'COMMON.TIME1'
 372       logical reduce
 373 #ifdef MPI
 374       if (nfgtasks.gt.1 .and. reduce) then
 375 #ifdef DEBUG
 376         write (iout,*) "energies before REDUCE"
 377         call enerprint(energia)
 378         call flush(iout)
 379 #endif
 380         do i=0,n_ene
 381           enebuff(i)=energia(i)
 382         enddo
 383         time00=MPI_Wtime()
 384         call MPI_Barrier(FG_COMM,IERR)
 385         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 386         time00=MPI_Wtime()
 387         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 388      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 389 #ifdef DEBUG
 390         write (iout,*) "energies after REDUCE"
 391         call enerprint(energia)
 392         call flush(iout)
 393 #endif
 394         time_Reduce=time_Reduce+MPI_Wtime()-time00
 395       endif
 396       if (fg_rank.eq.0) then
 397 #endif
 398       evdw=energia(1)
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428       eliptran=energia(22)
 429       Eafmforce=energia(23)
 430       ehomology_constr=energia(24)
 431 #ifdef SPLITELE
 432       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 433      & +wang*ebe+wtor*etors+wscloc*escloc
 434      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 435      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 436      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 437      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 438      & +wliptran*eliptran+Eafmforce
 439 #else
 440       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 441      & +wang*ebe+wtor*etors+wscloc*escloc
 442      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 443      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 444      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 445      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 446      & +wliptran*eliptran
 447      & +Eafmforce
 448 #endif
 449       energia(0)=etot
 450 c detecting NaNQ
 451 #ifdef ISNAN
 452 #ifdef AIX
 453       if (isnan(etot).ne.0) energia(0)=1.0d+99
 454 #else
 455       if (isnan(etot)) energia(0)=1.0d+99
 456 #endif
 457 #else
 458       i=0
 459 #ifdef WINPGI
 460       idumm=proc_proc(etot,i)
 461 #else
 462       call proc_proc(etot,i)
 463 #endif
 464       if(i.eq.1)energia(0)=1.0d+99
 465 #endif
 466 #ifdef MPI
 467       endif
 468 #endif
 469       return
 470       end
 471 c-------------------------------------------------------------------------------
 472       subroutine sum_gradient
 473       implicit real*8 (a-h,o-z)
 474       include 'DIMENSIONS'
 475 #ifndef ISNAN
 476       external proc_proc
 477 #ifdef WINPGI
 478 cMS$ATTRIBUTES C ::  proc_proc
 479 #endif
 480 #endif
 481 #ifdef MPI
 482       include 'mpif.h'
 483 #endif
 484       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 485      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 486      & ,gloc_scbuf(3,-1:maxres)
 487       include 'COMMON.SETUP'
 488       include 'COMMON.IOUNITS'
 489       include 'COMMON.FFIELD'
 490       include 'COMMON.DERIV'
 491       include 'COMMON.INTERACT'
 492       include 'COMMON.SBRIDGE'
 493       include 'COMMON.CHAIN'
 494       include 'COMMON.VAR'
 495       include 'COMMON.CONTROL'
 496       include 'COMMON.TIME1'
 497       include 'COMMON.MAXGRAD'
 498       include 'COMMON.SCCOR'
 499       include 'COMMON.MD'
 500 #ifdef TIMING
 501       time01=MPI_Wtime()
 502 #endif
 503 #ifdef DEBUG
 504       write (iout,*) "sum_gradient gvdwc, gvdwx"
 505       do i=1,nres
 506         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 507      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 508       enddo
 509       call flush(iout)
 510 #endif
 511 #ifdef MPI
 512 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 513         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 514      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 515 #endif
 516 C
 517 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 518 C            in virtual-bond-vector coordinates
 519 C
 520 #ifdef DEBUG
 521 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 522 c      do i=1,nres-1
 523 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 524 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 525 c      enddo
 526 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 527 c      do i=1,nres-1
 528 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 529 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 530 c      enddo
 531       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 534      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 535      &   g_corr5_loc(i)
 536       enddo
 537       call flush(iout)
 538 #endif
 539 #ifdef SPLITELE
 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)+wvdwpp*gvdwpp(j,i)+
 545      &                wel_loc*gel_loc_long(j,i)+
 546      &                wcorr*gradcorr_long(j,i)+
 547      &                wcorr5*gradcorr5_long(j,i)+
 548      &                wcorr6*gradcorr6_long(j,i)+
 549      &                wturn6*gcorr6_turn_long(j,i)+
 550      &                wstrain*ghpbc(j,i)
 551      &                +wliptran*gliptranc(j,i)
 552      &                +gradafm(j,i)
 553
 554         enddo
 555       enddo
 556 #else
 557       do i=0,nct
 558         do j=1,3
 559           gradbufc(j,i)=wsc*gvdwc(j,i)+
 560      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 561      &                welec*gelc_long(j,i)+
 562      &                wbond*gradb(j,i)+
 563      &                wel_loc*gel_loc_long(j,i)+
 564      &                wcorr*gradcorr_long(j,i)+
 565      &                wcorr5*gradcorr5_long(j,i)+
 566      &                wcorr6*gradcorr6_long(j,i)+
 567      &                wturn6*gcorr6_turn_long(j,i)+
 568      &                wstrain*ghpbc(j,i)
 569      &                +wliptran*gliptranc(j,i)
 570      &                +gradafm(j,i)
 571
 572         enddo
 573       enddo
 574 #endif
 575 #ifdef MPI
 576       if (nfgtasks.gt.1) then
 577       time00=MPI_Wtime()
 578 #ifdef DEBUG
 579       write (iout,*) "gradbufc before allreduce"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 582       enddo
 583       call flush(iout)
 584 #endif
 585       do i=0,nres
 586         do j=1,3
 587           gradbufc_sum(j,i)=gradbufc(j,i)
 588         enddo
 589       enddo
 590 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 591 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 592 c      time_reduce=time_reduce+MPI_Wtime()-time00
 593 #ifdef DEBUG
 594 c      write (iout,*) "gradbufc_sum after allreduce"
 595 c      do i=1,nres
 596 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 597 c      enddo
 598 c      call flush(iout)
 599 #endif
 600 #ifdef TIMING
 601 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 602 #endif
 603       do i=nnt,nres
 604         do k=1,3
 605           gradbufc(k,i)=0.0d0
 606         enddo
 607       enddo
 608 #ifdef DEBUG
 609       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 610       write (iout,*) (i," jgrad_start",jgrad_start(i),
 611      &                  " jgrad_end  ",jgrad_end(i),
 612      &                  i=igrad_start,igrad_end)
 613 #endif
 614 c
 615 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 616 c do not parallelize this part.
 617 c
 618 c      do i=igrad_start,igrad_end
 619 c        do j=jgrad_start(i),jgrad_end(i)
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625       do j=1,3
 626         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 627       enddo
 628       do i=nres-2,-1,-1
 629         do j=1,3
 630           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 631         enddo
 632       enddo
 633 #ifdef DEBUG
 634       write (iout,*) "gradbufc after summing"
 635       do i=1,nres
 636         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640       else
 641 #endif
 642 #ifdef DEBUG
 643       write (iout,*) "gradbufc"
 644       do i=1,nres
 645         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 646       enddo
 647       call flush(iout)
 648 #endif
 649       do i=-1,nres
 650         do j=1,3
 651           gradbufc_sum(j,i)=gradbufc(j,i)
 652           gradbufc(j,i)=0.0d0
 653         enddo
 654       enddo
 655       do j=1,3
 656         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 657       enddo
 658       do i=nres-2,-1,-1
 659         do j=1,3
 660           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 661         enddo
 662       enddo
 663 c      do i=nnt,nres-1
 664 c        do k=1,3
 665 c          gradbufc(k,i)=0.0d0
 666 c        enddo
 667 c        do j=i+1,nres
 668 c          do k=1,3
 669 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 670 c          enddo
 671 c        enddo
 672 c      enddo
 673 #ifdef DEBUG
 674       write (iout,*) "gradbufc after summing"
 675       do i=1,nres
 676         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 677       enddo
 678       call flush(iout)
 679 #endif
 680 #ifdef MPI
 681       endif
 682 #endif
 683       do k=1,3
 684         gradbufc(k,nres)=0.0d0
 685       enddo
 686       do i=-1,nct
 687         do j=1,3
 688 #ifdef SPLITELE
 689           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 690      &                wel_loc*gel_loc(j,i)+
 691      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 692      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 693      &                wel_loc*gel_loc_long(j,i)+
 694      &                wcorr*gradcorr_long(j,i)+
 695      &                wcorr5*gradcorr5_long(j,i)+
 696      &                wcorr6*gradcorr6_long(j,i)+
 697      &                wturn6*gcorr6_turn_long(j,i))+
 698      &                wbond*gradb(j,i)+
 699      &                wcorr*gradcorr(j,i)+
 700      &                wturn3*gcorr3_turn(j,i)+
 701      &                wturn4*gcorr4_turn(j,i)+
 702      &                wcorr5*gradcorr5(j,i)+
 703      &                wcorr6*gradcorr6(j,i)+
 704      &                wturn6*gcorr6_turn(j,i)+
 705      &                wsccor*gsccorc(j,i)
 706      &               +wscloc*gscloc(j,i)
 707      &               +wliptran*gliptranc(j,i)
 708      &                +gradafm(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i) +
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728      &               +wliptran*gliptranc(j,i)
 729      &                +gradafm(j,i)
 730
 731 #endif
 732           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 733      &                  wbond*gradbx(j,i)+
 734      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 735      &                  wsccor*gsccorx(j,i)
 736      &                 +wscloc*gsclocx(j,i)
 737      &                 +wliptran*gliptranx(j,i)
 738         enddo
 739       enddo
 740       if (constr_homology.gt.0) then
 741         do i=1,nct
 742           do j=1,3
 743             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 744             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 745           enddo
 746         enddo
 747       endif
 748 #ifdef DEBUG
 749       write (iout,*) "gloc before adding corr"
 750       do i=1,4*nres
 751         write (iout,*) i,gloc(i,icg)
 752       enddo
 753 #endif
 754       do i=1,nres-3
 755         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 756      &   +wcorr5*g_corr5_loc(i)
 757      &   +wcorr6*g_corr6_loc(i)
 758      &   +wturn4*gel_loc_turn4(i)
 759      &   +wturn3*gel_loc_turn3(i)
 760      &   +wturn6*gel_loc_turn6(i)
 761      &   +wel_loc*gel_loc_loc(i)
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "gloc after adding corr"
 765       do i=1,4*nres
 766         write (iout,*) i,gloc(i,icg)
 767       enddo
 768 #endif
 769 #ifdef MPI
 770       if (nfgtasks.gt.1) then
 771         do j=1,3
 772           do i=1,nres
 773             gradbufc(j,i)=gradc(j,i,icg)
 774             gradbufx(j,i)=gradx(j,i,icg)
 775           enddo
 776         enddo
 777         do i=1,4*nres
 778           glocbuf(i)=gloc(i,icg)
 779         enddo
 780 c#define DEBUG
 781 #ifdef DEBUG
 782       write (iout,*) "gloc_sc before reduce"
 783       do i=1,nres
 784        do j=1,1
 785         write (iout,*) i,j,gloc_sc(j,i,icg)
 786        enddo
 787       enddo
 788 #endif
 789 c#undef DEBUG
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         time_reduce=time_reduce+MPI_Wtime()-time00
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 c#define DEBUG
 810 #ifdef DEBUG
 811       write (iout,*) "gloc_sc after reduce"
 812       do i=1,nres
 813        do j=1,1
 814         write (iout,*) i,j,gloc_sc(j,i,icg)
 815        enddo
 816       enddo
 817 #endif
 818 c#undef DEBUG
 819 #ifdef DEBUG
 820       write (iout,*) "gloc after reduce"
 821       do i=1,4*nres
 822         write (iout,*) i,gloc(i,icg)
 823       enddo
 824 #endif
 825       endif
 826 #endif
 827       if (gnorm_check) then
 828 c
 829 c Compute the maximum elements of the gradient
 830 c
 831       gvdwc_max=0.0d0
 832       gvdwc_scp_max=0.0d0
 833       gelc_max=0.0d0
 834       gvdwpp_max=0.0d0
 835       gradb_max=0.0d0
 836       ghpbc_max=0.0d0
 837       gradcorr_max=0.0d0
 838       gel_loc_max=0.0d0
 839       gcorr3_turn_max=0.0d0
 840       gcorr4_turn_max=0.0d0
 841       gradcorr5_max=0.0d0
 842       gradcorr6_max=0.0d0
 843       gcorr6_turn_max=0.0d0
 844       gsccorc_max=0.0d0
 845       gscloc_max=0.0d0
 846       gvdwx_max=0.0d0
 847       gradx_scp_max=0.0d0
 848       ghpbx_max=0.0d0
 849       gradxorr_max=0.0d0
 850       gsccorx_max=0.0d0
 851       gsclocx_max=0.0d0
 852       do i=1,nct
 853         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 856         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 857      &   gvdwc_scp_max=gvdwc_scp_norm
 858         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 859         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 860         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 861         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 862         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 863         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 864         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 865         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 866         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 867         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 868         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 869         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 870         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 871      &    gcorr3_turn(1,i)))
 872         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 873      &    gcorr3_turn_max=gcorr3_turn_norm
 874         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 875      &    gcorr4_turn(1,i)))
 876         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 877      &    gcorr4_turn_max=gcorr4_turn_norm
 878         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 879         if (gradcorr5_norm.gt.gradcorr5_max)
 880      &    gradcorr5_max=gradcorr5_norm
 881         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 882         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 883         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 884      &    gcorr6_turn(1,i)))
 885         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 886      &    gcorr6_turn_max=gcorr6_turn_norm
 887         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 888         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 889         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 890         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 891         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 892         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 893         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 894         if (gradx_scp_norm.gt.gradx_scp_max)
 895      &    gradx_scp_max=gradx_scp_norm
 896         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 897         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 898         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 899         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 900         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 901         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 902         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 903         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 904       enddo
 905       if (gradout) then
 906 #ifdef AIX
 907         open(istat,file=statname,position="append")
 908 #else
 909         open(istat,file=statname,access="append")
 910 #endif
 911         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 912      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 913      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 914      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 915      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 916      &     gsccorx_max,gsclocx_max
 917         close(istat)
 918         if (gvdwc_max.gt.1.0d4) then
 919           write (iout,*) "gvdwc gvdwx gradb gradbx"
 920           do i=nnt,nct
 921             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 922      &        gradb(j,i),gradbx(j,i),j=1,3)
 923           enddo
 924           call pdbout(0.0d0,'cipiszcze',iout)
 925           call flush(iout)
 926         endif
 927       endif
 928       endif
 929 #ifdef DEBUG
 930       write (iout,*) "gradc gradx gloc"
 931       do i=1,nres
 932         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 933      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 934       enddo
 935 #endif
 936 #ifdef TIMING
 937       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 938 #endif
 939       return
 940       end
 941 c-------------------------------------------------------------------------------
 942       subroutine rescale_weights(t_bath)
 943       implicit real*8 (a-h,o-z)
 944       include 'DIMENSIONS'
 945       include 'COMMON.IOUNITS'
 946       include 'COMMON.FFIELD'
 947       include 'COMMON.SBRIDGE'
 948       double precision kfac /2.4d0/
 949       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 950 c      facT=temp0/t_bath
 951 c      facT=2*temp0/(t_bath+temp0)
 952       if (rescale_mode.eq.0) then
 953         facT=1.0d0
 954         facT2=1.0d0
 955         facT3=1.0d0
 956         facT4=1.0d0
 957         facT5=1.0d0
 958       else if (rescale_mode.eq.1) then
 959         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 960         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 961         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 962         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 963         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 964       else if (rescale_mode.eq.2) then
 965         x=t_bath/temp0
 966         x2=x*x
 967         x3=x2*x
 968         x4=x3*x
 969         x5=x4*x
 970         facT=licznik/dlog(dexp(x)+dexp(-x))
 971         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 972         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 973         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 974         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 975       else
 976         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 977         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 978 #ifdef MPI
 979        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 980 #endif
 981        stop 555
 982       endif
 983       welec=weights(3)*fact
 984       wcorr=weights(4)*fact3
 985       wcorr5=weights(5)*fact4
 986       wcorr6=weights(6)*fact5
 987       wel_loc=weights(7)*fact2
 988       wturn3=weights(8)*fact2
 989       wturn4=weights(9)*fact3
 990       wturn6=weights(10)*fact5
 991       wtor=weights(13)*fact
 992       wtor_d=weights(14)*fact2
 993       wsccor=weights(21)*fact
 994
 995       return
 996       end
 997 C------------------------------------------------------------------------
 998       subroutine enerprint(energia)
 999       implicit real*8 (a-h,o-z)
1000       include 'DIMENSIONS'
1001       include 'COMMON.IOUNITS'
1002       include 'COMMON.FFIELD'
1003       include 'COMMON.SBRIDGE'
1004       include 'COMMON.MD'
1005       double precision energia(0:n_ene)
1006       etot=energia(0)
1007       evdw=energia(1)
1008       evdw2=energia(2)
1009 #ifdef SCP14
1010       evdw2=energia(2)+energia(18)
1011 #else
1012       evdw2=energia(2)
1013 #endif
1014       ees=energia(3)
1015 #ifdef SPLITELE
1016       evdw1=energia(16)
1017 #endif
1018       ecorr=energia(4)
1019       ecorr5=energia(5)
1020       ecorr6=energia(6)
1021       eel_loc=energia(7)
1022       eello_turn3=energia(8)
1023       eello_turn4=energia(9)
1024       eello_turn6=energia(10)
1025       ebe=energia(11)
1026       escloc=energia(12)
1027       etors=energia(13)
1028       etors_d=energia(14)
1029       ehpb=energia(15)
1030       edihcnstr=energia(19)
1031       estr=energia(17)
1032       Uconst=energia(20)
1033       esccor=energia(21)
1034       ehomology_constr=energia(24)
1035       eliptran=energia(22)
1036       Eafmforce=energia(23)
1037 #ifdef SPLITELE
1038       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1039      &  estr,wbond,ebe,wang,
1040      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1041      &  ecorr,wcorr,
1042      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1043      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1044      &  edihcnstr,ehomology_constr, ebr*nss,
1045      &  Uconst,eliptran,wliptran,Eafmforce,etot
1046    10 format (/'Virtual-chain energies:'//
1047      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1048      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1049      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1050      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1051      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1052      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1053      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1054      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1055      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1056      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1057      & ' (SS bridges & dist. cnstr.)'/
1058      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1059      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1060      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1061      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1062      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1063      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1064      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1065      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1066      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1067      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1068      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1069      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1070      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1071      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1072      & 'ETOT=  ',1pE16.6,' (total)')
1073
1074 #else
1075       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1076      &  estr,wbond,ebe,wang,
1077      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1078      &  ecorr,wcorr,
1079      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1080      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1081      &  ehomology_constr,ebr*nss,Uconst,
1082      &  eliptran,wliptran,Eafmforc,
1083      &  etot
1084    10 format (/'Virtual-chain energies:'//
1085      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1086      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1087      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1088      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1089      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1090      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1091      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1092      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1093      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1094      & ' (SS bridges & dist. cnstr.)'/
1095      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1096      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1097      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1098      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1099      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1100      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1101      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1102      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1103      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1104      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1105      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1106      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1107      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1108      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1109      & 'ETOT=  ',1pE16.6,' (total)')
1110 #endif
1111       return
1112       end
1113 C-----------------------------------------------------------------------
1114       subroutine elj(evdw)
1115 C
1116 C This subroutine calculates the interaction energy of nonbonded side chains
1117 C assuming the LJ potential of interaction.
1118 C
1119       implicit real*8 (a-h,o-z)
1120       include 'DIMENSIONS'
1121       parameter (accur=1.0d-10)
1122       include 'COMMON.GEO'
1123       include 'COMMON.VAR'
1124       include 'COMMON.LOCAL'
1125       include 'COMMON.CHAIN'
1126       include 'COMMON.DERIV'
1127       include 'COMMON.INTERACT'
1128       include 'COMMON.TORSION'
1129       include 'COMMON.SBRIDGE'
1130       include 'COMMON.NAMES'
1131       include 'COMMON.IOUNITS'
1132       include 'COMMON.CONTACTS'
1133       dimension gg(3)
1134 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1135       evdw=0.0D0
1136       do i=iatsc_s,iatsc_e
1137         itypi=iabs(itype(i))
1138         if (itypi.eq.ntyp1) cycle
1139         itypi1=iabs(itype(i+1))
1140         xi=c(1,nres+i)
1141         yi=c(2,nres+i)
1142         zi=c(3,nres+i)
1143 C Change 12/1/95
1144         num_conti=0
1145 C
1146 C Calculate SC interaction energy.
1147 C
1148         do iint=1,nint_gr(i)
1149 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1150 cd   &                  'iend=',iend(i,iint)
1151           do j=istart(i,iint),iend(i,iint)
1152             itypj=iabs(itype(j))
1153             if (itypj.eq.ntyp1) cycle
1154             xj=c(1,nres+j)-xi
1155             yj=c(2,nres+j)-yi
1156             zj=c(3,nres+j)-zi
1157 C Change 12/1/95 to calculate four-body interactions
1158             rij=xj*xj+yj*yj+zj*zj
1159             rrij=1.0D0/rij
1160 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1161             eps0ij=eps(itypi,itypj)
1162             fac=rrij**expon2
1163 C have you changed here?
1164             e1=fac*fac*aa
1165             e2=fac*bb
1166             evdwij=e1+e2
1167 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1168 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1169 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1170 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1171 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1172 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1173             evdw=evdw+evdwij
1174 C
1175 C Calculate the components of the gradient in DC and X
1176 C
1177             fac=-rrij*(e1+evdwij)
1178             gg(1)=xj*fac
1179             gg(2)=yj*fac
1180             gg(3)=zj*fac
1181             do k=1,3
1182               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1183               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1184               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1185               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1186             enddo
1187 cgrad            do k=i,j-1
1188 cgrad              do l=1,3
1189 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1190 cgrad              enddo
1191 cgrad            enddo
1192 C
1193 C 12/1/95, revised on 5/20/97
1194 C
1195 C Calculate the contact function. The ith column of the array JCONT will
1196 C contain the numbers of atoms that make contacts with the atom I (of numbers
1197 C greater than I). The arrays FACONT and GACONT will contain the values of
1198 C the contact function and its derivative.
1199 C
1200 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1201 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1202 C Uncomment next line, if the correlation interactions are contact function only
1203             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1204               rij=dsqrt(rij)
1205               sigij=sigma(itypi,itypj)
1206               r0ij=rs0(itypi,itypj)
1207 C
1208 C Check whether the SC's are not too far to make a contact.
1209 C
1210               rcut=1.5d0*r0ij
1211               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1212 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1213 C
1214               if (fcont.gt.0.0D0) then
1215 C If the SC-SC distance if close to sigma, apply spline.
1216 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1217 cAdam &             fcont1,fprimcont1)
1218 cAdam           fcont1=1.0d0-fcont1
1219 cAdam           if (fcont1.gt.0.0d0) then
1220 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1221 cAdam             fcont=fcont*fcont1
1222 cAdam           endif
1223 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1224 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1225 cga             do k=1,3
1226 cga               gg(k)=gg(k)*eps0ij
1227 cga             enddo
1228 cga             eps0ij=-evdwij*eps0ij
1229 C Uncomment for AL's type of SC correlation interactions.
1230 cadam           eps0ij=-evdwij
1231                 num_conti=num_conti+1
1232                 jcont(num_conti,i)=j
1233                 facont(num_conti,i)=fcont*eps0ij
1234                 fprimcont=eps0ij*fprimcont/rij
1235                 fcont=expon*fcont
1236 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1237 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1238 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1239 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1240                 gacont(1,num_conti,i)=-fprimcont*xj
1241                 gacont(2,num_conti,i)=-fprimcont*yj
1242                 gacont(3,num_conti,i)=-fprimcont*zj
1243 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1244 cd              write (iout,'(2i3,3f10.5)')
1245 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1246               endif
1247             endif
1248           enddo      ! j
1249         enddo        ! iint
1250 C Change 12/1/95
1251         num_cont(i)=num_conti
1252       enddo          ! i
1253       do i=1,nct
1254         do j=1,3
1255           gvdwc(j,i)=expon*gvdwc(j,i)
1256           gvdwx(j,i)=expon*gvdwx(j,i)
1257         enddo
1258       enddo
1259 C******************************************************************************
1260 C
1261 C                              N O T E !!!
1262 C
1263 C To save time, the factor of EXPON has been extracted from ALL components
1264 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1265 C use!
1266 C
1267 C******************************************************************************
1268       return
1269       end
1270 C-----------------------------------------------------------------------------
1271       subroutine eljk(evdw)
1272 C
1273 C This subroutine calculates the interaction energy of nonbonded side chains
1274 C assuming the LJK potential of interaction.
1275 C
1276       implicit real*8 (a-h,o-z)
1277       include 'DIMENSIONS'
1278       include 'COMMON.GEO'
1279       include 'COMMON.VAR'
1280       include 'COMMON.LOCAL'
1281       include 'COMMON.CHAIN'
1282       include 'COMMON.DERIV'
1283       include 'COMMON.INTERACT'
1284       include 'COMMON.IOUNITS'
1285       include 'COMMON.NAMES'
1286       dimension gg(3)
1287       logical scheck
1288 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1289       evdw=0.0D0
1290       do i=iatsc_s,iatsc_e
1291         itypi=iabs(itype(i))
1292         if (itypi.eq.ntyp1) cycle
1293         itypi1=iabs(itype(i+1))
1294         xi=c(1,nres+i)
1295         yi=c(2,nres+i)
1296         zi=c(3,nres+i)
1297 C
1298 C Calculate SC interaction energy.
1299 C
1300         do iint=1,nint_gr(i)
1301           do j=istart(i,iint),iend(i,iint)
1302             itypj=iabs(itype(j))
1303             if (itypj.eq.ntyp1) cycle
1304             xj=c(1,nres+j)-xi
1305             yj=c(2,nres+j)-yi
1306             zj=c(3,nres+j)-zi
1307             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1308             fac_augm=rrij**expon
1309             e_augm=augm(itypi,itypj)*fac_augm
1310             r_inv_ij=dsqrt(rrij)
1311             rij=1.0D0/r_inv_ij
1312             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1313             fac=r_shift_inv**expon
1314 C have you changed here?
1315             e1=fac*fac*aa
1316             e2=fac*bb
1317             evdwij=e_augm+e1+e2
1318 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1319 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1320 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1321 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1322 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1323 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1324 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1325             evdw=evdw+evdwij
1326 C
1327 C Calculate the components of the gradient in DC and X
1328 C
1329             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1330             gg(1)=xj*fac
1331             gg(2)=yj*fac
1332             gg(3)=zj*fac
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 cgrad            do k=i,j-1
1340 cgrad              do l=1,3
1341 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1342 cgrad              enddo
1343 cgrad            enddo
1344           enddo      ! j
1345         enddo        ! iint
1346       enddo          ! i
1347       do i=1,nct
1348         do j=1,3
1349           gvdwc(j,i)=expon*gvdwc(j,i)
1350           gvdwx(j,i)=expon*gvdwx(j,i)
1351         enddo
1352       enddo
1353       return
1354       end
1355 C-----------------------------------------------------------------------------
1356       subroutine ebp(evdw)
1357 C
1358 C This subroutine calculates the interaction energy of nonbonded side chains
1359 C assuming the Berne-Pechukas potential of interaction.
1360 C
1361       implicit real*8 (a-h,o-z)
1362       include 'DIMENSIONS'
1363       include 'COMMON.GEO'
1364       include 'COMMON.VAR'
1365       include 'COMMON.LOCAL'
1366       include 'COMMON.CHAIN'
1367       include 'COMMON.DERIV'
1368       include 'COMMON.NAMES'
1369       include 'COMMON.INTERACT'
1370       include 'COMMON.IOUNITS'
1371       include 'COMMON.CALC'
1372       common /srutu/ icall
1373 c     double precision rrsave(maxdim)
1374       logical lprn
1375       evdw=0.0D0
1376 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1377       evdw=0.0D0
1378 c     if (icall.eq.0) then
1379 c       lprn=.true.
1380 c     else
1381         lprn=.false.
1382 c     endif
1383       ind=0
1384       do i=iatsc_s,iatsc_e
1385         itypi=iabs(itype(i))
1386         if (itypi.eq.ntyp1) cycle
1387         itypi1=iabs(itype(i+1))
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=iabs(itype(j))
1403             if (itypj.eq.ntyp1) cycle
1404 c            dscj_inv=dsc_inv(itypj)
1405             dscj_inv=vbld_inv(j+nres)
1406             chi1=chi(itypi,itypj)
1407             chi2=chi(itypj,itypi)
1408             chi12=chi1*chi2
1409             chip1=chip(itypi)
1410             chip2=chip(itypj)
1411             chip12=chip1*chip2
1412             alf1=alp(itypi)
1413             alf2=alp(itypj)
1414             alf12=0.5D0*(alf1+alf2)
1415 C For diagnostics only!!!
1416 c           chi1=0.0D0
1417 c           chi2=0.0D0
1418 c           chi12=0.0D0
1419 c           chip1=0.0D0
1420 c           chip2=0.0D0
1421 c           chip12=0.0D0
1422 c           alf1=0.0D0
1423 c           alf2=0.0D0
1424 c           alf12=0.0D0
1425             xj=c(1,nres+j)-xi
1426             yj=c(2,nres+j)-yi
1427             zj=c(3,nres+j)-zi
1428             dxj=dc_norm(1,nres+j)
1429             dyj=dc_norm(2,nres+j)
1430             dzj=dc_norm(3,nres+j)
1431             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1432 cd          if (icall.eq.0) then
1433 cd            rrsave(ind)=rrij
1434 cd          else
1435 cd            rrij=rrsave(ind)
1436 cd          endif
1437             rij=dsqrt(rrij)
1438 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1439             call sc_angular
1440 C Calculate whole angle-dependent part of epsilon and contributions
1441 C to its derivatives
1442 C have you changed here?
1443             fac=(rrij*sigsq)**expon2
1444             e1=fac*fac*aa
1445             e2=fac*bb
1446             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1447             eps2der=evdwij*eps3rt
1448             eps3der=evdwij*eps2rt
1449             evdwij=evdwij*eps2rt*eps3rt
1450             evdw=evdw+evdwij
1451             if (lprn) then
1452             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1453             epsi=bb**2/aa
1454 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1455 cd     &        restyp(itypi),i,restyp(itypj),j,
1456 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1457 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1458 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1459 cd     &        evdwij
1460             endif
1461 C Calculate gradient components.
1462             e1=e1*eps1*eps2rt**2*eps3rt**2
1463             fac=-expon*(e1+evdwij)
1464             sigder=fac/sigsq
1465             fac=rrij*fac
1466 C Calculate radial part of the gradient
1467             gg(1)=xj*fac
1468             gg(2)=yj*fac
1469             gg(3)=zj*fac
1470 C Calculate the angular part of the gradient and sum add the contributions
1471 C to the appropriate components of the Cartesian gradient.
1472             call sc_grad
1473           enddo      ! j
1474         enddo        ! iint
1475       enddo          ! i
1476 c     stop
1477       return
1478       end
1479 C-----------------------------------------------------------------------------
1480       subroutine egb(evdw)
1481 C
1482 C This subroutine calculates the interaction energy of nonbonded side chains
1483 C assuming the Gay-Berne potential of interaction.
1484 C
1485       implicit real*8 (a-h,o-z)
1486       include 'DIMENSIONS'
1487       include 'COMMON.GEO'
1488       include 'COMMON.VAR'
1489       include 'COMMON.LOCAL'
1490       include 'COMMON.CHAIN'
1491       include 'COMMON.DERIV'
1492       include 'COMMON.NAMES'
1493       include 'COMMON.INTERACT'
1494       include 'COMMON.IOUNITS'
1495       include 'COMMON.CALC'
1496       include 'COMMON.CONTROL'
1497       include 'COMMON.SPLITELE'
1498       include 'COMMON.SBRIDGE'
1499       logical lprn
1500       integer xshift,yshift,zshift
1501       evdw=0.0D0
1502 ccccc      energy_dec=.false.
1503 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1504       evdw=0.0D0
1505       lprn=.false.
1506 c     if (icall.eq.0) lprn=.false.
1507       ind=0
1508 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1509 C we have the original box)
1510 C      do xshift=-1,1
1511 C      do yshift=-1,1
1512 C      do zshift=-1,1
1513       do i=iatsc_s,iatsc_e
1514         itypi=iabs(itype(i))
1515         if (itypi.eq.ntyp1) cycle
1516         itypi1=iabs(itype(i+1))
1517         xi=c(1,nres+i)
1518         yi=c(2,nres+i)
1519         zi=c(3,nres+i)
1520 C Return atom into box, boxxsize is size of box in x dimension
1521 c  134   continue
1522 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1523 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1524 C Condition for being inside the proper box
1525 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1526 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1527 c        go to 134
1528 c        endif
1529 c  135   continue
1530 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1531 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1532 C Condition for being inside the proper box
1533 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1534 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1535 c        go to 135
1536 c        endif
1537 c  136   continue
1538 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1539 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1540 C Condition for being inside the proper box
1541 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1542 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1543 c        go to 136
1544 c        endif
1545           xi=mod(xi,boxxsize)
1546           if (xi.lt.0) xi=xi+boxxsize
1547           yi=mod(yi,boxysize)
1548           if (yi.lt.0) yi=yi+boxysize
1549           zi=mod(zi,boxzsize)
1550           if (zi.lt.0) zi=zi+boxzsize
1551 C define scaling factor for lipids
1552
1553 C        if (positi.le.0) positi=positi+boxzsize
1554 C        print *,i
1555 C first for peptide groups
1556 c for each residue check if it is in lipid or lipid water border area
1557        if ((zi.gt.bordlipbot)
1558      &.and.(zi.lt.bordliptop)) then
1559 C the energy transfer exist
1560         if (zi.lt.buflipbot) then
1561 C what fraction I am in
1562          fracinbuf=1.0d0-
1563      &        ((zi-bordlipbot)/lipbufthick)
1564 C lipbufthick is thickenes of lipid buffore
1565          sslipi=sscalelip(fracinbuf)
1566          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1567         elseif (zi.gt.bufliptop) then
1568          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1569          sslipi=sscalelip(fracinbuf)
1570          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1571         else
1572          sslipi=1.0d0
1573          ssgradlipi=0.0
1574         endif
1575        else
1576          sslipi=0.0d0
1577          ssgradlipi=0.0
1578        endif
1579
1580 C          xi=xi+xshift*boxxsize
1581 C          yi=yi+yshift*boxysize
1582 C          zi=zi+zshift*boxzsize
1583
1584         dxi=dc_norm(1,nres+i)
1585         dyi=dc_norm(2,nres+i)
1586         dzi=dc_norm(3,nres+i)
1587 c        dsci_inv=dsc_inv(itypi)
1588         dsci_inv=vbld_inv(i+nres)
1589 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1590 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1591 C
1592 C Calculate SC interaction energy.
1593 C
1594         do iint=1,nint_gr(i)
1595           do j=istart(i,iint),iend(i,iint)
1596             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1597               call dyn_ssbond_ene(i,j,evdwij)
1598               evdw=evdw+evdwij
1599               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1600      &                        'evdw',i,j,evdwij,' ss'
1601             ELSE
1602             ind=ind+1
1603             itypj=iabs(itype(j))
1604             if (itypj.eq.ntyp1) cycle
1605 c            dscj_inv=dsc_inv(itypj)
1606             dscj_inv=vbld_inv(j+nres)
1607 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1608 c     &       1.0d0/vbld(j+nres)
1609 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1610             sig0ij=sigma(itypi,itypj)
1611             chi1=chi(itypi,itypj)
1612             chi2=chi(itypj,itypi)
1613             chi12=chi1*chi2
1614             chip1=chip(itypi)
1615             chip2=chip(itypj)
1616             chip12=chip1*chip2
1617             alf1=alp(itypi)
1618             alf2=alp(itypj)
1619             alf12=0.5D0*(alf1+alf2)
1620 C For diagnostics only!!!
1621 c           chi1=0.0D0
1622 c           chi2=0.0D0
1623 c           chi12=0.0D0
1624 c           chip1=0.0D0
1625 c           chip2=0.0D0
1626 c           chip12=0.0D0
1627 c           alf1=0.0D0
1628 c           alf2=0.0D0
1629 c           alf12=0.0D0
1630             xj=c(1,nres+j)
1631             yj=c(2,nres+j)
1632             zj=c(3,nres+j)
1633 C Return atom J into box the original box
1634 c  137   continue
1635 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1636 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1637 C Condition for being inside the proper box
1638 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1639 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1640 c        go to 137
1641 c        endif
1642 c  138   continue
1643 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1644 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1645 C Condition for being inside the proper box
1646 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1647 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1648 c        go to 138
1649 c        endif
1650 c  139   continue
1651 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1652 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1653 C Condition for being inside the proper box
1654 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1655 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1656 c        go to 139
1657 c        endif
1658           xj=mod(xj,boxxsize)
1659           if (xj.lt.0) xj=xj+boxxsize
1660           yj=mod(yj,boxysize)
1661           if (yj.lt.0) yj=yj+boxysize
1662           zj=mod(zj,boxzsize)
1663           if (zj.lt.0) zj=zj+boxzsize
1664        if ((zj.gt.bordlipbot)
1665      &.and.(zj.lt.bordliptop)) then
1666 C the energy transfer exist
1667         if (zj.lt.buflipbot) then
1668 C what fraction I am in
1669          fracinbuf=1.0d0-
1670      &        ((zj-bordlipbot)/lipbufthick)
1671 C lipbufthick is thickenes of lipid buffore
1672          sslipj=sscalelip(fracinbuf)
1673          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1674         elseif (zj.gt.bufliptop) then
1675          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1676          sslipj=sscalelip(fracinbuf)
1677          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1678         else
1679          sslipj=1.0d0
1680          ssgradlipj=0.0
1681         endif
1682        else
1683          sslipj=0.0d0
1684          ssgradlipj=0.0
1685        endif
1686       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1687      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1688       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1689      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1690 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1691 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1692 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1693 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1694       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1695       xj_safe=xj
1696       yj_safe=yj
1697       zj_safe=zj
1698       subchap=0
1699       do xshift=-1,1
1700       do yshift=-1,1
1701       do zshift=-1,1
1702           xj=xj_safe+xshift*boxxsize
1703           yj=yj_safe+yshift*boxysize
1704           zj=zj_safe+zshift*boxzsize
1705           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1706           if(dist_temp.lt.dist_init) then
1707             dist_init=dist_temp
1708             xj_temp=xj
1709             yj_temp=yj
1710             zj_temp=zj
1711             subchap=1
1712           endif
1713        enddo
1714        enddo
1715        enddo
1716        if (subchap.eq.1) then
1717           xj=xj_temp-xi
1718           yj=yj_temp-yi
1719           zj=zj_temp-zi
1720        else
1721           xj=xj_safe-xi
1722           yj=yj_safe-yi
1723           zj=zj_safe-zi
1724        endif
1725             dxj=dc_norm(1,nres+j)
1726             dyj=dc_norm(2,nres+j)
1727             dzj=dc_norm(3,nres+j)
1728 C            xj=xj-xi
1729 C            yj=yj-yi
1730 C            zj=zj-zi
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1737             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1738
1739 c            write (iout,'(a7,4f8.3)')
1740 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1741             if (sss.gt.0.0d0) then
1742 C Calculate angle-dependent terms of energy and contributions to their
1743 C derivatives.
1744             call sc_angular
1745             sigsq=1.0D0/sigsq
1746             sig=sig0ij*dsqrt(sigsq)
1747             rij_shift=1.0D0/rij-sig+sig0ij
1748 c for diagnostics; uncomment
1749 c            rij_shift=1.2*sig0ij
1750 C I hate to put IF's in the loops, but here don't have another choice!!!!
1751             if (rij_shift.le.0.0D0) then
1752               evdw=1.0D20
1753 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1754 cd     &        restyp(itypi),i,restyp(itypj),j,
1755 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1756               return
1757             endif
1758             sigder=-sig*sigsq
1759 c---------------------------------------------------------------
1760             rij_shift=1.0D0/rij_shift
1761             fac=rij_shift**expon
1762 C here to start with
1763 C            if (c(i,3).gt.
1764             faclip=fac
1765             e1=fac*fac*aa
1766             e2=fac*bb
1767             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1768             eps2der=evdwij*eps3rt
1769             eps3der=evdwij*eps2rt
1770 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1771 C     &((sslipi+sslipj)/2.0d0+
1772 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1773 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1774 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1775             evdwij=evdwij*eps2rt*eps3rt
1776             evdw=evdw+evdwij*sss
1777             if (lprn) then
1778             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1779             epsi=bb**2/aa
1780             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1781      &        restyp(itypi),i,restyp(itypj),j,
1782      &        epsi,sigm,chi1,chi2,chip1,chip2,
1783      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1784      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1785      &        evdwij
1786             endif
1787
1788             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1789      &                        'evdw',i,j,evdwij
1790
1791 C Calculate gradient components.
1792             e1=e1*eps1*eps2rt**2*eps3rt**2
1793             fac=-expon*(e1+evdwij)*rij_shift
1794             sigder=fac*sigder
1795             fac=rij*fac
1796 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1797 c     &      evdwij,fac,sigma(itypi,itypj),expon
1798             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1799 c            fac=0.0d0
1800 C Calculate the radial part of the gradient
1801             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1802      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1803      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1804      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1805             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1806             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1807 C            gg_lipi(3)=0.0d0
1808 C            gg_lipj(3)=0.0d0
1809             gg(1)=xj*fac
1810             gg(2)=yj*fac
1811             gg(3)=zj*fac
1812 C Calculate angular part of the gradient.
1813             call sc_grad
1814             endif
1815             ENDIF    ! dyn_ss
1816           enddo      ! j
1817         enddo        ! iint
1818       enddo          ! i
1819 C      enddo          ! zshift
1820 C      enddo          ! yshift
1821 C      enddo          ! xshift
1822 c      write (iout,*) "Number of loop steps in EGB:",ind
1823 cccc      energy_dec=.false.
1824       return
1825       end
1826 C-----------------------------------------------------------------------------
1827       subroutine egbv(evdw)
1828 C
1829 C This subroutine calculates the interaction energy of nonbonded side chains
1830 C assuming the Gay-Berne-Vorobjev potential of interaction.
1831 C
1832       implicit real*8 (a-h,o-z)
1833       include 'DIMENSIONS'
1834       include 'COMMON.GEO'
1835       include 'COMMON.VAR'
1836       include 'COMMON.LOCAL'
1837       include 'COMMON.CHAIN'
1838       include 'COMMON.DERIV'
1839       include 'COMMON.NAMES'
1840       include 'COMMON.INTERACT'
1841       include 'COMMON.IOUNITS'
1842       include 'COMMON.CALC'
1843       common /srutu/ icall
1844       logical lprn
1845       evdw=0.0D0
1846 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1847       evdw=0.0D0
1848       lprn=.false.
1849 c     if (icall.eq.0) lprn=.true.
1850       ind=0
1851       do i=iatsc_s,iatsc_e
1852         itypi=iabs(itype(i))
1853         if (itypi.eq.ntyp1) cycle
1854         itypi1=iabs(itype(i+1))
1855         xi=c(1,nres+i)
1856         yi=c(2,nres+i)
1857         zi=c(3,nres+i)
1858           xi=mod(xi,boxxsize)
1859           if (xi.lt.0) xi=xi+boxxsize
1860           yi=mod(yi,boxysize)
1861           if (yi.lt.0) yi=yi+boxysize
1862           zi=mod(zi,boxzsize)
1863           if (zi.lt.0) zi=zi+boxzsize
1864 C define scaling factor for lipids
1865
1866 C        if (positi.le.0) positi=positi+boxzsize
1867 C        print *,i
1868 C first for peptide groups
1869 c for each residue check if it is in lipid or lipid water border area
1870        if ((zi.gt.bordlipbot)
1871      &.and.(zi.lt.bordliptop)) then
1872 C the energy transfer exist
1873         if (zi.lt.buflipbot) then
1874 C what fraction I am in
1875          fracinbuf=1.0d0-
1876      &        ((zi-bordlipbot)/lipbufthick)
1877 C lipbufthick is thickenes of lipid buffore
1878          sslipi=sscalelip(fracinbuf)
1879          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1880         elseif (zi.gt.bufliptop) then
1881          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1882          sslipi=sscalelip(fracinbuf)
1883          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1884         else
1885          sslipi=1.0d0
1886          ssgradlipi=0.0
1887         endif
1888        else
1889          sslipi=0.0d0
1890          ssgradlipi=0.0
1891        endif
1892
1893         dxi=dc_norm(1,nres+i)
1894         dyi=dc_norm(2,nres+i)
1895         dzi=dc_norm(3,nres+i)
1896 c        dsci_inv=dsc_inv(itypi)
1897         dsci_inv=vbld_inv(i+nres)
1898 C
1899 C Calculate SC interaction energy.
1900 C
1901         do iint=1,nint_gr(i)
1902           do j=istart(i,iint),iend(i,iint)
1903             ind=ind+1
1904             itypj=iabs(itype(j))
1905             if (itypj.eq.ntyp1) cycle
1906 c            dscj_inv=dsc_inv(itypj)
1907             dscj_inv=vbld_inv(j+nres)
1908             sig0ij=sigma(itypi,itypj)
1909             r0ij=r0(itypi,itypj)
1910             chi1=chi(itypi,itypj)
1911             chi2=chi(itypj,itypi)
1912             chi12=chi1*chi2
1913             chip1=chip(itypi)
1914             chip2=chip(itypj)
1915             chip12=chip1*chip2
1916             alf1=alp(itypi)
1917             alf2=alp(itypj)
1918             alf12=0.5D0*(alf1+alf2)
1919 C For diagnostics only!!!
1920 c           chi1=0.0D0
1921 c           chi2=0.0D0
1922 c           chi12=0.0D0
1923 c           chip1=0.0D0
1924 c           chip2=0.0D0
1925 c           chip12=0.0D0
1926 c           alf1=0.0D0
1927 c           alf2=0.0D0
1928 c           alf12=0.0D0
1929 C            xj=c(1,nres+j)-xi
1930 C            yj=c(2,nres+j)-yi
1931 C            zj=c(3,nres+j)-zi
1932           xj=mod(xj,boxxsize)
1933           if (xj.lt.0) xj=xj+boxxsize
1934           yj=mod(yj,boxysize)
1935           if (yj.lt.0) yj=yj+boxysize
1936           zj=mod(zj,boxzsize)
1937           if (zj.lt.0) zj=zj+boxzsize
1938        if ((zj.gt.bordlipbot)
1939      &.and.(zj.lt.bordliptop)) then
1940 C the energy transfer exist
1941         if (zj.lt.buflipbot) then
1942 C what fraction I am in
1943          fracinbuf=1.0d0-
1944      &        ((zj-bordlipbot)/lipbufthick)
1945 C lipbufthick is thickenes of lipid buffore
1946          sslipj=sscalelip(fracinbuf)
1947          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1948         elseif (zj.gt.bufliptop) then
1949          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1950          sslipj=sscalelip(fracinbuf)
1951          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1952         else
1953          sslipj=1.0d0
1954          ssgradlipj=0.0
1955         endif
1956        else
1957          sslipj=0.0d0
1958          ssgradlipj=0.0
1959        endif
1960       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1961      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1962       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1963      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1964 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1965 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1966       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1967       xj_safe=xj
1968       yj_safe=yj
1969       zj_safe=zj
1970       subchap=0
1971       do xshift=-1,1
1972       do yshift=-1,1
1973       do zshift=-1,1
1974           xj=xj_safe+xshift*boxxsize
1975           yj=yj_safe+yshift*boxysize
1976           zj=zj_safe+zshift*boxzsize
1977           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1978           if(dist_temp.lt.dist_init) then
1979             dist_init=dist_temp
1980             xj_temp=xj
1981             yj_temp=yj
1982             zj_temp=zj
1983             subchap=1
1984           endif
1985        enddo
1986        enddo
1987        enddo
1988        if (subchap.eq.1) then
1989           xj=xj_temp-xi
1990           yj=yj_temp-yi
1991           zj=zj_temp-zi
1992        else
1993           xj=xj_safe-xi
1994           yj=yj_safe-yi
1995           zj=zj_safe-zi
1996        endif
1997             dxj=dc_norm(1,nres+j)
1998             dyj=dc_norm(2,nres+j)
1999             dzj=dc_norm(3,nres+j)
2000             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2001             rij=dsqrt(rrij)
2002 C Calculate angle-dependent terms of energy and contributions to their
2003 C derivatives.
2004             call sc_angular
2005             sigsq=1.0D0/sigsq
2006             sig=sig0ij*dsqrt(sigsq)
2007             rij_shift=1.0D0/rij-sig+r0ij
2008 C I hate to put IF's in the loops, but here don't have another choice!!!!
2009             if (rij_shift.le.0.0D0) then
2010               evdw=1.0D20
2011               return
2012             endif
2013             sigder=-sig*sigsq
2014 c---------------------------------------------------------------
2015             rij_shift=1.0D0/rij_shift
2016             fac=rij_shift**expon
2017             e1=fac*fac*aa
2018             e2=fac*bb
2019             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020             eps2der=evdwij*eps3rt
2021             eps3der=evdwij*eps2rt
2022             fac_augm=rrij**expon
2023             e_augm=augm(itypi,itypj)*fac_augm
2024             evdwij=evdwij*eps2rt*eps3rt
2025             evdw=evdw+evdwij+e_augm
2026             if (lprn) then
2027             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2028             epsi=bb**2/aa
2029             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2030      &        restyp(itypi),i,restyp(itypj),j,
2031      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2032      &        chi1,chi2,chip1,chip2,
2033      &        eps1,eps2rt**2,eps3rt**2,
2034      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2035      &        evdwij+e_augm
2036             endif
2037 C Calculate gradient components.
2038             e1=e1*eps1*eps2rt**2*eps3rt**2
2039             fac=-expon*(e1+evdwij)*rij_shift
2040             sigder=fac*sigder
2041             fac=rij*fac-2*expon*rrij*e_augm
2042             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2043 C Calculate the radial part of the gradient
2044             gg(1)=xj*fac
2045             gg(2)=yj*fac
2046             gg(3)=zj*fac
2047 C Calculate angular part of the gradient.
2048             call sc_grad
2049           enddo      ! j
2050         enddo        ! iint
2051       enddo          ! i
2052       end
2053 C-----------------------------------------------------------------------------
2054       subroutine sc_angular
2055 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2056 C om12. Called by ebp, egb, and egbv.
2057       implicit none
2058       include 'COMMON.CALC'
2059       include 'COMMON.IOUNITS'
2060       erij(1)=xj*rij
2061       erij(2)=yj*rij
2062       erij(3)=zj*rij
2063       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2064       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2065       om12=dxi*dxj+dyi*dyj+dzi*dzj
2066       chiom12=chi12*om12
2067 C Calculate eps1(om12) and its derivative in om12
2068       faceps1=1.0D0-om12*chiom12
2069       faceps1_inv=1.0D0/faceps1
2070       eps1=dsqrt(faceps1_inv)
2071 C Following variable is eps1*deps1/dom12
2072       eps1_om12=faceps1_inv*chiom12
2073 c diagnostics only
2074 c      faceps1_inv=om12
2075 c      eps1=om12
2076 c      eps1_om12=1.0d0
2077 c      write (iout,*) "om12",om12," eps1",eps1
2078 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2079 C and om12.
2080       om1om2=om1*om2
2081       chiom1=chi1*om1
2082       chiom2=chi2*om2
2083       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2084       sigsq=1.0D0-facsig*faceps1_inv
2085       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2086       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2087       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2088 c diagnostics only
2089 c      sigsq=1.0d0
2090 c      sigsq_om1=0.0d0
2091 c      sigsq_om2=0.0d0
2092 c      sigsq_om12=0.0d0
2093 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2094 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2095 c     &    " eps1",eps1
2096 C Calculate eps2 and its derivatives in om1, om2, and om12.
2097       chipom1=chip1*om1
2098       chipom2=chip2*om2
2099       chipom12=chip12*om12
2100       facp=1.0D0-om12*chipom12
2101       facp_inv=1.0D0/facp
2102       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2103 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2104 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2105 C Following variable is the square root of eps2
2106       eps2rt=1.0D0-facp1*facp_inv
2107 C Following three variables are the derivatives of the square root of eps
2108 C in om1, om2, and om12.
2109       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2110       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2111       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2112 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2113       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2114 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2115 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2116 c     &  " eps2rt_om12",eps2rt_om12
2117 C Calculate whole angle-dependent part of epsilon and contributions
2118 C to its derivatives
2119       return
2120       end
2121 C----------------------------------------------------------------------------
2122       subroutine sc_grad
2123       implicit real*8 (a-h,o-z)
2124       include 'DIMENSIONS'
2125       include 'COMMON.CHAIN'
2126       include 'COMMON.DERIV'
2127       include 'COMMON.CALC'
2128       include 'COMMON.IOUNITS'
2129       double precision dcosom1(3),dcosom2(3)
2130 cc      print *,'sss=',sss
2131       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2132       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2133       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2134      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2135 c diagnostics only
2136 c      eom1=0.0d0
2137 c      eom2=0.0d0
2138 c      eom12=evdwij*eps1_om12
2139 c end diagnostics
2140 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2141 c     &  " sigder",sigder
2142 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2143 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2144       do k=1,3
2145         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2146         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2147       enddo
2148       do k=1,3
2149         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2150       enddo
2151 c      write (iout,*) "gg",(gg(k),k=1,3)
2152       do k=1,3
2153         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2154      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2155      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2156         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2157      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2158      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2159 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2160 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2161 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2162 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2163       enddo
2164 C
2165 C Calculate the components of the gradient in DC and X
2166 C
2167 cgrad      do k=i,j-1
2168 cgrad        do l=1,3
2169 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2170 cgrad        enddo
2171 cgrad      enddo
2172       do l=1,3
2173         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2174         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2175       enddo
2176       return
2177       end
2178 C-----------------------------------------------------------------------
2179       subroutine e_softsphere(evdw)
2180 C
2181 C This subroutine calculates the interaction energy of nonbonded side chains
2182 C assuming the LJ potential of interaction.
2183 C
2184       implicit real*8 (a-h,o-z)
2185       include 'DIMENSIONS'
2186       parameter (accur=1.0d-10)
2187       include 'COMMON.GEO'
2188       include 'COMMON.VAR'
2189       include 'COMMON.LOCAL'
2190       include 'COMMON.CHAIN'
2191       include 'COMMON.DERIV'
2192       include 'COMMON.INTERACT'
2193       include 'COMMON.TORSION'
2194       include 'COMMON.SBRIDGE'
2195       include 'COMMON.NAMES'
2196       include 'COMMON.IOUNITS'
2197       include 'COMMON.CONTACTS'
2198       dimension gg(3)
2199 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2200       evdw=0.0D0
2201       do i=iatsc_s,iatsc_e
2202         itypi=iabs(itype(i))
2203         if (itypi.eq.ntyp1) cycle
2204         itypi1=iabs(itype(i+1))
2205         xi=c(1,nres+i)
2206         yi=c(2,nres+i)
2207         zi=c(3,nres+i)
2208 C
2209 C Calculate SC interaction energy.
2210 C
2211         do iint=1,nint_gr(i)
2212 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2213 cd   &                  'iend=',iend(i,iint)
2214           do j=istart(i,iint),iend(i,iint)
2215             itypj=iabs(itype(j))
2216             if (itypj.eq.ntyp1) cycle
2217             xj=c(1,nres+j)-xi
2218             yj=c(2,nres+j)-yi
2219             zj=c(3,nres+j)-zi
2220             rij=xj*xj+yj*yj+zj*zj
2221 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2222             r0ij=r0(itypi,itypj)
2223             r0ijsq=r0ij*r0ij
2224 c            print *,i,j,r0ij,dsqrt(rij)
2225             if (rij.lt.r0ijsq) then
2226               evdwij=0.25d0*(rij-r0ijsq)**2
2227               fac=rij-r0ijsq
2228             else
2229               evdwij=0.0d0
2230               fac=0.0d0
2231             endif
2232             evdw=evdw+evdwij
2233 C
2234 C Calculate the components of the gradient in DC and X
2235 C
2236             gg(1)=xj*fac
2237             gg(2)=yj*fac
2238             gg(3)=zj*fac
2239             do k=1,3
2240               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2241               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2242               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2243               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2244             enddo
2245 cgrad            do k=i,j-1
2246 cgrad              do l=1,3
2247 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2248 cgrad              enddo
2249 cgrad            enddo
2250           enddo ! j
2251         enddo ! iint
2252       enddo ! i
2253       return
2254       end
2255 C--------------------------------------------------------------------------
2256       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2257      &              eello_turn4)
2258 C
2259 C Soft-sphere potential of p-p interaction
2260 C
2261       implicit real*8 (a-h,o-z)
2262       include 'DIMENSIONS'
2263       include 'COMMON.CONTROL'
2264       include 'COMMON.IOUNITS'
2265       include 'COMMON.GEO'
2266       include 'COMMON.VAR'
2267       include 'COMMON.LOCAL'
2268       include 'COMMON.CHAIN'
2269       include 'COMMON.DERIV'
2270       include 'COMMON.INTERACT'
2271       include 'COMMON.CONTACTS'
2272       include 'COMMON.TORSION'
2273       include 'COMMON.VECTORS'
2274       include 'COMMON.FFIELD'
2275       dimension ggg(3)
2276 C      write(iout,*) 'In EELEC_soft_sphere'
2277       ees=0.0D0
2278       evdw1=0.0D0
2279       eel_loc=0.0d0
2280       eello_turn3=0.0d0
2281       eello_turn4=0.0d0
2282       ind=0
2283       do i=iatel_s,iatel_e
2284         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2285         dxi=dc(1,i)
2286         dyi=dc(2,i)
2287         dzi=dc(3,i)
2288         xmedi=c(1,i)+0.5d0*dxi
2289         ymedi=c(2,i)+0.5d0*dyi
2290         zmedi=c(3,i)+0.5d0*dzi
2291           xmedi=mod(xmedi,boxxsize)
2292           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2293           ymedi=mod(ymedi,boxysize)
2294           if (ymedi.lt.0) ymedi=ymedi+boxysize
2295           zmedi=mod(zmedi,boxzsize)
2296           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2297         num_conti=0
2298 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2299         do j=ielstart(i),ielend(i)
2300           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2301           ind=ind+1
2302           iteli=itel(i)
2303           itelj=itel(j)
2304           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2305           r0ij=rpp(iteli,itelj)
2306           r0ijsq=r0ij*r0ij
2307           dxj=dc(1,j)
2308           dyj=dc(2,j)
2309           dzj=dc(3,j)
2310           xj=c(1,j)+0.5D0*dxj
2311           yj=c(2,j)+0.5D0*dyj
2312           zj=c(3,j)+0.5D0*dzj
2313           xj=mod(xj,boxxsize)
2314           if (xj.lt.0) xj=xj+boxxsize
2315           yj=mod(yj,boxysize)
2316           if (yj.lt.0) yj=yj+boxysize
2317           zj=mod(zj,boxzsize)
2318           if (zj.lt.0) zj=zj+boxzsize
2319       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2320       xj_safe=xj
2321       yj_safe=yj
2322       zj_safe=zj
2323       isubchap=0
2324       do xshift=-1,1
2325       do yshift=-1,1
2326       do zshift=-1,1
2327           xj=xj_safe+xshift*boxxsize
2328           yj=yj_safe+yshift*boxysize
2329           zj=zj_safe+zshift*boxzsize
2330           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2331           if(dist_temp.lt.dist_init) then
2332             dist_init=dist_temp
2333             xj_temp=xj
2334             yj_temp=yj
2335             zj_temp=zj
2336             isubchap=1
2337           endif
2338        enddo
2339        enddo
2340        enddo
2341        if (isubchap.eq.1) then
2342           xj=xj_temp-xmedi
2343           yj=yj_temp-ymedi
2344           zj=zj_temp-zmedi
2345        else
2346           xj=xj_safe-xmedi
2347           yj=yj_safe-ymedi
2348           zj=zj_safe-zmedi
2349        endif
2350           rij=xj*xj+yj*yj+zj*zj
2351             sss=sscale(sqrt(rij))
2352             sssgrad=sscagrad(sqrt(rij))
2353           if (rij.lt.r0ijsq) then
2354             evdw1ij=0.25d0*(rij-r0ijsq)**2
2355             fac=rij-r0ijsq
2356           else
2357             evdw1ij=0.0d0
2358             fac=0.0d0
2359           endif
2360           evdw1=evdw1+evdw1ij*sss
2361 C
2362 C Calculate contributions to the Cartesian gradient.
2363 C
2364           ggg(1)=fac*xj*sssgrad
2365           ggg(2)=fac*yj*sssgrad
2366           ggg(3)=fac*zj*sssgrad
2367           do k=1,3
2368             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2369             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2370           enddo
2371 *
2372 * Loop over residues i+1 thru j-1.
2373 *
2374 cgrad          do k=i+1,j-1
2375 cgrad            do l=1,3
2376 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2377 cgrad            enddo
2378 cgrad          enddo
2379         enddo ! j
2380       enddo   ! i
2381 cgrad      do i=nnt,nct-1
2382 cgrad        do k=1,3
2383 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2384 cgrad        enddo
2385 cgrad        do j=i+1,nct-1
2386 cgrad          do k=1,3
2387 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2388 cgrad          enddo
2389 cgrad        enddo
2390 cgrad      enddo
2391       return
2392       end
2393 c------------------------------------------------------------------------------
2394       subroutine vec_and_deriv
2395       implicit real*8 (a-h,o-z)
2396       include 'DIMENSIONS'
2397 #ifdef MPI
2398       include 'mpif.h'
2399 #endif
2400       include 'COMMON.IOUNITS'
2401       include 'COMMON.GEO'
2402       include 'COMMON.VAR'
2403       include 'COMMON.LOCAL'
2404       include 'COMMON.CHAIN'
2405       include 'COMMON.VECTORS'
2406       include 'COMMON.SETUP'
2407       include 'COMMON.TIME1'
2408       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2409 C Compute the local reference systems. For reference system (i), the
2410 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2411 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2412 #ifdef PARVEC
2413       do i=ivec_start,ivec_end
2414 #else
2415       do i=1,nres-1
2416 #endif
2417           if (i.eq.nres-1) then
2418 C Case of the last full residue
2419 C Compute the Z-axis
2420             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2421             costh=dcos(pi-theta(nres))
2422             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2423             do k=1,3
2424               uz(k,i)=fac*uz(k,i)
2425             enddo
2426 C Compute the derivatives of uz
2427             uzder(1,1,1)= 0.0d0
2428             uzder(2,1,1)=-dc_norm(3,i-1)
2429             uzder(3,1,1)= dc_norm(2,i-1)
2430             uzder(1,2,1)= dc_norm(3,i-1)
2431             uzder(2,2,1)= 0.0d0
2432             uzder(3,2,1)=-dc_norm(1,i-1)
2433             uzder(1,3,1)=-dc_norm(2,i-1)
2434             uzder(2,3,1)= dc_norm(1,i-1)
2435             uzder(3,3,1)= 0.0d0
2436             uzder(1,1,2)= 0.0d0
2437             uzder(2,1,2)= dc_norm(3,i)
2438             uzder(3,1,2)=-dc_norm(2,i)
2439             uzder(1,2,2)=-dc_norm(3,i)
2440             uzder(2,2,2)= 0.0d0
2441             uzder(3,2,2)= dc_norm(1,i)
2442             uzder(1,3,2)= dc_norm(2,i)
2443             uzder(2,3,2)=-dc_norm(1,i)
2444             uzder(3,3,2)= 0.0d0
2445 C Compute the Y-axis
2446             facy=fac
2447             do k=1,3
2448               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2449             enddo
2450 C Compute the derivatives of uy
2451             do j=1,3
2452               do k=1,3
2453                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2454      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2455                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2456               enddo
2457               uyder(j,j,1)=uyder(j,j,1)-costh
2458               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2459             enddo
2460             do j=1,2
2461               do k=1,3
2462                 do l=1,3
2463                   uygrad(l,k,j,i)=uyder(l,k,j)
2464                   uzgrad(l,k,j,i)=uzder(l,k,j)
2465                 enddo
2466               enddo
2467             enddo
2468             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2469             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2470             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2471             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2472           else
2473 C Other residues
2474 C Compute the Z-axis
2475             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2476             costh=dcos(pi-theta(i+2))
2477             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2478             do k=1,3
2479               uz(k,i)=fac*uz(k,i)
2480             enddo
2481 C Compute the derivatives of uz
2482             uzder(1,1,1)= 0.0d0
2483             uzder(2,1,1)=-dc_norm(3,i+1)
2484             uzder(3,1,1)= dc_norm(2,i+1)
2485             uzder(1,2,1)= dc_norm(3,i+1)
2486             uzder(2,2,1)= 0.0d0
2487             uzder(3,2,1)=-dc_norm(1,i+1)
2488             uzder(1,3,1)=-dc_norm(2,i+1)
2489             uzder(2,3,1)= dc_norm(1,i+1)
2490             uzder(3,3,1)= 0.0d0
2491             uzder(1,1,2)= 0.0d0
2492             uzder(2,1,2)= dc_norm(3,i)
2493             uzder(3,1,2)=-dc_norm(2,i)
2494             uzder(1,2,2)=-dc_norm(3,i)
2495             uzder(2,2,2)= 0.0d0
2496             uzder(3,2,2)= dc_norm(1,i)
2497             uzder(1,3,2)= dc_norm(2,i)
2498             uzder(2,3,2)=-dc_norm(1,i)
2499             uzder(3,3,2)= 0.0d0
2500 C Compute the Y-axis
2501             facy=fac
2502             do k=1,3
2503               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2504             enddo
2505 C Compute the derivatives of uy
2506             do j=1,3
2507               do k=1,3
2508                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2509      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2510                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2511               enddo
2512               uyder(j,j,1)=uyder(j,j,1)-costh
2513               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2514             enddo
2515             do j=1,2
2516               do k=1,3
2517                 do l=1,3
2518                   uygrad(l,k,j,i)=uyder(l,k,j)
2519                   uzgrad(l,k,j,i)=uzder(l,k,j)
2520                 enddo
2521               enddo
2522             enddo
2523             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2524             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2525             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2526             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2527           endif
2528       enddo
2529       do i=1,nres-1
2530         vbld_inv_temp(1)=vbld_inv(i+1)
2531         if (i.lt.nres-1) then
2532           vbld_inv_temp(2)=vbld_inv(i+2)
2533           else
2534           vbld_inv_temp(2)=vbld_inv(i)
2535           endif
2536         do j=1,2
2537           do k=1,3
2538             do l=1,3
2539               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2540               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2541             enddo
2542           enddo
2543         enddo
2544       enddo
2545 #if defined(PARVEC) && defined(MPI)
2546       if (nfgtasks1.gt.1) then
2547         time00=MPI_Wtime()
2548 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2549 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2550 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2551         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2552      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2553      &   FG_COMM1,IERR)
2554         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2555      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2556      &   FG_COMM1,IERR)
2557         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2558      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2559      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2560         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2561      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2562      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2563         time_gather=time_gather+MPI_Wtime()-time00
2564       endif
2565 c      if (fg_rank.eq.0) then
2566 c        write (iout,*) "Arrays UY and UZ"
2567 c        do i=1,nres-1
2568 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2569 c     &     (uz(k,i),k=1,3)
2570 c        enddo
2571 c      endif
2572 #endif
2573       return
2574       end
2575 C-----------------------------------------------------------------------------
2576       subroutine check_vecgrad
2577       implicit real*8 (a-h,o-z)
2578       include 'DIMENSIONS'
2579       include 'COMMON.IOUNITS'
2580       include 'COMMON.GEO'
2581       include 'COMMON.VAR'
2582       include 'COMMON.LOCAL'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.VECTORS'
2585       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2586       dimension uyt(3,maxres),uzt(3,maxres)
2587       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2588       double precision delta /1.0d-7/
2589       call vec_and_deriv
2590 cd      do i=1,nres
2591 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2592 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2593 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2594 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2595 cd     &     (dc_norm(if90,i),if90=1,3)
2596 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2597 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2598 cd          write(iout,'(a)')
2599 cd      enddo
2600       do i=1,nres
2601         do j=1,2
2602           do k=1,3
2603             do l=1,3
2604               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2605               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2606             enddo
2607           enddo
2608         enddo
2609       enddo
2610       call vec_and_deriv
2611       do i=1,nres
2612         do j=1,3
2613           uyt(j,i)=uy(j,i)
2614           uzt(j,i)=uz(j,i)
2615         enddo
2616       enddo
2617       do i=1,nres
2618 cd        write (iout,*) 'i=',i
2619         do k=1,3
2620           erij(k)=dc_norm(k,i)
2621         enddo
2622         do j=1,3
2623           do k=1,3
2624             dc_norm(k,i)=erij(k)
2625           enddo
2626           dc_norm(j,i)=dc_norm(j,i)+delta
2627 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2628 c          do k=1,3
2629 c            dc_norm(k,i)=dc_norm(k,i)/fac
2630 c          enddo
2631 c          write (iout,*) (dc_norm(k,i),k=1,3)
2632 c          write (iout,*) (erij(k),k=1,3)
2633           call vec_and_deriv
2634           do k=1,3
2635             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2636             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2637             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2638             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2639           enddo
2640 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2641 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2642 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2643         enddo
2644         do k=1,3
2645           dc_norm(k,i)=erij(k)
2646         enddo
2647 cd        do k=1,3
2648 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2649 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2650 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2651 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2652 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2653 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2654 cd          write (iout,'(a)')
2655 cd        enddo
2656       enddo
2657       return
2658       end
2659 C--------------------------------------------------------------------------
2660       subroutine set_matrices
2661       implicit real*8 (a-h,o-z)
2662       include 'DIMENSIONS'
2663 #ifdef MPI
2664       include "mpif.h"
2665       include "COMMON.SETUP"
2666       integer IERR
2667       integer status(MPI_STATUS_SIZE)
2668 #endif
2669       include 'COMMON.IOUNITS'
2670       include 'COMMON.GEO'
2671       include 'COMMON.VAR'
2672       include 'COMMON.LOCAL'
2673       include 'COMMON.CHAIN'
2674       include 'COMMON.DERIV'
2675       include 'COMMON.INTERACT'
2676       include 'COMMON.CONTACTS'
2677       include 'COMMON.TORSION'
2678       include 'COMMON.VECTORS'
2679       include 'COMMON.FFIELD'
2680       double precision auxvec(2),auxmat(2,2)
2681 C
2682 C Compute the virtual-bond-torsional-angle dependent quantities needed
2683 C to calculate the el-loc multibody terms of various order.
2684 C
2685 c      write(iout,*) 'nphi=',nphi,nres
2686 #ifdef PARMAT
2687       do i=ivec_start+2,ivec_end+2
2688 #else
2689       do i=3,nres+1
2690 #endif
2691 #ifdef NEWCORR
2692         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2693           iti = itortyp(itype(i-2))
2694         else
2695           iti=ntortyp+1
2696         endif
2697 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2698         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2699           iti1 = itortyp(itype(i-1))
2700         else
2701           iti1=ntortyp+1
2702         endif
2703 c        write(iout,*),i
2704         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2705      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2706      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2707         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2708      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2709      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2710 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2711 c     &*(cos(theta(i)/2.0)
2712         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2713      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2714      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2715 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2716 c     &*(cos(theta(i)/2.0)
2717         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2718      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2719      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2720 c        if (ggb1(1,i).eq.0.0d0) then
2721 c        write(iout,*) 'i=',i,ggb1(1,i),
2722 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2723 c     &bnew1(2,1,iti)*cos(theta(i)),
2724 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2725 c        endif
2726         b1(2,i-2)=bnew1(1,2,iti)
2727         gtb1(2,i-2)=0.0
2728         b2(2,i-2)=bnew2(1,2,iti)
2729         gtb2(2,i-2)=0.0
2730         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2731         EE(1,2,i-2)=eeold(1,2,iti)
2732         EE(2,1,i-2)=eeold(2,1,iti)
2733         EE(2,2,i-2)=eeold(2,2,iti)
2734         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2735         gtEE(1,2,i-2)=0.0d0
2736         gtEE(2,2,i-2)=0.0d0
2737         gtEE(2,1,i-2)=0.0d0
2738 c        EE(2,2,iti)=0.0d0
2739 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2740 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2741 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2742 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2743        b1tilde(1,i-2)=b1(1,i-2)
2744        b1tilde(2,i-2)=-b1(2,i-2)
2745        b2tilde(1,i-2)=b2(1,i-2)
2746        b2tilde(2,i-2)=-b2(2,i-2)
2747 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2748 c       write(iout,*)  'b1=',b1(1,i-2)
2749 c       write (iout,*) 'theta=', theta(i-1)
2750        enddo
2751 #else
2752         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2753           iti = itortyp(itype(i-2))
2754         else
2755           iti=ntortyp+1
2756         endif
2757 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2758         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2759           iti1 = itortyp(itype(i-1))
2760         else
2761           iti1=ntortyp+1
2762         endif
2763         b1(1,i-2)=b(3,iti)
2764         b1(2,i-2)=b(5,iti)
2765         b2(1,i-2)=b(2,iti)
2766         b2(2,i-2)=b(4,iti)
2767        b1tilde(1,i-2)=b1(1,i-2)
2768        b1tilde(2,i-2)=-b1(2,i-2)
2769        b2tilde(1,i-2)=b2(1,i-2)
2770        b2tilde(2,i-2)=-b2(2,i-2)
2771         EE(1,2,i-2)=eeold(1,2,iti)
2772         EE(2,1,i-2)=eeold(2,1,iti)
2773         EE(2,2,i-2)=eeold(2,2,iti)
2774         EE(1,1,i-2)=eeold(1,1,iti)
2775       enddo
2776 #endif
2777 #ifdef PARMAT
2778       do i=ivec_start+2,ivec_end+2
2779 #else
2780       do i=3,nres+1
2781 #endif
2782         if (i .lt. nres+1) then
2783           sin1=dsin(phi(i))
2784           cos1=dcos(phi(i))
2785           sintab(i-2)=sin1
2786           costab(i-2)=cos1
2787           obrot(1,i-2)=cos1
2788           obrot(2,i-2)=sin1
2789           sin2=dsin(2*phi(i))
2790           cos2=dcos(2*phi(i))
2791           sintab2(i-2)=sin2
2792           costab2(i-2)=cos2
2793           obrot2(1,i-2)=cos2
2794           obrot2(2,i-2)=sin2
2795           Ug(1,1,i-2)=-cos1
2796           Ug(1,2,i-2)=-sin1
2797           Ug(2,1,i-2)=-sin1
2798           Ug(2,2,i-2)= cos1
2799           Ug2(1,1,i-2)=-cos2
2800           Ug2(1,2,i-2)=-sin2
2801           Ug2(2,1,i-2)=-sin2
2802           Ug2(2,2,i-2)= cos2
2803         else
2804           costab(i-2)=1.0d0
2805           sintab(i-2)=0.0d0
2806           obrot(1,i-2)=1.0d0
2807           obrot(2,i-2)=0.0d0
2808           obrot2(1,i-2)=0.0d0
2809           obrot2(2,i-2)=0.0d0
2810           Ug(1,1,i-2)=1.0d0
2811           Ug(1,2,i-2)=0.0d0
2812           Ug(2,1,i-2)=0.0d0
2813           Ug(2,2,i-2)=1.0d0
2814           Ug2(1,1,i-2)=0.0d0
2815           Ug2(1,2,i-2)=0.0d0
2816           Ug2(2,1,i-2)=0.0d0
2817           Ug2(2,2,i-2)=0.0d0
2818         endif
2819         if (i .gt. 3 .and. i .lt. nres+1) then
2820           obrot_der(1,i-2)=-sin1
2821           obrot_der(2,i-2)= cos1
2822           Ugder(1,1,i-2)= sin1
2823           Ugder(1,2,i-2)=-cos1
2824           Ugder(2,1,i-2)=-cos1
2825           Ugder(2,2,i-2)=-sin1
2826           dwacos2=cos2+cos2
2827           dwasin2=sin2+sin2
2828           obrot2_der(1,i-2)=-dwasin2
2829           obrot2_der(2,i-2)= dwacos2
2830           Ug2der(1,1,i-2)= dwasin2
2831           Ug2der(1,2,i-2)=-dwacos2
2832           Ug2der(2,1,i-2)=-dwacos2
2833           Ug2der(2,2,i-2)=-dwasin2
2834         else
2835           obrot_der(1,i-2)=0.0d0
2836           obrot_der(2,i-2)=0.0d0
2837           Ugder(1,1,i-2)=0.0d0
2838           Ugder(1,2,i-2)=0.0d0
2839           Ugder(2,1,i-2)=0.0d0
2840           Ugder(2,2,i-2)=0.0d0
2841           obrot2_der(1,i-2)=0.0d0
2842           obrot2_der(2,i-2)=0.0d0
2843           Ug2der(1,1,i-2)=0.0d0
2844           Ug2der(1,2,i-2)=0.0d0
2845           Ug2der(2,1,i-2)=0.0d0
2846           Ug2der(2,2,i-2)=0.0d0
2847         endif
2848 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2849         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2850           iti = itortyp(itype(i-2))
2851         else
2852           iti=ntortyp
2853         endif
2854 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2855         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2856           iti1 = itortyp(itype(i-1))
2857         else
2858           iti1=ntortyp
2859         endif
2860 cd        write (iout,*) '*******i',i,' iti1',iti
2861 cd        write (iout,*) 'b1',b1(:,iti)
2862 cd        write (iout,*) 'b2',b2(:,iti)
2863 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2864 cd         write (iout,*) 'Ug',Ug(:,:,i-2)
2865 c        if (i .gt. iatel_s+2) then
2866         if (i .gt. nnt+2) then
2867           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2868 #ifdef NEWCORR
2869           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2870 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2871 #endif
2872 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2873 c     &    EE(1,2,iti),EE(2,2,iti)
2874           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2875           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2876 c          write(iout,*) "Macierz EUG",
2877 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2878 c     &    eug(2,2,i-2)
2879           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2880      &    then
2881           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2882           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2883           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2884           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2885           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2886           endif
2887         else
2888           do k=1,2
2889             Ub2(k,i-2)=0.0d0
2890             Ctobr(k,i-2)=0.0d0
2891             Dtobr2(k,i-2)=0.0d0
2892             do l=1,2
2893               EUg(l,k,i-2)=0.0d0
2894               CUg(l,k,i-2)=0.0d0
2895               DUg(l,k,i-2)=0.0d0
2896               DtUg2(l,k,i-2)=0.0d0
2897             enddo
2898           enddo
2899         endif
2900         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2901         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2902         do k=1,2
2903           muder(k,i-2)=Ub2der(k,i-2)
2904         enddo
2905 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2906         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2907           if (itype(i-1).le.ntyp) then
2908             iti1 = itortyp(itype(i-1))
2909           else
2910             iti1=ntortyp
2911           endif
2912         else
2913           iti1=ntortyp
2914         endif
2915         do k=1,2
2916           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2917         enddo
2918 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2919 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2920 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2921 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2922 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2923 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2924 cd        write (iout,*) 'mu1',mu1(:,i-2)
2925 cd        write (iout,*) 'mu2',mu2(:,i-2)
2926         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2927      &  then
2928         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2929         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2930         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2931         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2932         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2933 C Vectors and matrices dependent on a single virtual-bond dihedral.
2934         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2935         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2936         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2937         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2938         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2939         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2940         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2941         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2942         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2943         endif
2944       enddo
2945 C Matrices dependent on two consecutive virtual-bond dihedrals.
2946 C The order of matrices is from left to right.
2947       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2948      &then
2949 c      do i=max0(ivec_start,2),ivec_end
2950       do i=2,nres-1
2951         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2952         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2953         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2954         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2955         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2956         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2957         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2958         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2959       enddo
2960       endif
2961 #if defined(MPI) && defined(PARMAT)
2962 #ifdef DEBUG
2963 c      if (fg_rank.eq.0) then
2964         write (iout,*) "Arrays UG and UGDER before GATHER"
2965         do i=1,nres-1
2966           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2967      &     ((ug(l,k,i),l=1,2),k=1,2),
2968      &     ((ugder(l,k,i),l=1,2),k=1,2)
2969         enddo
2970         write (iout,*) "Arrays UG2 and UG2DER"
2971         do i=1,nres-1
2972           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2973      &     ((ug2(l,k,i),l=1,2),k=1,2),
2974      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2975         enddo
2976         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2977         do i=1,nres-1
2978           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2979      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2980      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2981         enddo
2982         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2983         do i=1,nres-1
2984           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2985      &     costab(i),sintab(i),costab2(i),sintab2(i)
2986         enddo
2987         write (iout,*) "Array MUDER"
2988         do i=1,nres-1
2989           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2990         enddo
2991 c      endif
2992 #endif
2993       if (nfgtasks.gt.1) then
2994         time00=MPI_Wtime()
2995 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2996 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2997 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2998 #ifdef MATGATHER
2999         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3012      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3013      &   FG_COMM1,IERR)
3014         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3015      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3016      &   FG_COMM1,IERR)
3017         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3018      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3019      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3020         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3021      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3022      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3023         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3024      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3025      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3026         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3027      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3028      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3029         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3030      &  then
3031         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3047      &   ivec_count(fg_rank1),
3048      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3049      &   FG_COMM1,IERR)
3050         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3051      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3052      &   FG_COMM1,IERR)
3053         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3054      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3057      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3058      &   FG_COMM1,IERR)
3059         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3060      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3061      &   FG_COMM1,IERR)
3062         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3063      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3064      &   FG_COMM1,IERR)
3065         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3066      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3067      &   FG_COMM1,IERR)
3068         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3069      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3070      &   FG_COMM1,IERR)
3071         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3072      &   ivec_count(fg_rank1),
3073      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3074      &   FG_COMM1,IERR)
3075         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3077      &   FG_COMM1,IERR)
3078        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3079      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3080      &   FG_COMM1,IERR)
3081         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3082      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3083      &   FG_COMM1,IERR)
3084        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3085      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3086      &   FG_COMM1,IERR)
3087         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3088      &   ivec_count(fg_rank1),
3089      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3092      &   ivec_count(fg_rank1),
3093      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3094      &   FG_COMM1,IERR)
3095         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3096      &   ivec_count(fg_rank1),
3097      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3098      &   MPI_MAT2,FG_COMM1,IERR)
3099         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3100      &   ivec_count(fg_rank1),
3101      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3102      &   MPI_MAT2,FG_COMM1,IERR)
3103         endif
3104 #else
3105 c Passes matrix info through the ring
3106       isend=fg_rank1
3107       irecv=fg_rank1-1
3108       if (irecv.lt.0) irecv=nfgtasks1-1
3109       iprev=irecv
3110       inext=fg_rank1+1
3111       if (inext.ge.nfgtasks1) inext=0
3112       do i=1,nfgtasks1-1
3113 c        write (iout,*) "isend",isend," irecv",irecv
3114 c        call flush(iout)
3115         lensend=lentyp(isend)
3116         lenrecv=lentyp(irecv)
3117 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3118 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3119 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3120 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3121 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3122 c        write (iout,*) "Gather ROTAT1"
3123 c        call flush(iout)
3124 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3125 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3126 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3127 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3128 c        write (iout,*) "Gather ROTAT2"
3129 c        call flush(iout)
3130         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3131      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3132      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3133      &   iprev,4400+irecv,FG_COMM,status,IERR)
3134 c        write (iout,*) "Gather ROTAT_OLD"
3135 c        call flush(iout)
3136         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3137      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3138      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3139      &   iprev,5500+irecv,FG_COMM,status,IERR)
3140 c        write (iout,*) "Gather PRECOMP11"
3141 c        call flush(iout)
3142         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3143      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3144      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3145      &   iprev,6600+irecv,FG_COMM,status,IERR)
3146 c        write (iout,*) "Gather PRECOMP12"
3147 c        call flush(iout)
3148         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3149      &  then
3150         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3151      &   MPI_ROTAT2(lensend),inext,7700+isend,
3152      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3153      &   iprev,7700+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather PRECOMP21"
3155 c        call flush(iout)
3156         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3157      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3158      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3159      &   iprev,8800+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather PRECOMP22"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3163      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3164      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3165      &   MPI_PRECOMP23(lenrecv),
3166      &   iprev,9900+irecv,FG_COMM,status,IERR)
3167 c        write (iout,*) "Gather PRECOMP23"
3168 c        call flush(iout)
3169         endif
3170         isend=irecv
3171         irecv=irecv-1
3172         if (irecv.lt.0) irecv=nfgtasks1-1
3173       enddo
3174 #endif
3175         time_gather=time_gather+MPI_Wtime()-time00
3176       endif
3177 #ifdef DEBUG
3178 c      if (fg_rank.eq.0) then
3179         write (iout,*) "Arrays UG and UGDER"
3180         do i=1,nres-1
3181           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3182      &     ((ug(l,k,i),l=1,2),k=1,2),
3183      &     ((ugder(l,k,i),l=1,2),k=1,2)
3184         enddo
3185         write (iout,*) "Arrays UG2 and UG2DER"
3186         do i=1,nres-1
3187           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3188      &     ((ug2(l,k,i),l=1,2),k=1,2),
3189      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3190         enddo
3191         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3192         do i=1,nres-1
3193           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3194      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3195      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3196         enddo
3197         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3198         do i=1,nres-1
3199           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3200      &     costab(i),sintab(i),costab2(i),sintab2(i)
3201         enddo
3202         write (iout,*) "Array MUDER"
3203         do i=1,nres-1
3204           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3205         enddo
3206 c      endif
3207 #endif
3208 #endif
3209 cd      do i=1,nres
3210 cd        iti = itortyp(itype(i))
3211 cd        write (iout,*) i
3212 cd        do j=1,2
3213 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3214 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3215 cd        enddo
3216 cd      enddo
3217       return
3218       end
3219 C--------------------------------------------------------------------------
3220       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3221 C
3222 C This subroutine calculates the average interaction energy and its gradient
3223 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3224 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3225 C The potential depends both on the distance of peptide-group centers and on
3226 C the orientation of the CA-CA virtual bonds.
3227 C
3228       implicit real*8 (a-h,o-z)
3229 #ifdef MPI
3230       include 'mpif.h'
3231 #endif
3232       include 'DIMENSIONS'
3233       include 'COMMON.CONTROL'
3234       include 'COMMON.SETUP'
3235       include 'COMMON.IOUNITS'
3236       include 'COMMON.GEO'
3237       include 'COMMON.VAR'
3238       include 'COMMON.LOCAL'
3239       include 'COMMON.CHAIN'
3240       include 'COMMON.DERIV'
3241       include 'COMMON.INTERACT'
3242       include 'COMMON.CONTACTS'
3243       include 'COMMON.TORSION'
3244       include 'COMMON.VECTORS'
3245       include 'COMMON.FFIELD'
3246       include 'COMMON.TIME1'
3247       include 'COMMON.SPLITELE'
3248       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3249      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3250       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3251      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3252       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3253      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3254      &    num_conti,j1,j2
3255 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3256 #ifdef MOMENT
3257       double precision scal_el /1.0d0/
3258 #else
3259       double precision scal_el /0.5d0/
3260 #endif
3261 C 12/13/98
3262 C 13-go grudnia roku pamietnego...
3263       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3264      &                   0.0d0,1.0d0,0.0d0,
3265      &                   0.0d0,0.0d0,1.0d0/
3266 cd      write(iout,*) 'In EELEC'
3267 cd      do i=1,nloctyp
3268 cd        write(iout,*) 'Type',i
3269 cd        write(iout,*) 'B1',B1(:,i)
3270 cd        write(iout,*) 'B2',B2(:,i)
3271 cd        write(iout,*) 'CC',CC(:,:,i)
3272 cd        write(iout,*) 'DD',DD(:,:,i)
3273 cd        write(iout,*) 'EE',EE(:,:,i)
3274 cd      enddo
3275 cd      call check_vecgrad
3276 cd      stop
3277       if (icheckgrad.eq.1) then
3278         do i=1,nres-1
3279           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3280           do k=1,3
3281             dc_norm(k,i)=dc(k,i)*fac
3282           enddo
3283 c          write (iout,*) 'i',i,' fac',fac
3284         enddo
3285       endif
3286       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3287      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3288      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3289 c        call vec_and_deriv
3290 #ifdef TIMING
3291         time01=MPI_Wtime()
3292 #endif
3293         call set_matrices
3294 #ifdef TIMING
3295         time_mat=time_mat+MPI_Wtime()-time01
3296 #endif
3297       endif
3298 cd      do i=1,nres-1
3299 cd        write (iout,*) 'i=',i
3300 cd        do k=1,3
3301 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3302 cd        enddo
3303 cd        do k=1,3
3304 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3305 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3306 cd        enddo
3307 cd      enddo
3308       t_eelecij=0.0d0
3309       ees=0.0D0
3310       evdw1=0.0D0
3311       eel_loc=0.0d0
3312       eello_turn3=0.0d0
3313       eello_turn4=0.0d0
3314       ind=0
3315       do i=1,nres
3316         num_cont_hb(i)=0
3317       enddo
3318 cd      print '(a)','Enter EELEC'
3319 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3320       do i=1,nres
3321         gel_loc_loc(i)=0.0d0
3322         gcorr_loc(i)=0.0d0
3323       enddo
3324 c
3325 c
3326 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3327 C
3328 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3329 C
3330 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3331       do i=iturn3_start,iturn3_end
3332 CAna        if (i.le.1) cycle
3333 C        write(iout,*) "tu jest i",i
3334         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3335 C changes suggested by Ana to avoid out of bounds
3336 CAna     & .or.((i+4).gt.nres)
3337 CAna     & .or.((i-1).le.0)
3338 C end of changes by Ana
3339      &  .or. itype(i+2).eq.ntyp1
3340      &  .or. itype(i+3).eq.ntyp1) cycle
3341 CAna        if(i.gt.1)then
3342 CAna          if(itype(i-1).eq.ntyp1)cycle
3343 CAna        end if
3344 CAna        if(i.LT.nres-3)then
3345 CAna          if (itype(i+4).eq.ntyp1) cycle
3346 CAna        end if
3347         dxi=dc(1,i)
3348         dyi=dc(2,i)
3349         dzi=dc(3,i)
3350         dx_normi=dc_norm(1,i)
3351         dy_normi=dc_norm(2,i)
3352         dz_normi=dc_norm(3,i)
3353         xmedi=c(1,i)+0.5d0*dxi
3354         ymedi=c(2,i)+0.5d0*dyi
3355         zmedi=c(3,i)+0.5d0*dzi
3356           xmedi=mod(xmedi,boxxsize)
3357           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3358           ymedi=mod(ymedi,boxysize)
3359           if (ymedi.lt.0) ymedi=ymedi+boxysize
3360           zmedi=mod(zmedi,boxzsize)
3361           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3362         num_conti=0
3363         call eelecij(i,i+2,ees,evdw1,eel_loc)
3364         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3365         num_cont_hb(i)=num_conti
3366       enddo
3367       do i=iturn4_start,iturn4_end
3368 cAna        if (i.le.1) cycle
3369         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3370 C changes suggested by Ana to avoid out of bounds
3371 cAna     & .or.((i+5).gt.nres)
3372 cAna     & .or.((i-1).le.0)
3373 C end of changes suggested by Ana
3374      &    .or. itype(i+3).eq.ntyp1
3375      &    .or. itype(i+4).eq.ntyp1
3376 cAna     &    .or. itype(i+5).eq.ntyp1
3377 cAna     &    .or. itype(i).eq.ntyp1
3378 cAna     &    .or. itype(i-1).eq.ntyp1
3379      &                             ) cycle
3380         dxi=dc(1,i)
3381         dyi=dc(2,i)
3382         dzi=dc(3,i)
3383         dx_normi=dc_norm(1,i)
3384         dy_normi=dc_norm(2,i)
3385         dz_normi=dc_norm(3,i)
3386         xmedi=c(1,i)+0.5d0*dxi
3387         ymedi=c(2,i)+0.5d0*dyi
3388         zmedi=c(3,i)+0.5d0*dzi
3389 C Return atom into box, boxxsize is size of box in x dimension
3390 c  194   continue
3391 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3392 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3393 C Condition for being inside the proper box
3394 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3395 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3396 c        go to 194
3397 c        endif
3398 c  195   continue
3399 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3400 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3401 C Condition for being inside the proper box
3402 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3403 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3404 c        go to 195
3405 c        endif
3406 c  196   continue
3407 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3408 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3409 C Condition for being inside the proper box
3410 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3411 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3412 c        go to 196
3413 c        endif
3414           xmedi=mod(xmedi,boxxsize)
3415           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3416           ymedi=mod(ymedi,boxysize)
3417           if (ymedi.lt.0) ymedi=ymedi+boxysize
3418           zmedi=mod(zmedi,boxzsize)
3419           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3420
3421         num_conti=num_cont_hb(i)
3422 c        write(iout,*) "JESTEM W PETLI"
3423         call eelecij(i,i+3,ees,evdw1,eel_loc)
3424         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3425      &   call eturn4(i,eello_turn4)
3426         num_cont_hb(i)=num_conti
3427       enddo   ! i
3428 C Loop over all neighbouring boxes
3429 C      do xshift=-1,1
3430 C      do yshift=-1,1
3431 C      do zshift=-1,1
3432 c
3433 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3434 c
3435       do i=iatel_s,iatel_e
3436 cAna        if (i.le.1) cycle
3437         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3438 C changes suggested by Ana to avoid out of bounds
3439 cAna     & .or.((i+2).gt.nres)
3440 cAna     & .or.((i-1).le.0)
3441 C end of changes by Ana
3442 cAna     &  .or. itype(i+2).eq.ntyp1
3443 cAna     &  .or. itype(i-1).eq.ntyp1
3444      &                ) cycle
3445         dxi=dc(1,i)
3446         dyi=dc(2,i)
3447         dzi=dc(3,i)
3448         dx_normi=dc_norm(1,i)
3449         dy_normi=dc_norm(2,i)
3450         dz_normi=dc_norm(3,i)
3451         xmedi=c(1,i)+0.5d0*dxi
3452         ymedi=c(2,i)+0.5d0*dyi
3453         zmedi=c(3,i)+0.5d0*dzi
3454           xmedi=mod(xmedi,boxxsize)
3455           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3456           ymedi=mod(ymedi,boxysize)
3457           if (ymedi.lt.0) ymedi=ymedi+boxysize
3458           zmedi=mod(zmedi,boxzsize)
3459           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3460 C          xmedi=xmedi+xshift*boxxsize
3461 C          ymedi=ymedi+yshift*boxysize
3462 C          zmedi=zmedi+zshift*boxzsize
3463
3464 C Return tom into box, boxxsize is size of box in x dimension
3465 c  164   continue
3466 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3467 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3468 C Condition for being inside the proper box
3469 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3470 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3471 c        go to 164
3472 c        endif
3473 c  165   continue
3474 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3475 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3476 C Condition for being inside the proper box
3477 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3478 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3479 c        go to 165
3480 c        endif
3481 c  166   continue
3482 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3483 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3484 cC Condition for being inside the proper box
3485 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3486 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3487 c        go to 166
3488 c        endif
3489
3490 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3491         num_conti=num_cont_hb(i)
3492         do j=ielstart(i),ielend(i)
3493 C          write (iout,*) i,j
3494 cAna         if (j.le.1) cycle
3495           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3496 C changes suggested by Ana to avoid out of bounds
3497 cAna     & .or.((j+2).gt.nres)
3498 cAna     & .or.((j-1).le.0)
3499 C end of changes by Ana
3500 cAna     & .or.itype(j+2).eq.ntyp1
3501 cAna     & .or.itype(j-1).eq.ntyp1
3502      &) cycle
3503           call eelecij(i,j,ees,evdw1,eel_loc)
3504         enddo ! j
3505         num_cont_hb(i)=num_conti
3506       enddo   ! i
3507 C     enddo   ! zshift
3508 C      enddo   ! yshift
3509 C      enddo   ! xshift
3510
3511 c      write (iout,*) "Number of loop steps in EELEC:",ind
3512 cd      do i=1,nres
3513 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3514 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3515 cd      enddo
3516 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3517 ccc      eel_loc=eel_loc+eello_turn3
3518 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3519       return
3520       end
3521 C-------------------------------------------------------------------------------
3522       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3523       implicit real*8 (a-h,o-z)
3524       include 'DIMENSIONS'
3525 #ifdef MPI
3526       include "mpif.h"
3527 #endif
3528       include 'COMMON.CONTROL'
3529       include 'COMMON.IOUNITS'
3530       include 'COMMON.GEO'
3531       include 'COMMON.VAR'
3532       include 'COMMON.LOCAL'
3533       include 'COMMON.CHAIN'
3534       include 'COMMON.DERIV'
3535       include 'COMMON.INTERACT'
3536       include 'COMMON.CONTACTS'
3537       include 'COMMON.TORSION'
3538       include 'COMMON.VECTORS'
3539       include 'COMMON.FFIELD'
3540       include 'COMMON.TIME1'
3541       include 'COMMON.SPLITELE'
3542       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3543      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3544       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3545      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3546      &    gmuij2(4),gmuji2(4)
3547       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3548      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3549      &    num_conti,j1,j2
3550 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3551 #ifdef MOMENT
3552       double precision scal_el /1.0d0/
3553 #else
3554       double precision scal_el /0.5d0/
3555 #endif
3556 C 12/13/98
3557 C 13-go grudnia roku pamietnego...
3558       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3559      &                   0.0d0,1.0d0,0.0d0,
3560      &                   0.0d0,0.0d0,1.0d0/
3561 c          time00=MPI_Wtime()
3562 cd      write (iout,*) "eelecij",i,j
3563 c          ind=ind+1
3564           iteli=itel(i)
3565           itelj=itel(j)
3566           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3567           aaa=app(iteli,itelj)
3568           bbb=bpp(iteli,itelj)
3569           ael6i=ael6(iteli,itelj)
3570           ael3i=ael3(iteli,itelj)
3571           dxj=dc(1,j)
3572           dyj=dc(2,j)
3573           dzj=dc(3,j)
3574           dx_normj=dc_norm(1,j)
3575           dy_normj=dc_norm(2,j)
3576           dz_normj=dc_norm(3,j)
3577 C          xj=c(1,j)+0.5D0*dxj-xmedi
3578 C          yj=c(2,j)+0.5D0*dyj-ymedi
3579 C          zj=c(3,j)+0.5D0*dzj-zmedi
3580           xj=c(1,j)+0.5D0*dxj
3581           yj=c(2,j)+0.5D0*dyj
3582           zj=c(3,j)+0.5D0*dzj
3583           xj=mod(xj,boxxsize)
3584           if (xj.lt.0) xj=xj+boxxsize
3585           yj=mod(yj,boxysize)
3586           if (yj.lt.0) yj=yj+boxysize
3587           zj=mod(zj,boxzsize)
3588           if (zj.lt.0) zj=zj+boxzsize
3589           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3590       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3591       xj_safe=xj
3592       yj_safe=yj
3593       zj_safe=zj
3594       isubchap=0
3595       do xshift=-1,1
3596       do yshift=-1,1
3597       do zshift=-1,1
3598           xj=xj_safe+xshift*boxxsize
3599           yj=yj_safe+yshift*boxysize
3600           zj=zj_safe+zshift*boxzsize
3601           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3602           if(dist_temp.lt.dist_init) then
3603             dist_init=dist_temp
3604             xj_temp=xj
3605             yj_temp=yj
3606             zj_temp=zj
3607             isubchap=1
3608           endif
3609        enddo
3610        enddo
3611        enddo
3612        if (isubchap.eq.1) then
3613           xj=xj_temp-xmedi
3614           yj=yj_temp-ymedi
3615           zj=zj_temp-zmedi
3616        else
3617           xj=xj_safe-xmedi
3618           yj=yj_safe-ymedi
3619           zj=zj_safe-zmedi
3620        endif
3621 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3622 c  174   continue
3623 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3624 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3625 C Condition for being inside the proper box
3626 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3627 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3628 c        go to 174
3629 c        endif
3630 c  175   continue
3631 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3632 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3633 C Condition for being inside the proper box
3634 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3635 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3636 c        go to 175
3637 c        endif
3638 c  176   continue
3639 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3640 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3641 C Condition for being inside the proper box
3642 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3643 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3644 c        go to 176
3645 c        endif
3646 C        endif !endPBC condintion
3647 C        xj=xj-xmedi
3648 C        yj=yj-ymedi
3649 C        zj=zj-zmedi
3650           rij=xj*xj+yj*yj+zj*zj
3651
3652             sss=sscale(sqrt(rij))
3653             sssgrad=sscagrad(sqrt(rij))
3654 c            if (sss.gt.0.0d0) then
3655           rrmij=1.0D0/rij
3656           rij=dsqrt(rij)
3657           rmij=1.0D0/rij
3658           r3ij=rrmij*rmij
3659           r6ij=r3ij*r3ij
3660           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3661           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3662           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3663           fac=cosa-3.0D0*cosb*cosg
3664           ev1=aaa*r6ij*r6ij
3665 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3666           if (j.eq.i+2) ev1=scal_el*ev1
3667           ev2=bbb*r6ij
3668           fac3=ael6i*r6ij
3669           fac4=ael3i*r3ij
3670           evdwij=(ev1+ev2)
3671           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3672           el2=fac4*fac
3673 C MARYSIA
3674           eesij=(el1+el2)
3675 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3676           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3677           ees=ees+eesij
3678           evdw1=evdw1+evdwij*sss
3679 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3680 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3681 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3682 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3683
3684           if (energy_dec) then
3685               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3686      &'evdw1',i,j,evdwij
3687 c     &,iteli,itelj,aaa,evdw1
3688               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3689           endif
3690
3691 C
3692 C Calculate contributions to the Cartesian gradient.
3693 C
3694 #ifdef SPLITELE
3695           facvdw=-6*rrmij*(ev1+evdwij)*sss
3696           facel=-3*rrmij*(el1+eesij)
3697           fac1=fac
3698           erij(1)=xj*rmij
3699           erij(2)=yj*rmij
3700           erij(3)=zj*rmij
3701 *
3702 * Radial derivatives. First process both termini of the fragment (i,j)
3703 *
3704           ggg(1)=facel*xj
3705           ggg(2)=facel*yj
3706           ggg(3)=facel*zj
3707 c          do k=1,3
3708 c            ghalf=0.5D0*ggg(k)
3709 c            gelc(k,i)=gelc(k,i)+ghalf
3710 c            gelc(k,j)=gelc(k,j)+ghalf
3711 c          enddo
3712 c 9/28/08 AL Gradient compotents will be summed only at the end
3713           do k=1,3
3714             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3715             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3716           enddo
3717 *
3718 * Loop over residues i+1 thru j-1.
3719 *
3720 cgrad          do k=i+1,j-1
3721 cgrad            do l=1,3
3722 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3723 cgrad            enddo
3724 cgrad          enddo
3725           if (sss.gt.0.0) then
3726           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3727           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3728           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3729           else
3730           ggg(1)=0.0
3731           ggg(2)=0.0
3732           ggg(3)=0.0
3733           endif
3734 c          do k=1,3
3735 c            ghalf=0.5D0*ggg(k)
3736 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3737 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3738 c          enddo
3739 c 9/28/08 AL Gradient compotents will be summed only at the end
3740           do k=1,3
3741             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3742             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3743           enddo
3744 *
3745 * Loop over residues i+1 thru j-1.
3746 *
3747 cgrad          do k=i+1,j-1
3748 cgrad            do l=1,3
3749 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3750 cgrad            enddo
3751 cgrad          enddo
3752 #else
3753 C MARYSIA
3754           facvdw=(ev1+evdwij)*sss
3755           facel=(el1+eesij)
3756           fac1=fac
3757           fac=-3*rrmij*(facvdw+facvdw+facel)
3758           erij(1)=xj*rmij
3759           erij(2)=yj*rmij
3760           erij(3)=zj*rmij
3761 *
3762 * Radial derivatives. First process both termini of the fragment (i,j)
3763 *
3764           ggg(1)=fac*xj
3765           ggg(2)=fac*yj
3766           ggg(3)=fac*zj
3767 c          do k=1,3
3768 c            ghalf=0.5D0*ggg(k)
3769 c            gelc(k,i)=gelc(k,i)+ghalf
3770 c            gelc(k,j)=gelc(k,j)+ghalf
3771 c          enddo
3772 c 9/28/08 AL Gradient compotents will be summed only at the end
3773           do k=1,3
3774             gelc_long(k,j)=gelc(k,j)+ggg(k)
3775             gelc_long(k,i)=gelc(k,i)-ggg(k)
3776           enddo
3777 *
3778 * Loop over residues i+1 thru j-1.
3779 *
3780 cgrad          do k=i+1,j-1
3781 cgrad            do l=1,3
3782 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3783 cgrad            enddo
3784 cgrad          enddo
3785 c 9/28/08 AL Gradient compotents will be summed only at the end
3786           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3787           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3788           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3789           do k=1,3
3790             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3791             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3792           enddo
3793 #endif
3794 *
3795 * Angular part
3796 *
3797           ecosa=2.0D0*fac3*fac1+fac4
3798           fac4=-3.0D0*fac4
3799           fac3=-6.0D0*fac3
3800           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3801           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3802           do k=1,3
3803             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3804             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3805           enddo
3806 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3807 cd   &          (dcosg(k),k=1,3)
3808           do k=1,3
3809             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3810           enddo
3811 c          do k=1,3
3812 c            ghalf=0.5D0*ggg(k)
3813 c            gelc(k,i)=gelc(k,i)+ghalf
3814 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3815 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3816 c            gelc(k,j)=gelc(k,j)+ghalf
3817 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3818 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3819 c          enddo
3820 cgrad          do k=i+1,j-1
3821 cgrad            do l=1,3
3822 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3823 cgrad            enddo
3824 cgrad          enddo
3825           do k=1,3
3826             gelc(k,i)=gelc(k,i)
3827      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3828      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3829             gelc(k,j)=gelc(k,j)
3830      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3831      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3832             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3833             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3834           enddo
3835 C MARYSIA
3836 c          endif !sscale
3837           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3838      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3839      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3840 C
3841 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3842 C   energy of a peptide unit is assumed in the form of a second-order
3843 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3844 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3845 C   are computed for EVERY pair of non-contiguous peptide groups.
3846 C
3847
3848           if (j.lt.nres-1) then
3849             j1=j+1
3850             j2=j-1
3851           else
3852             j1=j-1
3853             j2=j-2
3854           endif
3855           kkk=0
3856           lll=0
3857           do k=1,2
3858             do l=1,2
3859               kkk=kkk+1
3860               muij(kkk)=mu(k,i)*mu(l,j)
3861 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3862 #ifdef NEWCORR
3863              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3864 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3865              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3866              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3867 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3868              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3869 #endif
3870             enddo
3871           enddo
3872 cd         write (iout,*) 'EELEC: i',i,' j',j
3873 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3874 cd          write(iout,*) 'muij',muij
3875           ury=scalar(uy(1,i),erij)
3876           urz=scalar(uz(1,i),erij)
3877           vry=scalar(uy(1,j),erij)
3878           vrz=scalar(uz(1,j),erij)
3879           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3880           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3881           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3882           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3883           fac=dsqrt(-ael6i)*r3ij
3884           a22=a22*fac
3885           a23=a23*fac
3886           a32=a32*fac
3887           a33=a33*fac
3888 cd          write (iout,'(4i5,4f10.5)')
3889 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3890 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3891 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3892 cd     &      uy(:,j),uz(:,j)
3893 cd          write (iout,'(4f10.5)')
3894 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3895 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3896 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3897 cd           write (iout,'(9f10.5/)')
3898 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3899 C Derivatives of the elements of A in virtual-bond vectors
3900           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3901           do k=1,3
3902             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3903             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3904             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3905             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3906             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3907             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3908             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3909             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3910             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3911             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3912             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3913             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3914           enddo
3915 C Compute radial contributions to the gradient
3916           facr=-3.0d0*rrmij
3917           a22der=a22*facr
3918           a23der=a23*facr
3919           a32der=a32*facr
3920           a33der=a33*facr
3921           agg(1,1)=a22der*xj
3922           agg(2,1)=a22der*yj
3923           agg(3,1)=a22der*zj
3924           agg(1,2)=a23der*xj
3925           agg(2,2)=a23der*yj
3926           agg(3,2)=a23der*zj
3927           agg(1,3)=a32der*xj
3928           agg(2,3)=a32der*yj
3929           agg(3,3)=a32der*zj
3930           agg(1,4)=a33der*xj
3931           agg(2,4)=a33der*yj
3932           agg(3,4)=a33der*zj
3933 C Add the contributions coming from er
3934           fac3=-3.0d0*fac
3935           do k=1,3
3936             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3937             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3938             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3939             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3940           enddo
3941           do k=1,3
3942 C Derivatives in DC(i)
3943 cgrad            ghalf1=0.5d0*agg(k,1)
3944 cgrad            ghalf2=0.5d0*agg(k,2)
3945 cgrad            ghalf3=0.5d0*agg(k,3)
3946 cgrad            ghalf4=0.5d0*agg(k,4)
3947             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3948      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3949             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3950      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3951             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3952      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3953             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3954      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3955 C Derivatives in DC(i+1)
3956             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3957      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3958             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3959      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3960             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3961      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3962             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3963      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3964 C Derivatives in DC(j)
3965             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3966      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3967             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3968      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3969             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3970      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3971             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3972      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3973 C Derivatives in DC(j+1) or DC(nres-1)
3974             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3975      &      -3.0d0*vryg(k,3)*ury)
3976             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3977      &      -3.0d0*vrzg(k,3)*ury)
3978             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3979      &      -3.0d0*vryg(k,3)*urz)
3980             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3981      &      -3.0d0*vrzg(k,3)*urz)
3982 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3983 cgrad              do l=1,4
3984 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3985 cgrad              enddo
3986 cgrad            endif
3987           enddo
3988           acipa(1,1)=a22
3989           acipa(1,2)=a23
3990           acipa(2,1)=a32
3991           acipa(2,2)=a33
3992           a22=-a22
3993           a23=-a23
3994           do l=1,2
3995             do k=1,3
3996               agg(k,l)=-agg(k,l)
3997               aggi(k,l)=-aggi(k,l)
3998               aggi1(k,l)=-aggi1(k,l)
3999               aggj(k,l)=-aggj(k,l)
4000               aggj1(k,l)=-aggj1(k,l)
4001             enddo
4002           enddo
4003           if (j.lt.nres-1) then
4004             a22=-a22
4005             a32=-a32
4006             do l=1,3,2
4007               do k=1,3
4008                 agg(k,l)=-agg(k,l)
4009                 aggi(k,l)=-aggi(k,l)
4010                 aggi1(k,l)=-aggi1(k,l)
4011                 aggj(k,l)=-aggj(k,l)
4012                 aggj1(k,l)=-aggj1(k,l)
4013               enddo
4014             enddo
4015           else
4016             a22=-a22
4017             a23=-a23
4018             a32=-a32
4019             a33=-a33
4020             do l=1,4
4021               do k=1,3
4022                 agg(k,l)=-agg(k,l)
4023                 aggi(k,l)=-aggi(k,l)
4024                 aggi1(k,l)=-aggi1(k,l)
4025                 aggj(k,l)=-aggj(k,l)
4026                 aggj1(k,l)=-aggj1(k,l)
4027               enddo
4028             enddo
4029           endif
4030           ENDIF ! WCORR
4031           IF (wel_loc.gt.0.0d0) THEN
4032 C Contribution to the local-electrostatic energy coming from the i-j pair
4033           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4034      &     +a33*muij(4)
4035 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4036 c     &                     ' eel_loc_ij',eel_loc_ij
4037 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4038 C Calculate patrial derivative for theta angle
4039 #ifdef NEWCORR
4040          geel_loc_ij=a22*gmuij1(1)
4041      &     +a23*gmuij1(2)
4042      &     +a32*gmuij1(3)
4043      &     +a33*gmuij1(4)
4044 c         write(iout,*) "derivative over thatai"
4045 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4046 c     &   a33*gmuij1(4)
4047          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4048      &      geel_loc_ij*wel_loc
4049 c         write(iout,*) "derivative over thatai-1"
4050 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4051 c     &   a33*gmuij2(4)
4052          geel_loc_ij=
4053      &     a22*gmuij2(1)
4054      &     +a23*gmuij2(2)
4055      &     +a32*gmuij2(3)
4056      &     +a33*gmuij2(4)
4057          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4058      &      geel_loc_ij*wel_loc
4059 c  Derivative over j residue
4060          geel_loc_ji=a22*gmuji1(1)
4061      &     +a23*gmuji1(2)
4062      &     +a32*gmuji1(3)
4063      &     +a33*gmuji1(4)
4064 c         write(iout,*) "derivative over thataj"
4065 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4066 c     &   a33*gmuji1(4)
4067
4068         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4069      &      geel_loc_ji*wel_loc
4070          geel_loc_ji=
4071      &     +a22*gmuji2(1)
4072      &     +a23*gmuji2(2)
4073      &     +a32*gmuji2(3)
4074      &     +a33*gmuji2(4)
4075 c         write(iout,*) "derivative over thataj-1"
4076 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4077 c     &   a33*gmuji2(4)
4078          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4079      &      geel_loc_ji*wel_loc
4080 #endif
4081 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4082
4083           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4084      &            'eelloc',i,j,eel_loc_ij
4085 c           if (eel_loc_ij.ne.0)
4086 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4087 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4088
4089           eel_loc=eel_loc+eel_loc_ij
4090 C Partial derivatives in virtual-bond dihedral angles gamma
4091           if (i.gt.1)
4092      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4093      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4094      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4095           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4096      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4097      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4098 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4099           do l=1,3
4100             ggg(l)=agg(l,1)*muij(1)+
4101      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4102             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4103             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4104 cgrad            ghalf=0.5d0*ggg(l)
4105 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4106 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4107           enddo
4108 cgrad          do k=i+1,j2
4109 cgrad            do l=1,3
4110 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4111 cgrad            enddo
4112 cgrad          enddo
4113 C Remaining derivatives of eello
4114           do l=1,3
4115             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4116      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4117             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4118      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4119             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4120      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4121             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4122      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4123           enddo
4124           ENDIF
4125 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4126 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4127           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4128      &       .and. num_conti.le.maxconts) then
4129 c            write (iout,*) i,j," entered corr"
4130 C
4131 C Calculate the contact function. The ith column of the array JCONT will
4132 C contain the numbers of atoms that make contacts with the atom I (of numbers
4133 C greater than I). The arrays FACONT and GACONT will contain the values of
4134 C the contact function and its derivative.
4135 c           r0ij=1.02D0*rpp(iteli,itelj)
4136 c           r0ij=1.11D0*rpp(iteli,itelj)
4137             r0ij=2.20D0*rpp(iteli,itelj)
4138 c           r0ij=1.55D0*rpp(iteli,itelj)
4139             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4140             if (fcont.gt.0.0D0) then
4141               num_conti=num_conti+1
4142               if (num_conti.gt.maxconts) then
4143                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4144      &                         ' will skip next contacts for this conf.'
4145               else
4146                 jcont_hb(num_conti,i)=j
4147 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4148 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4149                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4150      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4151 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4152 C  terms.
4153                 d_cont(num_conti,i)=rij
4154 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4155 C     --- Electrostatic-interaction matrix ---
4156                 a_chuj(1,1,num_conti,i)=a22
4157                 a_chuj(1,2,num_conti,i)=a23
4158                 a_chuj(2,1,num_conti,i)=a32
4159                 a_chuj(2,2,num_conti,i)=a33
4160 C     --- Gradient of rij
4161                 do kkk=1,3
4162                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4163                 enddo
4164                 kkll=0
4165                 do k=1,2
4166                   do l=1,2
4167                     kkll=kkll+1
4168                     do m=1,3
4169                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4170                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4171                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4172                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4173                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4174                     enddo
4175                   enddo
4176                 enddo
4177                 ENDIF
4178                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4179 C Calculate contact energies
4180                 cosa4=4.0D0*cosa
4181                 wij=cosa-3.0D0*cosb*cosg
4182                 cosbg1=cosb+cosg
4183                 cosbg2=cosb-cosg
4184 c               fac3=dsqrt(-ael6i)/r0ij**3
4185                 fac3=dsqrt(-ael6i)*r3ij
4186 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4187                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4188                 if (ees0tmp.gt.0) then
4189                   ees0pij=dsqrt(ees0tmp)
4190                 else
4191                   ees0pij=0
4192                 endif
4193 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4194                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4195                 if (ees0tmp.gt.0) then
4196                   ees0mij=dsqrt(ees0tmp)
4197                 else
4198                   ees0mij=0
4199                 endif
4200 c               ees0mij=0.0D0
4201                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4202                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4203 C Diagnostics. Comment out or remove after debugging!
4204 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4205 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4206 c               ees0m(num_conti,i)=0.0D0
4207 C End diagnostics.
4208 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4209 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4210 C Angular derivatives of the contact function
4211                 ees0pij1=fac3/ees0pij
4212                 ees0mij1=fac3/ees0mij
4213                 fac3p=-3.0D0*fac3*rrmij
4214                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4215                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4216 c               ees0mij1=0.0D0
4217                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4218                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4219                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4220                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4221                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4222                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4223                 ecosap=ecosa1+ecosa2
4224                 ecosbp=ecosb1+ecosb2
4225                 ecosgp=ecosg1+ecosg2
4226                 ecosam=ecosa1-ecosa2
4227                 ecosbm=ecosb1-ecosb2
4228                 ecosgm=ecosg1-ecosg2
4229 C Diagnostics
4230 c               ecosap=ecosa1
4231 c               ecosbp=ecosb1
4232 c               ecosgp=ecosg1
4233 c               ecosam=0.0D0
4234 c               ecosbm=0.0D0
4235 c               ecosgm=0.0D0
4236 C End diagnostics
4237                 facont_hb(num_conti,i)=fcont
4238                 fprimcont=fprimcont/rij
4239 cd              facont_hb(num_conti,i)=1.0D0
4240 C Following line is for diagnostics.
4241 cd              fprimcont=0.0D0
4242                 do k=1,3
4243                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4244                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4245                 enddo
4246                 do k=1,3
4247                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4248                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4249                 enddo
4250                 gggp(1)=gggp(1)+ees0pijp*xj
4251                 gggp(2)=gggp(2)+ees0pijp*yj
4252                 gggp(3)=gggp(3)+ees0pijp*zj
4253                 gggm(1)=gggm(1)+ees0mijp*xj
4254                 gggm(2)=gggm(2)+ees0mijp*yj
4255                 gggm(3)=gggm(3)+ees0mijp*zj
4256 C Derivatives due to the contact function
4257                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4258                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4259                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4260                 do k=1,3
4261 c
4262 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4263 c          following the change of gradient-summation algorithm.
4264 c
4265 cgrad                  ghalfp=0.5D0*gggp(k)
4266 cgrad                  ghalfm=0.5D0*gggm(k)
4267                   gacontp_hb1(k,num_conti,i)=!ghalfp
4268      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4269      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4270                   gacontp_hb2(k,num_conti,i)=!ghalfp
4271      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4272      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4273                   gacontp_hb3(k,num_conti,i)=gggp(k)
4274                   gacontm_hb1(k,num_conti,i)=!ghalfm
4275      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4276      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4277                   gacontm_hb2(k,num_conti,i)=!ghalfm
4278      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4279      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4280                   gacontm_hb3(k,num_conti,i)=gggm(k)
4281                 enddo
4282 C Diagnostics. Comment out or remove after debugging!
4283 cdiag           do k=1,3
4284 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4285 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4286 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4287 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4288 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4289 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4290 cdiag           enddo
4291               ENDIF ! wcorr
4292               endif  ! num_conti.le.maxconts
4293             endif  ! fcont.gt.0
4294           endif    ! j.gt.i+1
4295           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4296             do k=1,4
4297               do l=1,3
4298                 ghalf=0.5d0*agg(l,k)
4299                 aggi(l,k)=aggi(l,k)+ghalf
4300                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4301                 aggj(l,k)=aggj(l,k)+ghalf
4302               enddo
4303             enddo
4304             if (j.eq.nres-1 .and. i.lt.j-2) then
4305               do k=1,4
4306                 do l=1,3
4307                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4308                 enddo
4309               enddo
4310             endif
4311           endif
4312 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4313       return
4314       end
4315 C-----------------------------------------------------------------------------
4316       subroutine eturn3(i,eello_turn3)
4317 C Third- and fourth-order contributions from turns
4318       implicit real*8 (a-h,o-z)
4319       include 'DIMENSIONS'
4320       include 'COMMON.IOUNITS'
4321       include 'COMMON.GEO'
4322       include 'COMMON.VAR'
4323       include 'COMMON.LOCAL'
4324       include 'COMMON.CHAIN'
4325       include 'COMMON.DERIV'
4326       include 'COMMON.INTERACT'
4327       include 'COMMON.CONTACTS'
4328       include 'COMMON.TORSION'
4329       include 'COMMON.VECTORS'
4330       include 'COMMON.FFIELD'
4331       include 'COMMON.CONTROL'
4332       dimension ggg(3)
4333       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4334      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4335      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4336      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4337      &  auxgmat2(2,2),auxgmatt2(2,2)
4338       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4339      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4340       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4341      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4342      &    num_conti,j1,j2
4343       j=i+2
4344 c      write (iout,*) "eturn3",i,j,j1,j2
4345       a_temp(1,1)=a22
4346       a_temp(1,2)=a23
4347       a_temp(2,1)=a32
4348       a_temp(2,2)=a33
4349 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4350 C
4351 C               Third-order contributions
4352 C
4353 C                 (i+2)o----(i+3)
4354 C                      | |
4355 C                      | |
4356 C                 (i+1)o----i
4357 C
4358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4359 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4360         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4361 c auxalary matices for theta gradient
4362 c auxalary matrix for i+1 and constant i+2
4363         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4364 c auxalary matrix for i+2 and constant i+1
4365         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4366         call transpose2(auxmat(1,1),auxmat1(1,1))
4367         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4368         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4369         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4370         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4371         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4372         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4373 C Derivatives in theta
4374         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4375      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4376         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4377      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4378
4379         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4380      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4381 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4382 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4383 cd     &    ' eello_turn3_num',4*eello_turn3_num
4384 C Derivatives in gamma(i)
4385         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4386         call transpose2(auxmat2(1,1),auxmat3(1,1))
4387         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4388         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4389 C Derivatives in gamma(i+1)
4390         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4391         call transpose2(auxmat2(1,1),auxmat3(1,1))
4392         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4393         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4394      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4395 C Cartesian derivatives
4396         do l=1,3
4397 c            ghalf1=0.5d0*agg(l,1)
4398 c            ghalf2=0.5d0*agg(l,2)
4399 c            ghalf3=0.5d0*agg(l,3)
4400 c            ghalf4=0.5d0*agg(l,4)
4401           a_temp(1,1)=aggi(l,1)!+ghalf1
4402           a_temp(1,2)=aggi(l,2)!+ghalf2
4403           a_temp(2,1)=aggi(l,3)!+ghalf3
4404           a_temp(2,2)=aggi(l,4)!+ghalf4
4405           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4406           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4407      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4408           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4409           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4410           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4411           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4412           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4413           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4414      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4415           a_temp(1,1)=aggj(l,1)!+ghalf1
4416           a_temp(1,2)=aggj(l,2)!+ghalf2
4417           a_temp(2,1)=aggj(l,3)!+ghalf3
4418           a_temp(2,2)=aggj(l,4)!+ghalf4
4419           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4420           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4421      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4422           a_temp(1,1)=aggj1(l,1)
4423           a_temp(1,2)=aggj1(l,2)
4424           a_temp(2,1)=aggj1(l,3)
4425           a_temp(2,2)=aggj1(l,4)
4426           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4427           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4428      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4429         enddo
4430       return
4431       end
4432 C-------------------------------------------------------------------------------
4433       subroutine eturn4(i,eello_turn4)
4434 C Third- and fourth-order contributions from turns
4435       implicit real*8 (a-h,o-z)
4436       include 'DIMENSIONS'
4437       include 'COMMON.IOUNITS'
4438       include 'COMMON.GEO'
4439       include 'COMMON.VAR'
4440       include 'COMMON.LOCAL'
4441       include 'COMMON.CHAIN'
4442       include 'COMMON.DERIV'
4443       include 'COMMON.INTERACT'
4444       include 'COMMON.CONTACTS'
4445       include 'COMMON.TORSION'
4446       include 'COMMON.VECTORS'
4447       include 'COMMON.FFIELD'
4448       include 'COMMON.CONTROL'
4449       dimension ggg(3)
4450       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4451      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4452      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4453      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4454      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4455      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4456      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4457       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4458      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4459       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4460      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4461      &    num_conti,j1,j2
4462       j=i+3
4463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4464 C
4465 C               Fourth-order contributions
4466 C
4467 C                 (i+3)o----(i+4)
4468 C                     /  |
4469 C               (i+2)o   |
4470 C                     \  |
4471 C                 (i+1)o----i
4472 C
4473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4474 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4475 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4476 c        write(iout,*)"WCHODZE W PROGRAM"
4477         a_temp(1,1)=a22
4478         a_temp(1,2)=a23
4479         a_temp(2,1)=a32
4480         a_temp(2,2)=a33
4481         iti1=itortyp(itype(i+1))
4482         iti2=itortyp(itype(i+2))
4483         iti3=itortyp(itype(i+3))
4484 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4485         call transpose2(EUg(1,1,i+1),e1t(1,1))
4486         call transpose2(Eug(1,1,i+2),e2t(1,1))
4487         call transpose2(Eug(1,1,i+3),e3t(1,1))
4488 C Ematrix derivative in theta
4489         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4490         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4491         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4492         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4493 c       eta1 in derivative theta
4494         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4495         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4496 c       auxgvec is derivative of Ub2 so i+3 theta
4497         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4498 c       auxalary matrix of E i+1
4499         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4500 c        s1=0.0
4501 c        gs1=0.0
4502         s1=scalar2(b1(1,i+2),auxvec(1))
4503 c derivative of theta i+2 with constant i+3
4504         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4505 c derivative of theta i+2 with constant i+2
4506         gs32=scalar2(b1(1,i+2),auxgvec(1))
4507 c derivative of E matix in theta of i+1
4508         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4509
4510         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4511 c       ea31 in derivative theta
4512         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4513         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4514 c auxilary matrix auxgvec of Ub2 with constant E matirx
4515         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4516 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4517         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4518
4519 c        s2=0.0
4520 c        gs2=0.0
4521         s2=scalar2(b1(1,i+1),auxvec(1))
4522 c derivative of theta i+1 with constant i+3
4523         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4524 c derivative of theta i+2 with constant i+1
4525         gs21=scalar2(b1(1,i+1),auxgvec(1))
4526 c derivative of theta i+3 with constant i+1
4527         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4528 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4529 c     &  gtb1(1,i+1)
4530         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4531 c two derivatives over diffetent matrices
4532 c gtae3e2 is derivative over i+3
4533         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4534 c ae3gte2 is derivative over i+2
4535         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4536         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4537 c three possible derivative over theta E matices
4538 c i+1
4539         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4540 c i+2
4541         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4542 c i+3
4543         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4544         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4545
4546         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4547         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4548         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4549
4550         eello_turn4=eello_turn4-(s1+s2+s3)
4551 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4552 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4553 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4554 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4555 cd     &    ' eello_turn4_num',8*eello_turn4_num
4556 #ifdef NEWCORR
4557         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4558      &                  -(gs13+gsE13+gsEE1)*wturn4
4559         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4560      &                    -(gs23+gs21+gsEE2)*wturn4
4561         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4562      &                    -(gs32+gsE31+gsEE3)*wturn4
4563 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4564 c     &   gs2
4565 #endif
4566         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4567      &      'eturn4',i,j,-(s1+s2+s3)
4568 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4569 c     &    ' eello_turn4_num',8*eello_turn4_num
4570 C Derivatives in gamma(i)
4571         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4572         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4573         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4574         s1=scalar2(b1(1,i+2),auxvec(1))
4575         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4576         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4577         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4578 C Derivatives in gamma(i+1)
4579         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4580         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4581         s2=scalar2(b1(1,i+1),auxvec(1))
4582         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4583         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4584         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4585         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4586 C Derivatives in gamma(i+2)
4587         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4588         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4589         s1=scalar2(b1(1,i+2),auxvec(1))
4590         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4591         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4592         s2=scalar2(b1(1,i+1),auxvec(1))
4593         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4594         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4595         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4596         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4597 C Cartesian derivatives
4598 C Derivatives of this turn contributions in DC(i+2)
4599         if (j.lt.nres-1) then
4600           do l=1,3
4601             a_temp(1,1)=agg(l,1)
4602             a_temp(1,2)=agg(l,2)
4603             a_temp(2,1)=agg(l,3)
4604             a_temp(2,2)=agg(l,4)
4605             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4606             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4607             s1=scalar2(b1(1,i+2),auxvec(1))
4608             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4609             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4610             s2=scalar2(b1(1,i+1),auxvec(1))
4611             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4612             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4613             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4614             ggg(l)=-(s1+s2+s3)
4615             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4616           enddo
4617         endif
4618 C Remaining derivatives of this turn contribution
4619         do l=1,3
4620           a_temp(1,1)=aggi(l,1)
4621           a_temp(1,2)=aggi(l,2)
4622           a_temp(2,1)=aggi(l,3)
4623           a_temp(2,2)=aggi(l,4)
4624           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4625           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4626           s1=scalar2(b1(1,i+2),auxvec(1))
4627           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4628           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4629           s2=scalar2(b1(1,i+1),auxvec(1))
4630           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4631           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4632           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4633           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4634           a_temp(1,1)=aggi1(l,1)
4635           a_temp(1,2)=aggi1(l,2)
4636           a_temp(2,1)=aggi1(l,3)
4637           a_temp(2,2)=aggi1(l,4)
4638           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4639           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4640           s1=scalar2(b1(1,i+2),auxvec(1))
4641           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4642           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4643           s2=scalar2(b1(1,i+1),auxvec(1))
4644           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4645           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4646           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4647           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4648           a_temp(1,1)=aggj(l,1)
4649           a_temp(1,2)=aggj(l,2)
4650           a_temp(2,1)=aggj(l,3)
4651           a_temp(2,2)=aggj(l,4)
4652           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4653           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4654           s1=scalar2(b1(1,i+2),auxvec(1))
4655           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4656           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4657           s2=scalar2(b1(1,i+1),auxvec(1))
4658           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4659           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4660           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4661           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4662           a_temp(1,1)=aggj1(l,1)
4663           a_temp(1,2)=aggj1(l,2)
4664           a_temp(2,1)=aggj1(l,3)
4665           a_temp(2,2)=aggj1(l,4)
4666           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4667           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4668           s1=scalar2(b1(1,i+2),auxvec(1))
4669           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4670           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4671           s2=scalar2(b1(1,i+1),auxvec(1))
4672           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4673           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4674           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4675 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4676           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4677         enddo
4678       return
4679       end
4680 C-----------------------------------------------------------------------------
4681       subroutine vecpr(u,v,w)
4682       implicit real*8(a-h,o-z)
4683       dimension u(3),v(3),w(3)
4684       w(1)=u(2)*v(3)-u(3)*v(2)
4685       w(2)=-u(1)*v(3)+u(3)*v(1)
4686       w(3)=u(1)*v(2)-u(2)*v(1)
4687       return
4688       end
4689 C-----------------------------------------------------------------------------
4690       subroutine unormderiv(u,ugrad,unorm,ungrad)
4691 C This subroutine computes the derivatives of a normalized vector u, given
4692 C the derivatives computed without normalization conditions, ugrad. Returns
4693 C ungrad.
4694       implicit none
4695       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4696       double precision vec(3)
4697       double precision scalar
4698       integer i,j
4699 c      write (2,*) 'ugrad',ugrad
4700 c      write (2,*) 'u',u
4701       do i=1,3
4702         vec(i)=scalar(ugrad(1,i),u(1))
4703       enddo
4704 c      write (2,*) 'vec',vec
4705       do i=1,3
4706         do j=1,3
4707           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4708         enddo
4709       enddo
4710 c      write (2,*) 'ungrad',ungrad
4711       return
4712       end
4713 C-----------------------------------------------------------------------------
4714       subroutine escp_soft_sphere(evdw2,evdw2_14)
4715 C
4716 C This subroutine calculates the excluded-volume interaction energy between
4717 C peptide-group centers and side chains and its gradient in virtual-bond and
4718 C side-chain vectors.
4719 C
4720       implicit real*8 (a-h,o-z)
4721       include 'DIMENSIONS'
4722       include 'COMMON.GEO'
4723       include 'COMMON.VAR'
4724       include 'COMMON.LOCAL'
4725       include 'COMMON.CHAIN'
4726       include 'COMMON.DERIV'
4727       include 'COMMON.INTERACT'
4728       include 'COMMON.FFIELD'
4729       include 'COMMON.IOUNITS'
4730       include 'COMMON.CONTROL'
4731       dimension ggg(3)
4732       evdw2=0.0D0
4733       evdw2_14=0.0d0
4734       r0_scp=4.5d0
4735 cd    print '(a)','Enter ESCP'
4736 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4737 C      do xshift=-1,1
4738 C      do yshift=-1,1
4739 C      do zshift=-1,1
4740       do i=iatscp_s,iatscp_e
4741         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4742         iteli=itel(i)
4743         xi=0.5D0*(c(1,i)+c(1,i+1))
4744         yi=0.5D0*(c(2,i)+c(2,i+1))
4745         zi=0.5D0*(c(3,i)+c(3,i+1))
4746 C Return atom into box, boxxsize is size of box in x dimension
4747 c  134   continue
4748 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4749 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4750 C Condition for being inside the proper box
4751 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4752 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4753 c        go to 134
4754 c        endif
4755 c  135   continue
4756 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4757 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4758 C Condition for being inside the proper box
4759 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4760 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4761 c        go to 135
4762 c c       endif
4763 c  136   continue
4764 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4765 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4766 cC Condition for being inside the proper box
4767 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4768 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4769 c        go to 136
4770 c        endif
4771           xi=mod(xi,boxxsize)
4772           if (xi.lt.0) xi=xi+boxxsize
4773           yi=mod(yi,boxysize)
4774           if (yi.lt.0) yi=yi+boxysize
4775           zi=mod(zi,boxzsize)
4776           if (zi.lt.0) zi=zi+boxzsize
4777 C          xi=xi+xshift*boxxsize
4778 C          yi=yi+yshift*boxysize
4779 C          zi=zi+zshift*boxzsize
4780         do iint=1,nscp_gr(i)
4781
4782         do j=iscpstart(i,iint),iscpend(i,iint)
4783           if (itype(j).eq.ntyp1) cycle
4784           itypj=iabs(itype(j))
4785 C Uncomment following three lines for SC-p interactions
4786 c         xj=c(1,nres+j)-xi
4787 c         yj=c(2,nres+j)-yi
4788 c         zj=c(3,nres+j)-zi
4789 C Uncomment following three lines for Ca-p interactions
4790           xj=c(1,j)
4791           yj=c(2,j)
4792           zj=c(3,j)
4793 c  174   continue
4794 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4795 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4796 C Condition for being inside the proper box
4797 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4798 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4799 c        go to 174
4800 c        endif
4801 c  175   continue
4802 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4803 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4804 cC Condition for being inside the proper box
4805 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4806 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4807 c        go to 175
4808 c        endif
4809 c  176   continue
4810 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4811 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4812 C Condition for being inside the proper box
4813 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4814 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4815 c        go to 176
4816           xj=mod(xj,boxxsize)
4817           if (xj.lt.0) xj=xj+boxxsize
4818           yj=mod(yj,boxysize)
4819           if (yj.lt.0) yj=yj+boxysize
4820           zj=mod(zj,boxzsize)
4821           if (zj.lt.0) zj=zj+boxzsize
4822       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4823       xj_safe=xj
4824       yj_safe=yj
4825       zj_safe=zj
4826       subchap=0
4827       do xshift=-1,1
4828       do yshift=-1,1
4829       do zshift=-1,1
4830           xj=xj_safe+xshift*boxxsize
4831           yj=yj_safe+yshift*boxysize
4832           zj=zj_safe+zshift*boxzsize
4833           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4834           if(dist_temp.lt.dist_init) then
4835             dist_init=dist_temp
4836             xj_temp=xj
4837             yj_temp=yj
4838             zj_temp=zj
4839             subchap=1
4840           endif
4841        enddo
4842        enddo
4843        enddo
4844        if (subchap.eq.1) then
4845           xj=xj_temp-xi
4846           yj=yj_temp-yi
4847           zj=zj_temp-zi
4848        else
4849           xj=xj_safe-xi
4850           yj=yj_safe-yi
4851           zj=zj_safe-zi
4852        endif
4853 c c       endif
4854 C          xj=xj-xi
4855 C          yj=yj-yi
4856 C          zj=zj-zi
4857           rij=xj*xj+yj*yj+zj*zj
4858
4859           r0ij=r0_scp
4860           r0ijsq=r0ij*r0ij
4861           if (rij.lt.r0ijsq) then
4862             evdwij=0.25d0*(rij-r0ijsq)**2
4863             fac=rij-r0ijsq
4864           else
4865             evdwij=0.0d0
4866             fac=0.0d0
4867           endif
4868           evdw2=evdw2+evdwij
4869 C
4870 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4871 C
4872           ggg(1)=xj*fac
4873           ggg(2)=yj*fac
4874           ggg(3)=zj*fac
4875 cgrad          if (j.lt.i) then
4876 cd          write (iout,*) 'j<i'
4877 C Uncomment following three lines for SC-p interactions
4878 c           do k=1,3
4879 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4880 c           enddo
4881 cgrad          else
4882 cd          write (iout,*) 'j>i'
4883 cgrad            do k=1,3
4884 cgrad              ggg(k)=-ggg(k)
4885 C Uncomment following line for SC-p interactions
4886 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4887 cgrad            enddo
4888 cgrad          endif
4889 cgrad          do k=1,3
4890 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4891 cgrad          enddo
4892 cgrad          kstart=min0(i+1,j)
4893 cgrad          kend=max0(i-1,j-1)
4894 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4895 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4896 cgrad          do k=kstart,kend
4897 cgrad            do l=1,3
4898 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4899 cgrad            enddo
4900 cgrad          enddo
4901           do k=1,3
4902             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4903             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4904           enddo
4905         enddo
4906
4907         enddo ! iint
4908       enddo ! i
4909 C      enddo !zshift
4910 C      enddo !yshift
4911 C      enddo !xshift
4912       return
4913       end
4914 C-----------------------------------------------------------------------------
4915       subroutine escp(evdw2,evdw2_14)
4916 C
4917 C This subroutine calculates the excluded-volume interaction energy between
4918 C peptide-group centers and side chains and its gradient in virtual-bond and
4919 C side-chain vectors.
4920 C
4921       implicit real*8 (a-h,o-z)
4922       include 'DIMENSIONS'
4923       include 'COMMON.GEO'
4924       include 'COMMON.VAR'
4925       include 'COMMON.LOCAL'
4926       include 'COMMON.CHAIN'
4927       include 'COMMON.DERIV'
4928       include 'COMMON.INTERACT'
4929       include 'COMMON.FFIELD'
4930       include 'COMMON.IOUNITS'
4931       include 'COMMON.CONTROL'
4932       include 'COMMON.SPLITELE'
4933       dimension ggg(3)
4934       evdw2=0.0D0
4935       evdw2_14=0.0d0
4936 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4937 cd    print '(a)','Enter ESCP'
4938 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4939 C      do xshift=-1,1
4940 C      do yshift=-1,1
4941 C      do zshift=-1,1
4942       do i=iatscp_s,iatscp_e
4943         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4944         iteli=itel(i)
4945         xi=0.5D0*(c(1,i)+c(1,i+1))
4946         yi=0.5D0*(c(2,i)+c(2,i+1))
4947         zi=0.5D0*(c(3,i)+c(3,i+1))
4948           xi=mod(xi,boxxsize)
4949           if (xi.lt.0) xi=xi+boxxsize
4950           yi=mod(yi,boxysize)
4951           if (yi.lt.0) yi=yi+boxysize
4952           zi=mod(zi,boxzsize)
4953           if (zi.lt.0) zi=zi+boxzsize
4954 c          xi=xi+xshift*boxxsize
4955 c          yi=yi+yshift*boxysize
4956 c          zi=zi+zshift*boxzsize
4957 c        print *,xi,yi,zi,'polozenie i'
4958 C Return atom into box, boxxsize is size of box in x dimension
4959 c  134   continue
4960 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4961 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4962 C Condition for being inside the proper box
4963 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4964 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4965 c        go to 134
4966 c        endif
4967 c  135   continue
4968 c          print *,xi,boxxsize,"pierwszy"
4969
4970 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4971 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4972 C Condition for being inside the proper box
4973 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4974 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4975 c        go to 135
4976 c        endif
4977 c  136   continue
4978 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4979 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4980 C Condition for being inside the proper box
4981 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4982 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4983 c        go to 136
4984 c        endif
4985         do iint=1,nscp_gr(i)
4986
4987         do j=iscpstart(i,iint),iscpend(i,iint)
4988           itypj=iabs(itype(j))
4989           if (itypj.eq.ntyp1) cycle
4990 C Uncomment following three lines for SC-p interactions
4991 c         xj=c(1,nres+j)-xi
4992 c         yj=c(2,nres+j)-yi
4993 c         zj=c(3,nres+j)-zi
4994 C Uncomment following three lines for Ca-p interactions
4995           xj=c(1,j)
4996           yj=c(2,j)
4997           zj=c(3,j)
4998           xj=mod(xj,boxxsize)
4999           if (xj.lt.0) xj=xj+boxxsize
5000           yj=mod(yj,boxysize)
5001           if (yj.lt.0) yj=yj+boxysize
5002           zj=mod(zj,boxzsize)
5003           if (zj.lt.0) zj=zj+boxzsize
5004 c  174   continue
5005 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5006 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5007 C Condition for being inside the proper box
5008 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5009 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5010 c        go to 174
5011 c        endif
5012 c  175   continue
5013 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5014 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5015 cC Condition for being inside the proper box
5016 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5017 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5018 c        go to 175
5019 c        endif
5020 c  176   continue
5021 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5022 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5023 C Condition for being inside the proper box
5024 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5025 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5026 c        go to 176
5027 c        endif
5028 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5029       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5030       xj_safe=xj
5031       yj_safe=yj
5032       zj_safe=zj
5033       subchap=0
5034       do xshift=-1,1
5035       do yshift=-1,1
5036       do zshift=-1,1
5037           xj=xj_safe+xshift*boxxsize
5038           yj=yj_safe+yshift*boxysize
5039           zj=zj_safe+zshift*boxzsize
5040           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5041           if(dist_temp.lt.dist_init) then
5042             dist_init=dist_temp
5043             xj_temp=xj
5044             yj_temp=yj
5045             zj_temp=zj
5046             subchap=1
5047           endif
5048        enddo
5049        enddo
5050        enddo
5051        if (subchap.eq.1) then
5052           xj=xj_temp-xi
5053           yj=yj_temp-yi
5054           zj=zj_temp-zi
5055        else
5056           xj=xj_safe-xi
5057           yj=yj_safe-yi
5058           zj=zj_safe-zi
5059        endif
5060 c          print *,xj,yj,zj,'polozenie j'
5061           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5062 c          print *,rrij
5063           sss=sscale(1.0d0/(dsqrt(rrij)))
5064 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5065 c          if (sss.eq.0) print *,'czasem jest OK'
5066           if (sss.le.0.0d0) cycle
5067           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5068           fac=rrij**expon2
5069           e1=fac*fac*aad(itypj,iteli)
5070           e2=fac*bad(itypj,iteli)
5071           if (iabs(j-i) .le. 2) then
5072             e1=scal14*e1
5073             e2=scal14*e2
5074             evdw2_14=evdw2_14+(e1+e2)*sss
5075           endif
5076           evdwij=e1+e2
5077           evdw2=evdw2+evdwij*sss
5078           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5079      &        'evdw2',i,j,evdwij
5080 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5081 C
5082 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5083 C
5084           fac=-(evdwij+e1)*rrij*sss
5085           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5086           ggg(1)=xj*fac
5087           ggg(2)=yj*fac
5088           ggg(3)=zj*fac
5089 cgrad          if (j.lt.i) then
5090 cd          write (iout,*) 'j<i'
5091 C Uncomment following three lines for SC-p interactions
5092 c           do k=1,3
5093 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5094 c           enddo
5095 cgrad          else
5096 cd          write (iout,*) 'j>i'
5097 cgrad            do k=1,3
5098 cgrad              ggg(k)=-ggg(k)
5099 C Uncomment following line for SC-p interactions
5100 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5101 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5102 cgrad            enddo
5103 cgrad          endif
5104 cgrad          do k=1,3
5105 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5106 cgrad          enddo
5107 cgrad          kstart=min0(i+1,j)
5108 cgrad          kend=max0(i-1,j-1)
5109 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5110 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5111 cgrad          do k=kstart,kend
5112 cgrad            do l=1,3
5113 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5114 cgrad            enddo
5115 cgrad          enddo
5116           do k=1,3
5117             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5118             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5119           enddo
5120 c        endif !endif for sscale cutoff
5121         enddo ! j
5122
5123         enddo ! iint
5124       enddo ! i
5125 c      enddo !zshift
5126 c      enddo !yshift
5127 c      enddo !xshift
5128       do i=1,nct
5129         do j=1,3
5130           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5131           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5132           gradx_scp(j,i)=expon*gradx_scp(j,i)
5133         enddo
5134       enddo
5135 C******************************************************************************
5136 C
5137 C                              N O T E !!!
5138 C
5139 C To save time the factor EXPON has been extracted from ALL components
5140 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5141 C use!
5142 C
5143 C******************************************************************************
5144       return
5145       end
5146 C--------------------------------------------------------------------------
5147       subroutine edis(ehpb)
5148 C
5149 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5150 C
5151       implicit real*8 (a-h,o-z)
5152       include 'DIMENSIONS'
5153       include 'COMMON.SBRIDGE'
5154       include 'COMMON.CHAIN'
5155       include 'COMMON.DERIV'
5156       include 'COMMON.VAR'
5157       include 'COMMON.INTERACT'
5158       include 'COMMON.IOUNITS'
5159       dimension ggg(3)
5160       ehpb=0.0D0
5161 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5162 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5163       if (link_end.eq.0) return
5164       do i=link_start,link_end
5165 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5166 C CA-CA distance used in regularization of structure.
5167         ii=ihpb(i)
5168         jj=jhpb(i)
5169 C iii and jjj point to the residues for which the distance is assigned.
5170         if (ii.gt.nres) then
5171           iii=ii-nres
5172           jjj=jj-nres
5173         else
5174           iii=ii
5175           jjj=jj
5176         endif
5177 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5178 c     &    dhpb(i),dhpb1(i),forcon(i)
5179 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5180 C    distance and angle dependent SS bond potential.
5181 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5182 C     & iabs(itype(jjj)).eq.1) then
5183 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5184 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5185         if (.not.dyn_ss .and. i.le.nss) then
5186 C 15/02/13 CC dynamic SSbond - additional check
5187          if (ii.gt.nres
5188      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5189           call ssbond_ene(iii,jjj,eij)
5190           ehpb=ehpb+2*eij
5191          endif
5192 cd          write (iout,*) "eij",eij
5193         else
5194 C Calculate the distance between the two points and its difference from the
5195 C target distance.
5196           dd=dist(ii,jj)
5197             rdis=dd-dhpb(i)
5198 C Get the force constant corresponding to this distance.
5199             waga=forcon(i)
5200 C Calculate the contribution to energy.
5201             ehpb=ehpb+waga*rdis*rdis
5202 C
5203 C Evaluate gradient.
5204 C
5205             fac=waga*rdis/dd
5206 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5207 cd   &   ' waga=',waga,' fac=',fac
5208             do j=1,3
5209               ggg(j)=fac*(c(j,jj)-c(j,ii))
5210             enddo
5211 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5212 C If this is a SC-SC distance, we need to calculate the contributions to the
5213 C Cartesian gradient in the SC vectors (ghpbx).
5214           if (iii.lt.ii) then
5215           do j=1,3
5216             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5217             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5218           enddo
5219           endif
5220 cgrad        do j=iii,jjj-1
5221 cgrad          do k=1,3
5222 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5223 cgrad          enddo
5224 cgrad        enddo
5225           do k=1,3
5226             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5227             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5228           enddo
5229         endif
5230       enddo
5231       ehpb=0.5D0*ehpb
5232       return
5233       end
5234 C--------------------------------------------------------------------------
5235       subroutine ssbond_ene(i,j,eij)
5236 C
5237 C Calculate the distance and angle dependent SS-bond potential energy
5238 C using a free-energy function derived based on RHF/6-31G** ab initio
5239 C calculations of diethyl disulfide.
5240 C
5241 C A. Liwo and U. Kozlowska, 11/24/03
5242 C
5243       implicit real*8 (a-h,o-z)
5244       include 'DIMENSIONS'
5245       include 'COMMON.SBRIDGE'
5246       include 'COMMON.CHAIN'
5247       include 'COMMON.DERIV'
5248       include 'COMMON.LOCAL'
5249       include 'COMMON.INTERACT'
5250       include 'COMMON.VAR'
5251       include 'COMMON.IOUNITS'
5252       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5253       itypi=iabs(itype(i))
5254       xi=c(1,nres+i)
5255       yi=c(2,nres+i)
5256       zi=c(3,nres+i)
5257       dxi=dc_norm(1,nres+i)
5258       dyi=dc_norm(2,nres+i)
5259       dzi=dc_norm(3,nres+i)
5260 c      dsci_inv=dsc_inv(itypi)
5261       dsci_inv=vbld_inv(nres+i)
5262       itypj=iabs(itype(j))
5263 c      dscj_inv=dsc_inv(itypj)
5264       dscj_inv=vbld_inv(nres+j)
5265       xj=c(1,nres+j)-xi
5266       yj=c(2,nres+j)-yi
5267       zj=c(3,nres+j)-zi
5268       dxj=dc_norm(1,nres+j)
5269       dyj=dc_norm(2,nres+j)
5270       dzj=dc_norm(3,nres+j)
5271       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5272       rij=dsqrt(rrij)
5273       erij(1)=xj*rij
5274       erij(2)=yj*rij
5275       erij(3)=zj*rij
5276       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5277       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5278       om12=dxi*dxj+dyi*dyj+dzi*dzj
5279       do k=1,3
5280         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5281         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5282       enddo
5283       rij=1.0d0/rij
5284       deltad=rij-d0cm
5285       deltat1=1.0d0-om1
5286       deltat2=1.0d0+om2
5287       deltat12=om2-om1+2.0d0
5288       cosphi=om12-om1*om2
5289       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5290      &  +akct*deltad*deltat12
5291      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5292 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5293 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5294 c     &  " deltat12",deltat12," eij",eij
5295       ed=2*akcm*deltad+akct*deltat12
5296       pom1=akct*deltad
5297       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5298       eom1=-2*akth*deltat1-pom1-om2*pom2
5299       eom2= 2*akth*deltat2+pom1-om1*pom2
5300       eom12=pom2
5301       do k=1,3
5302         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5303         ghpbx(k,i)=ghpbx(k,i)-ggk
5304      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5305      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5306         ghpbx(k,j)=ghpbx(k,j)+ggk
5307      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5308      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5309         ghpbc(k,i)=ghpbc(k,i)-ggk
5310         ghpbc(k,j)=ghpbc(k,j)+ggk
5311       enddo
5312 C
5313 C Calculate the components of the gradient in DC and X
5314 C
5315 cgrad      do k=i,j-1
5316 cgrad        do l=1,3
5317 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5318 cgrad        enddo
5319 cgrad      enddo
5320       return
5321       end
5322 C--------------------------------------------------------------------------
5323       subroutine ebond(estr)
5324 c
5325 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5326 c
5327       implicit real*8 (a-h,o-z)
5328       include 'DIMENSIONS'
5329       include 'COMMON.LOCAL'
5330       include 'COMMON.GEO'
5331       include 'COMMON.INTERACT'
5332       include 'COMMON.DERIV'
5333       include 'COMMON.VAR'
5334       include 'COMMON.CHAIN'
5335       include 'COMMON.IOUNITS'
5336       include 'COMMON.NAMES'
5337       include 'COMMON.FFIELD'
5338       include 'COMMON.CONTROL'
5339       include 'COMMON.SETUP'
5340       double precision u(3),ud(3)
5341       estr=0.0d0
5342       estr1=0.0d0
5343       do i=ibondp_start,ibondp_end
5344         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5345 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5346 c          do j=1,3
5347 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5348 c     &      *dc(j,i-1)/vbld(i)
5349 c          enddo
5350 c          if (energy_dec) write(iout,*)
5351 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5352 c        else
5353 C       Checking if it involves dummy (NH3+ or COO-) group
5354          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5355 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5356         diff = vbld(i)-vbldpDUM
5357          else
5358 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5359         diff = vbld(i)-vbldp0
5360          endif
5361         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5362      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5363         estr=estr+diff*diff
5364         do j=1,3
5365           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5366         enddo
5367 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5368 c        endif
5369       enddo
5370       estr=0.5d0*AKP*estr+estr1
5371 c
5372 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5373 c
5374       do i=ibond_start,ibond_end
5375         iti=iabs(itype(i))
5376         if (iti.ne.10 .and. iti.ne.ntyp1) then
5377           nbi=nbondterm(iti)
5378           if (nbi.eq.1) then
5379             diff=vbld(i+nres)-vbldsc0(1,iti)
5380             if (energy_dec)  write (iout,*)
5381      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5382      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5383             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5384             do j=1,3
5385               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5386             enddo
5387           else
5388             do j=1,nbi
5389               diff=vbld(i+nres)-vbldsc0(j,iti)
5390               ud(j)=aksc(j,iti)*diff
5391               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5392             enddo
5393             uprod=u(1)
5394             do j=2,nbi
5395               uprod=uprod*u(j)
5396             enddo
5397             usum=0.0d0
5398             usumsqder=0.0d0
5399             do j=1,nbi
5400               uprod1=1.0d0
5401               uprod2=1.0d0
5402               do k=1,nbi
5403                 if (k.ne.j) then
5404                   uprod1=uprod1*u(k)
5405                   uprod2=uprod2*u(k)*u(k)
5406                 endif
5407               enddo
5408               usum=usum+uprod1
5409               usumsqder=usumsqder+ud(j)*uprod2
5410             enddo
5411             estr=estr+uprod/usum
5412             do j=1,3
5413              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5414             enddo
5415           endif
5416         endif
5417       enddo
5418       return
5419       end
5420 #ifdef CRYST_THETA
5421 C--------------------------------------------------------------------------
5422       subroutine ebend(etheta)
5423 C
5424 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5425 C angles gamma and its derivatives in consecutive thetas and gammas.
5426 C
5427       implicit real*8 (a-h,o-z)
5428       include 'DIMENSIONS'
5429       include 'COMMON.LOCAL'
5430       include 'COMMON.GEO'
5431       include 'COMMON.INTERACT'
5432       include 'COMMON.DERIV'
5433       include 'COMMON.VAR'
5434       include 'COMMON.CHAIN'
5435       include 'COMMON.IOUNITS'
5436       include 'COMMON.NAMES'
5437       include 'COMMON.FFIELD'
5438       include 'COMMON.CONTROL'
5439       common /calcthet/ term1,term2,termm,diffak,ratak,
5440      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5441      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5442       double precision y(2),z(2)
5443       delta=0.02d0*pi
5444 c      time11=dexp(-2*time)
5445 c      time12=1.0d0
5446       etheta=0.0D0
5447 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5448       do i=ithet_start,ithet_end
5449         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5450      &  .or.itype(i).eq.ntyp1) cycle
5451 C Zero the energy function and its derivative at 0 or pi.
5452         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5453         it=itype(i-1)
5454         ichir1=isign(1,itype(i-2))
5455         ichir2=isign(1,itype(i))
5456          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5457          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5458          if (itype(i-1).eq.10) then
5459           itype1=isign(10,itype(i-2))
5460           ichir11=isign(1,itype(i-2))
5461           ichir12=isign(1,itype(i-2))
5462           itype2=isign(10,itype(i))
5463           ichir21=isign(1,itype(i))
5464           ichir22=isign(1,itype(i))
5465          endif
5466
5467         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5468 #ifdef OSF
5469           phii=phi(i)
5470           if (phii.ne.phii) phii=150.0
5471 #else
5472           phii=phi(i)
5473 #endif
5474           y(1)=dcos(phii)
5475           y(2)=dsin(phii)
5476         else
5477           y(1)=0.0D0
5478           y(2)=0.0D0
5479         endif
5480         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5481 #ifdef OSF
5482           phii1=phi(i+1)
5483           if (phii1.ne.phii1) phii1=150.0
5484           phii1=pinorm(phii1)
5485           z(1)=cos(phii1)
5486 #else
5487           phii1=phi(i+1)
5488 #endif
5489           z(1)=dcos(phii1)
5490           z(2)=dsin(phii1)
5491         else
5492           z(1)=0.0D0
5493           z(2)=0.0D0
5494         endif
5495 C Calculate the "mean" value of theta from the part of the distribution
5496 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5497 C In following comments this theta will be referred to as t_c.
5498         thet_pred_mean=0.0d0
5499         do k=1,2
5500             athetk=athet(k,it,ichir1,ichir2)
5501             bthetk=bthet(k,it,ichir1,ichir2)
5502           if (it.eq.10) then
5503              athetk=athet(k,itype1,ichir11,ichir12)
5504              bthetk=bthet(k,itype2,ichir21,ichir22)
5505           endif
5506          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5507 c         write(iout,*) 'chuj tu', y(k),z(k)
5508         enddo
5509         dthett=thet_pred_mean*ssd
5510         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5511 C Derivatives of the "mean" values in gamma1 and gamma2.
5512         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5513      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5514          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5515      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5516          if (it.eq.10) then
5517       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5518      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5519         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5520      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5521          endif
5522         if (theta(i).gt.pi-delta) then
5523           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5524      &         E_tc0)
5525           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5526           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5527           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5528      &        E_theta)
5529           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5530      &        E_tc)
5531         else if (theta(i).lt.delta) then
5532           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5533           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5534           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5535      &        E_theta)
5536           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5537           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5538      &        E_tc)
5539         else
5540           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5541      &        E_theta,E_tc)
5542         endif
5543         etheta=etheta+ethetai
5544         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5545      &      'ebend',i,ethetai,theta(i),itype(i)
5546         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5547         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5548         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5549       enddo
5550 C Ufff.... We've done all this!!!
5551       return
5552       end
5553 C---------------------------------------------------------------------------
5554       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5555      &     E_tc)
5556       implicit real*8 (a-h,o-z)
5557       include 'DIMENSIONS'
5558       include 'COMMON.LOCAL'
5559       include 'COMMON.IOUNITS'
5560       common /calcthet/ term1,term2,termm,diffak,ratak,
5561      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5562      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5563 C Calculate the contributions to both Gaussian lobes.
5564 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5565 C The "polynomial part" of the "standard deviation" of this part of
5566 C the distributioni.
5567 ccc        write (iout,*) thetai,thet_pred_mean
5568         sig=polthet(3,it)
5569         do j=2,0,-1
5570           sig=sig*thet_pred_mean+polthet(j,it)
5571         enddo
5572 C Derivative of the "interior part" of the "standard deviation of the"
5573 C gamma-dependent Gaussian lobe in t_c.
5574         sigtc=3*polthet(3,it)
5575         do j=2,1,-1
5576           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5577         enddo
5578         sigtc=sig*sigtc
5579 C Set the parameters of both Gaussian lobes of the distribution.
5580 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5581         fac=sig*sig+sigc0(it)
5582         sigcsq=fac+fac
5583         sigc=1.0D0/sigcsq
5584 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5585         sigsqtc=-4.0D0*sigcsq*sigtc
5586 c       print *,i,sig,sigtc,sigsqtc
5587 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5588         sigtc=-sigtc/(fac*fac)
5589 C Following variable is sigma(t_c)**(-2)
5590         sigcsq=sigcsq*sigcsq
5591         sig0i=sig0(it)
5592         sig0inv=1.0D0/sig0i**2
5593         delthec=thetai-thet_pred_mean
5594         delthe0=thetai-theta0i
5595         term1=-0.5D0*sigcsq*delthec*delthec
5596         term2=-0.5D0*sig0inv*delthe0*delthe0
5597 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5598 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5599 C NaNs in taking the logarithm. We extract the largest exponent which is added
5600 C to the energy (this being the log of the distribution) at the end of energy
5601 C term evaluation for this virtual-bond angle.
5602         if (term1.gt.term2) then
5603           termm=term1
5604           term2=dexp(term2-termm)
5605           term1=1.0d0
5606         else
5607           termm=term2
5608           term1=dexp(term1-termm)
5609           term2=1.0d0
5610         endif
5611 C The ratio between the gamma-independent and gamma-dependent lobes of
5612 C the distribution is a Gaussian function of thet_pred_mean too.
5613         diffak=gthet(2,it)-thet_pred_mean
5614         ratak=diffak/gthet(3,it)**2
5615         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5616 C Let's differentiate it in thet_pred_mean NOW.
5617         aktc=ak*ratak
5618 C Now put together the distribution terms to make complete distribution.
5619         termexp=term1+ak*term2
5620         termpre=sigc+ak*sig0i
5621 C Contribution of the bending energy from this theta is just the -log of
5622 C the sum of the contributions from the two lobes and the pre-exponential
5623 C factor. Simple enough, isn't it?
5624         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5625 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5626 C NOW the derivatives!!!
5627 C 6/6/97 Take into account the deformation.
5628         E_theta=(delthec*sigcsq*term1
5629      &       +ak*delthe0*sig0inv*term2)/termexp
5630         E_tc=((sigtc+aktc*sig0i)/termpre
5631      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5632      &       aktc*term2)/termexp)
5633       return
5634       end
5635 c-----------------------------------------------------------------------------
5636       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5637       implicit real*8 (a-h,o-z)
5638       include 'DIMENSIONS'
5639       include 'COMMON.LOCAL'
5640       include 'COMMON.IOUNITS'
5641       common /calcthet/ term1,term2,termm,diffak,ratak,
5642      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5643      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5644       delthec=thetai-thet_pred_mean
5645       delthe0=thetai-theta0i
5646 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5647       t3 = thetai-thet_pred_mean
5648       t6 = t3**2
5649       t9 = term1
5650       t12 = t3*sigcsq
5651       t14 = t12+t6*sigsqtc
5652       t16 = 1.0d0
5653       t21 = thetai-theta0i
5654       t23 = t21**2
5655       t26 = term2
5656       t27 = t21*t26
5657       t32 = termexp
5658       t40 = t32**2
5659       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5660      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5661      & *(-t12*t9-ak*sig0inv*t27)
5662       return
5663       end
5664 #else
5665 C--------------------------------------------------------------------------
5666       subroutine ebend(etheta)
5667 C
5668 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5669 C angles gamma and its derivatives in consecutive thetas and gammas.
5670 C ab initio-derived potentials from
5671 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5672 C
5673       implicit real*8 (a-h,o-z)
5674       include 'DIMENSIONS'
5675       include 'COMMON.LOCAL'
5676       include 'COMMON.GEO'
5677       include 'COMMON.INTERACT'
5678       include 'COMMON.DERIV'
5679       include 'COMMON.VAR'
5680       include 'COMMON.CHAIN'
5681       include 'COMMON.IOUNITS'
5682       include 'COMMON.NAMES'
5683       include 'COMMON.FFIELD'
5684       include 'COMMON.CONTROL'
5685       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5686      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5687      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5688      & sinph1ph2(maxdouble,maxdouble)
5689       logical lprn /.false./, lprn1 /.false./
5690       etheta=0.0D0
5691       do i=ithet_start,ithet_end
5692 c        if (i.eq.2) cycle
5693 c        print *,i,itype(i-1),itype(i),itype(i-2)
5694         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5695      &  .or.(itype(i).eq.ntyp1)) cycle
5696 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5697
5698         if (iabs(itype(i+1)).eq.20) iblock=2
5699         if (iabs(itype(i+1)).ne.20) iblock=1
5700         dethetai=0.0d0
5701         dephii=0.0d0
5702         dephii1=0.0d0
5703         theti2=0.5d0*theta(i)
5704         ityp2=ithetyp((itype(i-1)))
5705         do k=1,nntheterm
5706           coskt(k)=dcos(k*theti2)
5707           sinkt(k)=dsin(k*theti2)
5708         enddo
5709         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5710 #ifdef OSF
5711           phii=phi(i)
5712           if (phii.ne.phii) phii=150.0
5713 #else
5714           phii=phi(i)
5715 #endif
5716           ityp1=ithetyp((itype(i-2)))
5717 C propagation of chirality for glycine type
5718           do k=1,nsingle
5719             cosph1(k)=dcos(k*phii)
5720             sinph1(k)=dsin(k*phii)
5721           enddo
5722         else
5723           phii=0.0d0
5724           ityp1=ithetyp(itype(i-2))
5725           do k=1,nsingle
5726             cosph1(k)=0.0d0
5727             sinph1(k)=0.0d0
5728           enddo
5729         endif
5730         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5731 #ifdef OSF
5732           phii1=phi(i+1)
5733           if (phii1.ne.phii1) phii1=150.0
5734           phii1=pinorm(phii1)
5735 #else
5736           phii1=phi(i+1)
5737 #endif
5738           ityp3=ithetyp((itype(i)))
5739           do k=1,nsingle
5740             cosph2(k)=dcos(k*phii1)
5741             sinph2(k)=dsin(k*phii1)
5742           enddo
5743         else
5744           phii1=0.0d0
5745           ityp3=ithetyp(itype(i))
5746           do k=1,nsingle
5747             cosph2(k)=0.0d0
5748             sinph2(k)=0.0d0
5749           enddo
5750         endif
5751         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5752         do k=1,ndouble
5753           do l=1,k-1
5754             ccl=cosph1(l)*cosph2(k-l)
5755             ssl=sinph1(l)*sinph2(k-l)
5756             scl=sinph1(l)*cosph2(k-l)
5757             csl=cosph1(l)*sinph2(k-l)
5758             cosph1ph2(l,k)=ccl-ssl
5759             cosph1ph2(k,l)=ccl+ssl
5760             sinph1ph2(l,k)=scl+csl
5761             sinph1ph2(k,l)=scl-csl
5762           enddo
5763         enddo
5764         if (lprn) then
5765         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5766      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5767         write (iout,*) "coskt and sinkt"
5768         do k=1,nntheterm
5769           write (iout,*) k,coskt(k),sinkt(k)
5770         enddo
5771         endif
5772         do k=1,ntheterm
5773           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5774           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5775      &      *coskt(k)
5776           if (lprn)
5777      &    write (iout,*) "k",k,"
5778      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5779      &     " ethetai",ethetai
5780         enddo
5781         if (lprn) then
5782         write (iout,*) "cosph and sinph"
5783         do k=1,nsingle
5784           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5785         enddo
5786         write (iout,*) "cosph1ph2 and sinph2ph2"
5787         do k=2,ndouble
5788           do l=1,k-1
5789             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5790      &         sinph1ph2(l,k),sinph1ph2(k,l)
5791           enddo
5792         enddo
5793         write(iout,*) "ethetai",ethetai
5794         endif
5795         do m=1,ntheterm2
5796           do k=1,nsingle
5797             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5798      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5799      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5800      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5801             ethetai=ethetai+sinkt(m)*aux
5802             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5803             dephii=dephii+k*sinkt(m)*(
5804      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5805      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5806             dephii1=dephii1+k*sinkt(m)*(
5807      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5808      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5809             if (lprn)
5810      &      write (iout,*) "m",m," k",k," bbthet",
5811      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5812      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5813      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5814      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5815           enddo
5816         enddo
5817         if (lprn)
5818      &  write(iout,*) "ethetai",ethetai
5819         do m=1,ntheterm3
5820           do k=2,ndouble
5821             do l=1,k-1
5822               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5823      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5824      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5825      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5826               ethetai=ethetai+sinkt(m)*aux
5827               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5828               dephii=dephii+l*sinkt(m)*(
5829      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5830      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5831      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5832      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5833               dephii1=dephii1+(k-l)*sinkt(m)*(
5834      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5835      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5836      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5837      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5838               if (lprn) then
5839               write (iout,*) "m",m," k",k," l",l," ffthet",
5840      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5841      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5842      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5843      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5844      &            " ethetai",ethetai
5845               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5846      &            cosph1ph2(k,l)*sinkt(m),
5847      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5848               endif
5849             enddo
5850           enddo
5851         enddo
5852 10      continue
5853 c        lprn1=.true.
5854         if (lprn1)
5855      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5856      &   i,theta(i)*rad2deg,phii*rad2deg,
5857      &   phii1*rad2deg,ethetai
5858 c        lprn1=.false.
5859         etheta=etheta+ethetai
5860         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5861      &      'ebend',i,ethetai
5862         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5863         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5864         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5865       enddo
5866       return
5867       end
5868 #endif
5869 #ifdef CRYST_SC
5870 c-----------------------------------------------------------------------------
5871       subroutine esc(escloc)
5872 C Calculate the local energy of a side chain and its derivatives in the
5873 C corresponding virtual-bond valence angles THETA and the spherical angles
5874 C ALPHA and OMEGA.
5875       implicit real*8 (a-h,o-z)
5876       include 'DIMENSIONS'
5877       include 'COMMON.GEO'
5878       include 'COMMON.LOCAL'
5879       include 'COMMON.VAR'
5880       include 'COMMON.INTERACT'
5881       include 'COMMON.DERIV'
5882       include 'COMMON.CHAIN'
5883       include 'COMMON.IOUNITS'
5884       include 'COMMON.NAMES'
5885       include 'COMMON.FFIELD'
5886       include 'COMMON.CONTROL'
5887       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5888      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5889       common /sccalc/ time11,time12,time112,theti,it,nlobit
5890       delta=0.02d0*pi
5891       escloc=0.0D0
5892 c     write (iout,'(a)') 'ESC'
5893       do i=loc_start,loc_end
5894         it=itype(i)
5895         if (it.eq.ntyp1) cycle
5896         if (it.eq.10) goto 1
5897         nlobit=nlob(iabs(it))
5898 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5899 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5900         theti=theta(i+1)-pipol
5901         x(1)=dtan(theti)
5902         x(2)=alph(i)
5903         x(3)=omeg(i)
5904
5905         if (x(2).gt.pi-delta) then
5906           xtemp(1)=x(1)
5907           xtemp(2)=pi-delta
5908           xtemp(3)=x(3)
5909           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5910           xtemp(2)=pi
5911           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5912           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5913      &        escloci,dersc(2))
5914           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5915      &        ddersc0(1),dersc(1))
5916           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5917      &        ddersc0(3),dersc(3))
5918           xtemp(2)=pi-delta
5919           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5920           xtemp(2)=pi
5921           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5922           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5923      &            dersc0(2),esclocbi,dersc02)
5924           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5925      &            dersc12,dersc01)
5926           call splinthet(x(2),0.5d0*delta,ss,ssd)
5927           dersc0(1)=dersc01
5928           dersc0(2)=dersc02
5929           dersc0(3)=0.0d0
5930           do k=1,3
5931             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5932           enddo
5933           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5934 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5935 c    &             esclocbi,ss,ssd
5936           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5937 c         escloci=esclocbi
5938 c         write (iout,*) escloci
5939         else if (x(2).lt.delta) then
5940           xtemp(1)=x(1)
5941           xtemp(2)=delta
5942           xtemp(3)=x(3)
5943           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5944           xtemp(2)=0.0d0
5945           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5946           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5947      &        escloci,dersc(2))
5948           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5949      &        ddersc0(1),dersc(1))
5950           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5951      &        ddersc0(3),dersc(3))
5952           xtemp(2)=delta
5953           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5954           xtemp(2)=0.0d0
5955           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5956           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5957      &            dersc0(2),esclocbi,dersc02)
5958           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5959      &            dersc12,dersc01)
5960           dersc0(1)=dersc01
5961           dersc0(2)=dersc02
5962           dersc0(3)=0.0d0
5963           call splinthet(x(2),0.5d0*delta,ss,ssd)
5964           do k=1,3
5965             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5966           enddo
5967           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5968 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5969 c    &             esclocbi,ss,ssd
5970           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5971 c         write (iout,*) escloci
5972         else
5973           call enesc(x,escloci,dersc,ddummy,.false.)
5974         endif
5975
5976         escloc=escloc+escloci
5977         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5978      &     'escloc',i,escloci
5979 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5980
5981         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5982      &   wscloc*dersc(1)
5983         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5984         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5985     1   continue
5986       enddo
5987       return
5988       end
5989 C---------------------------------------------------------------------------
5990       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5991       implicit real*8 (a-h,o-z)
5992       include 'DIMENSIONS'
5993       include 'COMMON.GEO'
5994       include 'COMMON.LOCAL'
5995       include 'COMMON.IOUNITS'
5996       common /sccalc/ time11,time12,time112,theti,it,nlobit
5997       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5998       double precision contr(maxlob,-1:1)
5999       logical mixed
6000 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6001         escloc_i=0.0D0
6002         do j=1,3
6003           dersc(j)=0.0D0
6004           if (mixed) ddersc(j)=0.0d0
6005         enddo
6006         x3=x(3)
6007
6008 C Because of periodicity of the dependence of the SC energy in omega we have
6009 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6010 C To avoid underflows, first compute & store the exponents.
6011
6012         do iii=-1,1
6013
6014           x(3)=x3+iii*dwapi
6015
6016           do j=1,nlobit
6017             do k=1,3
6018               z(k)=x(k)-censc(k,j,it)
6019             enddo
6020             do k=1,3
6021               Axk=0.0D0
6022               do l=1,3
6023                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6024               enddo
6025               Ax(k,j,iii)=Axk
6026             enddo
6027             expfac=0.0D0
6028             do k=1,3
6029               expfac=expfac+Ax(k,j,iii)*z(k)
6030             enddo
6031             contr(j,iii)=expfac
6032           enddo ! j
6033
6034         enddo ! iii
6035
6036         x(3)=x3
6037 C As in the case of ebend, we want to avoid underflows in exponentiation and
6038 C subsequent NaNs and INFs in energy calculation.
6039 C Find the largest exponent
6040         emin=contr(1,-1)
6041         do iii=-1,1
6042           do j=1,nlobit
6043             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6044           enddo
6045         enddo
6046         emin=0.5D0*emin
6047 cd      print *,'it=',it,' emin=',emin
6048
6049 C Compute the contribution to SC energy and derivatives
6050         do iii=-1,1
6051
6052           do j=1,nlobit
6053 #ifdef OSF
6054             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6055             if(adexp.ne.adexp) adexp=1.0
6056             expfac=dexp(adexp)
6057 #else
6058             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6059 #endif
6060 cd          print *,'j=',j,' expfac=',expfac
6061             escloc_i=escloc_i+expfac
6062             do k=1,3
6063               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6064             enddo
6065             if (mixed) then
6066               do k=1,3,2
6067                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6068      &            +gaussc(k,2,j,it))*expfac
6069               enddo
6070             endif
6071           enddo
6072
6073         enddo ! iii
6074
6075         dersc(1)=dersc(1)/cos(theti)**2
6076         ddersc(1)=ddersc(1)/cos(theti)**2
6077         ddersc(3)=ddersc(3)
6078
6079         escloci=-(dlog(escloc_i)-emin)
6080         do j=1,3
6081           dersc(j)=dersc(j)/escloc_i
6082         enddo
6083         if (mixed) then
6084           do j=1,3,2
6085             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6086           enddo
6087         endif
6088       return
6089       end
6090 C------------------------------------------------------------------------------
6091       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6092       implicit real*8 (a-h,o-z)
6093       include 'DIMENSIONS'
6094       include 'COMMON.GEO'
6095       include 'COMMON.LOCAL'
6096       include 'COMMON.IOUNITS'
6097       common /sccalc/ time11,time12,time112,theti,it,nlobit
6098       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6099       double precision contr(maxlob)
6100       logical mixed
6101
6102       escloc_i=0.0D0
6103
6104       do j=1,3
6105         dersc(j)=0.0D0
6106       enddo
6107
6108       do j=1,nlobit
6109         do k=1,2
6110           z(k)=x(k)-censc(k,j,it)
6111         enddo
6112         z(3)=dwapi
6113         do k=1,3
6114           Axk=0.0D0
6115           do l=1,3
6116             Axk=Axk+gaussc(l,k,j,it)*z(l)
6117           enddo
6118           Ax(k,j)=Axk
6119         enddo
6120         expfac=0.0D0
6121         do k=1,3
6122           expfac=expfac+Ax(k,j)*z(k)
6123         enddo
6124         contr(j)=expfac
6125       enddo ! j
6126
6127 C As in the case of ebend, we want to avoid underflows in exponentiation and
6128 C subsequent NaNs and INFs in energy calculation.
6129 C Find the largest exponent
6130       emin=contr(1)
6131       do j=1,nlobit
6132         if (emin.gt.contr(j)) emin=contr(j)
6133       enddo
6134       emin=0.5D0*emin
6135
6136 C Compute the contribution to SC energy and derivatives
6137
6138       dersc12=0.0d0
6139       do j=1,nlobit
6140         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6141         escloc_i=escloc_i+expfac
6142         do k=1,2
6143           dersc(k)=dersc(k)+Ax(k,j)*expfac
6144         enddo
6145         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6146      &            +gaussc(1,2,j,it))*expfac
6147         dersc(3)=0.0d0
6148       enddo
6149
6150       dersc(1)=dersc(1)/cos(theti)**2
6151       dersc12=dersc12/cos(theti)**2
6152       escloci=-(dlog(escloc_i)-emin)
6153       do j=1,2
6154         dersc(j)=dersc(j)/escloc_i
6155       enddo
6156       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6157       return
6158       end
6159 #else
6160 c----------------------------------------------------------------------------------
6161       subroutine esc(escloc)
6162 C Calculate the local energy of a side chain and its derivatives in the
6163 C corresponding virtual-bond valence angles THETA and the spherical angles
6164 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6165 C added by Urszula Kozlowska. 07/11/2007
6166 C
6167       implicit real*8 (a-h,o-z)
6168       include 'DIMENSIONS'
6169       include 'COMMON.GEO'
6170       include 'COMMON.LOCAL'
6171       include 'COMMON.VAR'
6172       include 'COMMON.SCROT'
6173       include 'COMMON.INTERACT'
6174       include 'COMMON.DERIV'
6175       include 'COMMON.CHAIN'
6176       include 'COMMON.IOUNITS'
6177       include 'COMMON.NAMES'
6178       include 'COMMON.FFIELD'
6179       include 'COMMON.CONTROL'
6180       include 'COMMON.VECTORS'
6181       double precision x_prime(3),y_prime(3),z_prime(3)
6182      &    , sumene,dsc_i,dp2_i,x(65),
6183      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6184      &    de_dxx,de_dyy,de_dzz,de_dt
6185       double precision s1_t,s1_6_t,s2_t,s2_6_t
6186       double precision
6187      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6188      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6189      & dt_dCi(3),dt_dCi1(3)
6190       common /sccalc/ time11,time12,time112,theti,it,nlobit
6191       delta=0.02d0*pi
6192       escloc=0.0D0
6193       do i=loc_start,loc_end
6194         if (itype(i).eq.ntyp1) cycle
6195         costtab(i+1) =dcos(theta(i+1))
6196         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6197         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6198         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6199         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6200         cosfac=dsqrt(cosfac2)
6201         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6202         sinfac=dsqrt(sinfac2)
6203         it=iabs(itype(i))
6204         if (it.eq.10) goto 1
6205 c
6206 C  Compute the axes of tghe local cartesian coordinates system; store in
6207 c   x_prime, y_prime and z_prime
6208 c
6209         do j=1,3
6210           x_prime(j) = 0.00
6211           y_prime(j) = 0.00
6212           z_prime(j) = 0.00
6213         enddo
6214 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6215 C     &   dc_norm(3,i+nres)
6216         do j = 1,3
6217           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6218           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6219         enddo
6220         do j = 1,3
6221           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6222         enddo
6223 c       write (2,*) "i",i
6224 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6225 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6226 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6227 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6228 c      & " xy",scalar(x_prime(1),y_prime(1)),
6229 c      & " xz",scalar(x_prime(1),z_prime(1)),
6230 c      & " yy",scalar(y_prime(1),y_prime(1)),
6231 c      & " yz",scalar(y_prime(1),z_prime(1)),
6232 c      & " zz",scalar(z_prime(1),z_prime(1))
6233 c
6234 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6235 C to local coordinate system. Store in xx, yy, zz.
6236 c
6237         xx=0.0d0
6238         yy=0.0d0
6239         zz=0.0d0
6240         do j = 1,3
6241           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6242           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6243           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6244         enddo
6245
6246         xxtab(i)=xx
6247         yytab(i)=yy
6248         zztab(i)=zz
6249 C
6250 C Compute the energy of the ith side cbain
6251 C
6252 c        write (2,*) "xx",xx," yy",yy," zz",zz
6253         it=iabs(itype(i))
6254         do j = 1,65
6255           x(j) = sc_parmin(j,it)
6256         enddo
6257 #ifdef CHECK_COORD
6258 Cc diagnostics - remove later
6259         xx1 = dcos(alph(2))
6260         yy1 = dsin(alph(2))*dcos(omeg(2))
6261         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6262         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6263      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6264      &    xx1,yy1,zz1
6265 C,"  --- ", xx_w,yy_w,zz_w
6266 c end diagnostics
6267 #endif
6268         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6269      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6270      &   + x(10)*yy*zz
6271         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6272      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6273      & + x(20)*yy*zz
6274         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6275      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6276      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6277      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6278      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6279      &  +x(40)*xx*yy*zz
6280         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6281      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6282      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6283      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6284      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6285      &  +x(60)*xx*yy*zz
6286         dsc_i   = 0.743d0+x(61)
6287         dp2_i   = 1.9d0+x(62)
6288         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6289      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6290         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6291      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6292         s1=(1+x(63))/(0.1d0 + dscp1)
6293         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6294         s2=(1+x(65))/(0.1d0 + dscp2)
6295         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6296         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6297      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6298 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6299 c     &   sumene4,
6300 c     &   dscp1,dscp2,sumene
6301 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6302         escloc = escloc + sumene
6303         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6304      &     'escloc',i,sumene
6305 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6306 c     & ,zz,xx,yy
6307 c#define DEBUG
6308 #ifdef DEBUG
6309 C
6310 C This section to check the numerical derivatives of the energy of ith side
6311 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6312 C #define DEBUG in the code to turn it on.
6313 C
6314         write (2,*) "sumene               =",sumene
6315         aincr=1.0d-7
6316         xxsave=xx
6317         xx=xx+aincr
6318         write (2,*) xx,yy,zz
6319         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6320         de_dxx_num=(sumenep-sumene)/aincr
6321         xx=xxsave
6322         write (2,*) "xx+ sumene from enesc=",sumenep
6323         yysave=yy
6324         yy=yy+aincr
6325         write (2,*) xx,yy,zz
6326         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6327         de_dyy_num=(sumenep-sumene)/aincr
6328         yy=yysave
6329         write (2,*) "yy+ sumene from enesc=",sumenep
6330         zzsave=zz
6331         zz=zz+aincr
6332         write (2,*) xx,yy,zz
6333         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6334         de_dzz_num=(sumenep-sumene)/aincr
6335         zz=zzsave
6336         write (2,*) "zz+ sumene from enesc=",sumenep
6337         costsave=cost2tab(i+1)
6338         sintsave=sint2tab(i+1)
6339         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6340         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6341         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6342         de_dt_num=(sumenep-sumene)/aincr
6343         write (2,*) " t+ sumene from enesc=",sumenep
6344         cost2tab(i+1)=costsave
6345         sint2tab(i+1)=sintsave
6346 C End of diagnostics section.
6347 #endif
6348 C
6349 C Compute the gradient of esc
6350 C
6351 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6352         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6353         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6354         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6355         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6356         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6357         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6358         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6359         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6360         pom1=(sumene3*sint2tab(i+1)+sumene1)
6361      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6362         pom2=(sumene4*cost2tab(i+1)+sumene2)
6363      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6364         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6365         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6366      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6367      &  +x(40)*yy*zz
6368         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6369         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6370      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6371      &  +x(60)*yy*zz
6372         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6373      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6374      &        +(pom1+pom2)*pom_dx
6375 #ifdef DEBUG
6376         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6377 #endif
6378 C
6379         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6380         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6381      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6382      &  +x(40)*xx*zz
6383         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6384         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6385      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6386      &  +x(59)*zz**2 +x(60)*xx*zz
6387         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6388      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6389      &        +(pom1-pom2)*pom_dy
6390 #ifdef DEBUG
6391         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6392 #endif
6393 C
6394         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6395      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6396      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6397      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6398      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6399      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6400      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6401      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6402 #ifdef DEBUG
6403         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6404 #endif
6405 C
6406         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6407      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6408      &  +pom1*pom_dt1+pom2*pom_dt2
6409 #ifdef DEBUG
6410         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6411 #endif
6412 c#undef DEBUG
6413 c
6414 C
6415        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6416        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6417        cosfac2xx=cosfac2*xx
6418        sinfac2yy=sinfac2*yy
6419        do k = 1,3
6420          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6421      &      vbld_inv(i+1)
6422          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6423      &      vbld_inv(i)
6424          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6425          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6426 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6427 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6428 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6429 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6430          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6431          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6432          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6433          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6434          dZZ_Ci1(k)=0.0d0
6435          dZZ_Ci(k)=0.0d0
6436          do j=1,3
6437            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6438      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6439            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6440      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6441          enddo
6442
6443          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6444          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6445          dZZ_XYZ(k)=vbld_inv(i+nres)*
6446      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6447 c
6448          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6449          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6450        enddo
6451
6452        do k=1,3
6453          dXX_Ctab(k,i)=dXX_Ci(k)
6454          dXX_C1tab(k,i)=dXX_Ci1(k)
6455          dYY_Ctab(k,i)=dYY_Ci(k)
6456          dYY_C1tab(k,i)=dYY_Ci1(k)
6457          dZZ_Ctab(k,i)=dZZ_Ci(k)
6458          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6459          dXX_XYZtab(k,i)=dXX_XYZ(k)
6460          dYY_XYZtab(k,i)=dYY_XYZ(k)
6461          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6462        enddo
6463
6464        do k = 1,3
6465 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6466 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6467 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6468 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6469 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6470 c     &    dt_dci(k)
6471 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6472 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6473          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6474      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6475          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6476      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6477          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6478      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6479        enddo
6480 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6481 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6482
6483 C to check gradient call subroutine check_grad
6484
6485     1 continue
6486       enddo
6487       return
6488       end
6489 c------------------------------------------------------------------------------
6490       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6491       implicit none
6492       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6493      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6494       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6495      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6496      &   + x(10)*yy*zz
6497       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6498      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6499      & + x(20)*yy*zz
6500       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6501      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6502      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6503      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6504      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6505      &  +x(40)*xx*yy*zz
6506       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6507      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6508      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6509      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6510      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6511      &  +x(60)*xx*yy*zz
6512       dsc_i   = 0.743d0+x(61)
6513       dp2_i   = 1.9d0+x(62)
6514       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6515      &          *(xx*cost2+yy*sint2))
6516       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6517      &          *(xx*cost2-yy*sint2))
6518       s1=(1+x(63))/(0.1d0 + dscp1)
6519       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6520       s2=(1+x(65))/(0.1d0 + dscp2)
6521       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6522       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6523      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6524       enesc=sumene
6525       return
6526       end
6527 #endif
6528 c------------------------------------------------------------------------------
6529       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6530 C
6531 C This procedure calculates two-body contact function g(rij) and its derivative:
6532 C
6533 C           eps0ij                                     !       x < -1
6534 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6535 C            0                                         !       x > 1
6536 C
6537 C where x=(rij-r0ij)/delta
6538 C
6539 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6540 C
6541       implicit none
6542       double precision rij,r0ij,eps0ij,fcont,fprimcont
6543       double precision x,x2,x4,delta
6544 c     delta=0.02D0*r0ij
6545 c      delta=0.2D0*r0ij
6546       x=(rij-r0ij)/delta
6547       if (x.lt.-1.0D0) then
6548         fcont=eps0ij
6549         fprimcont=0.0D0
6550       else if (x.le.1.0D0) then
6551         x2=x*x
6552         x4=x2*x2
6553         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6554         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6555       else
6556         fcont=0.0D0
6557         fprimcont=0.0D0
6558       endif
6559       return
6560       end
6561 c------------------------------------------------------------------------------
6562       subroutine splinthet(theti,delta,ss,ssder)
6563       implicit real*8 (a-h,o-z)
6564       include 'DIMENSIONS'
6565       include 'COMMON.VAR'
6566       include 'COMMON.GEO'
6567       thetup=pi-delta
6568       thetlow=delta
6569       if (theti.gt.pipol) then
6570         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6571       else
6572         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6573         ssder=-ssder
6574       endif
6575       return
6576       end
6577 c------------------------------------------------------------------------------
6578       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6579       implicit none
6580       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6581       double precision ksi,ksi2,ksi3,a1,a2,a3
6582       a1=fprim0*delta/(f1-f0)
6583       a2=3.0d0-2.0d0*a1
6584       a3=a1-2.0d0
6585       ksi=(x-x0)/delta
6586       ksi2=ksi*ksi
6587       ksi3=ksi2*ksi
6588       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6589       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6590       return
6591       end
6592 c------------------------------------------------------------------------------
6593       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6594       implicit none
6595       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6596       double precision ksi,ksi2,ksi3,a1,a2,a3
6597       ksi=(x-x0)/delta
6598       ksi2=ksi*ksi
6599       ksi3=ksi2*ksi
6600       a1=fprim0x*delta
6601       a2=3*(f1x-f0x)-2*fprim0x*delta
6602       a3=fprim0x*delta-2*(f1x-f0x)
6603       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6604       return
6605       end
6606 C-----------------------------------------------------------------------------
6607 #ifdef CRYST_TOR
6608 C-----------------------------------------------------------------------------
6609       subroutine etor(etors,edihcnstr)
6610       implicit real*8 (a-h,o-z)
6611       include 'DIMENSIONS'
6612       include 'COMMON.VAR'
6613       include 'COMMON.GEO'
6614       include 'COMMON.LOCAL'
6615       include 'COMMON.TORSION'
6616       include 'COMMON.INTERACT'
6617       include 'COMMON.DERIV'
6618       include 'COMMON.CHAIN'
6619       include 'COMMON.NAMES'
6620       include 'COMMON.IOUNITS'
6621       include 'COMMON.FFIELD'
6622       include 'COMMON.TORCNSTR'
6623       include 'COMMON.CONTROL'
6624       logical lprn
6625 C Set lprn=.true. for debugging
6626       lprn=.false.
6627 c      lprn=.true.
6628       etors=0.0D0
6629       do i=iphi_start,iphi_end
6630       etors_ii=0.0D0
6631         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6632      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6633         itori=itortyp(itype(i-2))
6634         itori1=itortyp(itype(i-1))
6635         phii=phi(i)
6636         gloci=0.0D0
6637 C Proline-Proline pair is a special case...
6638         if (itori.eq.3 .and. itori1.eq.3) then
6639           if (phii.gt.-dwapi3) then
6640             cosphi=dcos(3*phii)
6641             fac=1.0D0/(1.0D0-cosphi)
6642             etorsi=v1(1,3,3)*fac
6643             etorsi=etorsi+etorsi
6644             etors=etors+etorsi-v1(1,3,3)
6645             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6646             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6647           endif
6648           do j=1,3
6649             v1ij=v1(j+1,itori,itori1)
6650             v2ij=v2(j+1,itori,itori1)
6651             cosphi=dcos(j*phii)
6652             sinphi=dsin(j*phii)
6653             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6654             if (energy_dec) etors_ii=etors_ii+
6655      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6656             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6657           enddo
6658         else
6659           do j=1,nterm_old
6660             v1ij=v1(j,itori,itori1)
6661             v2ij=v2(j,itori,itori1)
6662             cosphi=dcos(j*phii)
6663             sinphi=dsin(j*phii)
6664             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6665             if (energy_dec) etors_ii=etors_ii+
6666      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6667             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6668           enddo
6669         endif
6670         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6671              'etor',i,etors_ii
6672         if (lprn)
6673      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6674      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6675      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6676         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6677 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6678       enddo
6679 ! 6/20/98 - dihedral angle constraints
6680       edihcnstr=0.0d0
6681       do i=1,ndih_constr
6682         itori=idih_constr(i)
6683         phii=phi(itori)
6684         difi=phii-phi0(i)
6685         if (difi.gt.drange(i)) then
6686           difi=difi-drange(i)
6687           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6688           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6689         else if (difi.lt.-drange(i)) then
6690           difi=difi+drange(i)
6691           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6692           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6693         endif
6694 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6695 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6696       enddo
6697 !      write (iout,*) 'edihcnstr',edihcnstr
6698       return
6699       end
6700 c------------------------------------------------------------------------------
6701 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6702       subroutine e_modeller(ehomology_constr)
6703       ehomology_constr=0.0d0
6704       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6705       return
6706       end
6707 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6708
6709 c------------------------------------------------------------------------------
6710       subroutine etor_d(etors_d)
6711       etors_d=0.0d0
6712       return
6713       end
6714 c----------------------------------------------------------------------------
6715 #else
6716       subroutine etor(etors,edihcnstr)
6717       implicit real*8 (a-h,o-z)
6718       include 'DIMENSIONS'
6719       include 'COMMON.VAR'
6720       include 'COMMON.GEO'
6721       include 'COMMON.LOCAL'
6722       include 'COMMON.TORSION'
6723       include 'COMMON.INTERACT'
6724       include 'COMMON.DERIV'
6725       include 'COMMON.CHAIN'
6726       include 'COMMON.NAMES'
6727       include 'COMMON.IOUNITS'
6728       include 'COMMON.FFIELD'
6729       include 'COMMON.TORCNSTR'
6730       include 'COMMON.CONTROL'
6731       logical lprn
6732 C Set lprn=.true. for debugging
6733       lprn=.false.
6734 c     lprn=.true.
6735       etors=0.0D0
6736       do i=iphi_start,iphi_end
6737 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6738 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6739 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6740 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6741         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6742      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6743 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6744 C For introducing the NH3+ and COO- group please check the etor_d for reference
6745 C and guidance
6746         etors_ii=0.0D0
6747          if (iabs(itype(i)).eq.20) then
6748          iblock=2
6749          else
6750          iblock=1
6751          endif
6752         itori=itortyp(itype(i-2))
6753         itori1=itortyp(itype(i-1))
6754         phii=phi(i)
6755         gloci=0.0D0
6756 C Regular cosine and sine terms
6757         do j=1,nterm(itori,itori1,iblock)
6758           v1ij=v1(j,itori,itori1,iblock)
6759           v2ij=v2(j,itori,itori1,iblock)
6760           cosphi=dcos(j*phii)
6761           sinphi=dsin(j*phii)
6762           etors=etors+v1ij*cosphi+v2ij*sinphi
6763           if (energy_dec) etors_ii=etors_ii+
6764      &                v1ij*cosphi+v2ij*sinphi
6765           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6766         enddo
6767 C Lorentz terms
6768 C                         v1
6769 C  E = SUM ----------------------------------- - v1
6770 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6771 C
6772         cosphi=dcos(0.5d0*phii)
6773         sinphi=dsin(0.5d0*phii)
6774         do j=1,nlor(itori,itori1,iblock)
6775           vl1ij=vlor1(j,itori,itori1)
6776           vl2ij=vlor2(j,itori,itori1)
6777           vl3ij=vlor3(j,itori,itori1)
6778           pom=vl2ij*cosphi+vl3ij*sinphi
6779           pom1=1.0d0/(pom*pom+1.0d0)
6780           etors=etors+vl1ij*pom1
6781           if (energy_dec) etors_ii=etors_ii+
6782      &                vl1ij*pom1
6783           pom=-pom*pom1*pom1
6784           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6785         enddo
6786 C Subtract the constant term
6787         etors=etors-v0(itori,itori1,iblock)
6788           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6789      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6790         if (lprn)
6791      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6792      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6793      &  (v1(j,itori,itori1,iblock),j=1,6),
6794      &  (v2(j,itori,itori1,iblock),j=1,6)
6795         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6796 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6797       enddo
6798 ! 6/20/98 - dihedral angle constraints
6799       edihcnstr=0.0d0
6800 c      do i=1,ndih_constr
6801       do i=idihconstr_start,idihconstr_end
6802         itori=idih_constr(i)
6803         phii=phi(itori)
6804         difi=pinorm(phii-phi0(i))
6805         if (difi.gt.drange(i)) then
6806           difi=difi-drange(i)
6807           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6808           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6809         else if (difi.lt.-drange(i)) then
6810           difi=difi+drange(i)
6811           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6812           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6813         else
6814           difi=0.0
6815         endif
6816 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6817 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6818 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6819       enddo
6820 cd       write (iout,*) 'edihcnstr',edihcnstr
6821       return
6822       end
6823 c----------------------------------------------------------------------------
6824 c MODELLER restraint function
6825       subroutine e_modeller(ehomology_constr)
6826       implicit real*8 (a-h,o-z)
6827       include 'DIMENSIONS'
6828
6829       integer nnn, i, j, k, ki, irec, l
6830       integer katy, odleglosci, test7
6831       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6832       real*8 Eval,Erot
6833       real*8 distance(max_template),distancek(max_template),
6834      &    min_odl,godl(max_template),dih_diff(max_template)
6835
6836 c
6837 c     FP - 30/10/2014 Temporary specifications for homology restraints
6838 c
6839       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6840      &                 sgtheta
6841       double precision, dimension (maxres) :: guscdiff,usc_diff
6842       double precision, dimension (max_template) ::
6843      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6844      &           theta_diff
6845 c
6846
6847       include 'COMMON.SBRIDGE'
6848       include 'COMMON.CHAIN'
6849       include 'COMMON.GEO'
6850       include 'COMMON.DERIV'
6851       include 'COMMON.LOCAL'
6852       include 'COMMON.INTERACT'
6853       include 'COMMON.VAR'
6854       include 'COMMON.IOUNITS'
6855       include 'COMMON.MD'
6856       include 'COMMON.CONTROL'
6857 c
6858 c     From subroutine Econstr_back
6859 c
6860       include 'COMMON.NAMES'
6861       include 'COMMON.TIME1'
6862 c
6863
6864
6865       do i=1,19
6866         distancek(i)=9999999.9
6867       enddo
6868
6869
6870       odleg=0.0d0
6871
6872 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6873 c function)
6874 C AL 5/2/14 - Introduce list of restraints
6875 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6876 #ifdef DEBUG
6877       write(iout,*) "------- dist restrs start -------"
6878 #endif
6879       do ii = link_start_homo,link_end_homo
6880          i = ires_homo(ii)
6881          j = jres_homo(ii)
6882          dij=dist(i,j)
6883 c        write (iout,*) "dij(",i,j,") =",dij
6884          do k=1,constr_homology
6885 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6886            if(.not.l_homo(k,ii)) cycle
6887            distance(k)=odl(k,ii)-dij
6888 c          write (iout,*) "distance(",k,") =",distance(k)
6889 c
6890 c          For Gaussian-type Urestr
6891 c
6892            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6893 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6894 c          write (iout,*) "distancek(",k,") =",distancek(k)
6895 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6896 c
6897 c          For Lorentzian-type Urestr
6898 c
6899            if (waga_dist.lt.0.0d0) then
6900               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6901               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6902      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6903            endif
6904          enddo
6905
6906 c         min_odl=minval(distancek)
6907          do kk=1,constr_homology
6908           if(l_homo(kk,ii)) then
6909             min_odl=distancek(kk)
6910             exit
6911           endif
6912          enddo
6913          do kk=1,constr_homology
6914           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6915      &              min_odl=distancek(kk)
6916          enddo
6917
6918 c        write (iout,* )"min_odl",min_odl
6919 #ifdef DEBUG
6920          write (iout,*) "ij dij",i,j,dij
6921          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6922          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6923          write (iout,* )"min_odl",min_odl
6924 #endif
6925          odleg2=0.0d0
6926          do k=1,constr_homology
6927 c Nie wiem po co to liczycie jeszcze raz!
6928 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6929 c     &              (2*(sigma_odl(i,j,k))**2))
6930            if(.not.l_homo(k,ii)) cycle
6931            if (waga_dist.ge.0.0d0) then
6932 c
6933 c          For Gaussian-type Urestr
6934 c
6935             godl(k)=dexp(-distancek(k)+min_odl)
6936             odleg2=odleg2+godl(k)
6937 c
6938 c          For Lorentzian-type Urestr
6939 c
6940            else
6941             odleg2=odleg2+distancek(k)
6942            endif
6943
6944 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6945 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6946 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6947 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6948
6949          enddo
6950 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6951 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6952 #ifdef DEBUG
6953          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6954          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6955 #endif
6956            if (waga_dist.ge.0.0d0) then
6957 c
6958 c          For Gaussian-type Urestr
6959 c
6960               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6961 c
6962 c          For Lorentzian-type Urestr
6963 c
6964            else
6965               odleg=odleg+odleg2/constr_homology
6966            endif
6967 c
6968 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6969 c Gradient
6970 c
6971 c          For Gaussian-type Urestr
6972 c
6973          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6974          sum_sgodl=0.0d0
6975          do k=1,constr_homology
6976 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6977 c     &           *waga_dist)+min_odl
6978 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6979 c
6980          if(.not.l_homo(k,ii)) cycle
6981          if (waga_dist.ge.0.0d0) then
6982 c          For Gaussian-type Urestr
6983 c
6984            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6985 c
6986 c          For Lorentzian-type Urestr
6987 c
6988          else
6989            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6990      &           sigma_odlir(k,ii)**2)**2)
6991          endif
6992            sum_sgodl=sum_sgodl+sgodl
6993
6994 c            sgodl2=sgodl2+sgodl
6995 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6996 c      write(iout,*) "constr_homology=",constr_homology
6997 c      write(iout,*) i, j, k, "TEST K"
6998          enddo
6999          if (waga_dist.ge.0.0d0) then
7000 c
7001 c          For Gaussian-type Urestr
7002 c
7003             grad_odl3=waga_homology(iset)*waga_dist
7004      &                *sum_sgodl/(sum_godl*dij)
7005 c
7006 c          For Lorentzian-type Urestr
7007 c
7008          else
7009 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7010 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7011             grad_odl3=-waga_homology(iset)*waga_dist*
7012      &                sum_sgodl/(constr_homology*dij)
7013          endif
7014 c
7015 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7016
7017
7018 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7019 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7020 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7021
7022 ccc      write(iout,*) godl, sgodl, grad_odl3
7023
7024 c          grad_odl=grad_odl+grad_odl3
7025
7026          do jik=1,3
7027             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7028 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7029 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7030 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7031             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7032             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7033 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7034 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7035 c         if (i.eq.25.and.j.eq.27) then
7036 c         write(iout,*) "jik",jik,"i",i,"j",j
7037 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7038 c         write(iout,*) "grad_odl3",grad_odl3
7039 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7040 c         write(iout,*) "ggodl",ggodl
7041 c         write(iout,*) "ghpbc(",jik,i,")",
7042 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7043 c     &                 ghpbc(jik,j)
7044 c         endif
7045          enddo
7046 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7047 ccc     & dLOG(odleg2),"-odleg=", -odleg
7048
7049       enddo ! ii-loop for dist
7050 #ifdef DEBUG
7051       write(iout,*) "------- dist restrs end -------"
7052 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7053 c    &     waga_d.eq.1.0d0) call sum_gradient
7054 #endif
7055 c Pseudo-energy and gradient from dihedral-angle restraints from
7056 c homology templates
7057 c      write (iout,*) "End of distance loop"
7058 c      call flush(iout)
7059       kat=0.0d0
7060 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7061 #ifdef DEBUG
7062       write(iout,*) "------- dih restrs start -------"
7063       do i=idihconstr_start_homo,idihconstr_end_homo
7064         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7065       enddo
7066 #endif
7067       do i=idihconstr_start_homo,idihconstr_end_homo
7068         kat2=0.0d0
7069 c        betai=beta(i,i+1,i+2,i+3)
7070         betai = phi(i)
7071 c       write (iout,*) "betai =",betai
7072         do k=1,constr_homology
7073           dih_diff(k)=pinorm(dih(k,i)-betai)
7074 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7075 cd     &                  ,sigma_dih(k,i)
7076 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7077 c     &                                   -(6.28318-dih_diff(i,k))
7078 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7079 c     &                                   6.28318+dih_diff(i,k)
7080
7081           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7082 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7083           gdih(k)=dexp(kat3)
7084           kat2=kat2+gdih(k)
7085 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7086 c          write(*,*)""
7087         enddo
7088 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7089 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7090 #ifdef DEBUG
7091         write (iout,*) "i",i," betai",betai," kat2",kat2
7092         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7093 #endif
7094         if (kat2.le.1.0d-14) cycle
7095         kat=kat-dLOG(kat2/constr_homology)
7096 c       write (iout,*) "kat",kat ! sum of -ln-s
7097
7098 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7099 ccc     & dLOG(kat2), "-kat=", -kat
7100
7101 c ----------------------------------------------------------------------
7102 c Gradient
7103 c ----------------------------------------------------------------------
7104
7105         sum_gdih=kat2
7106         sum_sgdih=0.0d0
7107         do k=1,constr_homology
7108           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7109 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7110           sum_sgdih=sum_sgdih+sgdih
7111         enddo
7112 c       grad_dih3=sum_sgdih/sum_gdih
7113         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7114
7115 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7116 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7117 ccc     & gloc(nphi+i-3,icg)
7118         gloc(i,icg)=gloc(i,icg)+grad_dih3
7119 c        if (i.eq.25) then
7120 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7121 c        endif
7122 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7123 ccc     & gloc(nphi+i-3,icg)
7124
7125       enddo ! i-loop for dih
7126 #ifdef DEBUG
7127       write(iout,*) "------- dih restrs end -------"
7128 #endif
7129
7130 c Pseudo-energy and gradient for theta angle restraints from
7131 c homology templates
7132 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7133 c adapted
7134
7135 c
7136 c     For constr_homology reference structures (FP)
7137 c
7138 c     Uconst_back_tot=0.0d0
7139       Eval=0.0d0
7140       Erot=0.0d0
7141 c     Econstr_back legacy
7142       do i=1,nres
7143 c     do i=ithet_start,ithet_end
7144        dutheta(i)=0.0d0
7145 c     enddo
7146 c     do i=loc_start,loc_end
7147         do j=1,3
7148           duscdiff(j,i)=0.0d0
7149           duscdiffx(j,i)=0.0d0
7150         enddo
7151       enddo
7152 c
7153 c     do iref=1,nref
7154 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7155 c     write (iout,*) "waga_theta",waga_theta
7156       if (waga_theta.gt.0.0d0) then
7157 #ifdef DEBUG
7158       write (iout,*) "usampl",usampl
7159       write(iout,*) "------- theta restrs start -------"
7160 c     do i=ithet_start,ithet_end
7161 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7162 c     enddo
7163 #endif
7164 c     write (iout,*) "maxres",maxres,"nres",nres
7165
7166       do i=ithet_start,ithet_end
7167 c
7168 c     do i=1,nfrag_back
7169 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7170 c
7171 c Deviation of theta angles wrt constr_homology ref structures
7172 c
7173         utheta_i=0.0d0 ! argument of Gaussian for single k
7174         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7175 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7176 c       over residues in a fragment
7177 c       write (iout,*) "theta(",i,")=",theta(i)
7178         do k=1,constr_homology
7179 c
7180 c         dtheta_i=theta(j)-thetaref(j,iref)
7181 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7182           theta_diff(k)=thetatpl(k,i)-theta(i)
7183 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7184 cd     &                  ,sigma_theta(k,i)
7185
7186 c
7187           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7188 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7189           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7190           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
7191 c         Gradient for single Gaussian restraint in subr Econstr_back
7192 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7193 c
7194         enddo
7195 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7196 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7197
7198 c
7199 c         Gradient for multiple Gaussian restraint
7200         sum_gtheta=gutheta_i
7201         sum_sgtheta=0.0d0
7202         do k=1,constr_homology
7203 c        New generalized expr for multiple Gaussian from Econstr_back
7204          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7205 c
7206 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7207           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7208         enddo
7209 c       Final value of gradient using same var as in Econstr_back
7210         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7211      &      +sum_sgtheta/sum_gtheta*waga_theta
7212      &               *waga_homology(iset)
7213 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7214 c     &               *waga_homology(iset)
7215 c       dutheta(i)=sum_sgtheta/sum_gtheta
7216 c
7217 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7218         Eval=Eval-dLOG(gutheta_i/constr_homology)
7219 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7220 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7221 c       Uconst_back=Uconst_back+utheta(i)
7222       enddo ! (i-loop for theta)
7223 #ifdef DEBUG
7224       write(iout,*) "------- theta restrs end -------"
7225 #endif
7226       endif
7227 c
7228 c Deviation of local SC geometry
7229 c
7230 c Separation of two i-loops (instructed by AL - 11/3/2014)
7231 c
7232 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7233 c     write (iout,*) "waga_d",waga_d
7234
7235 #ifdef DEBUG
7236       write(iout,*) "------- SC restrs start -------"
7237       write (iout,*) "Initial duscdiff,duscdiffx"
7238       do i=loc_start,loc_end
7239         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7240      &                 (duscdiffx(jik,i),jik=1,3)
7241       enddo
7242 #endif
7243       do i=loc_start,loc_end
7244         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7245         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7246 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7247 c       write(iout,*) "xxtab, yytab, zztab"
7248 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7249         do k=1,constr_homology
7250 c
7251           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7252 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7253           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7254           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7255 c         write(iout,*) "dxx, dyy, dzz"
7256 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7257 c
7258           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7259 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7260 c         uscdiffk(k)=usc_diff(i)
7261           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7262           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
7263 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7264 c     &      xxref(j),yyref(j),zzref(j)
7265         enddo
7266 c
7267 c       Gradient
7268 c
7269 c       Generalized expression for multiple Gaussian acc to that for a single
7270 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7271 c
7272 c       Original implementation
7273 c       sum_guscdiff=guscdiff(i)
7274 c
7275 c       sum_sguscdiff=0.0d0
7276 c       do k=1,constr_homology
7277 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7278 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7279 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7280 c       enddo
7281 c
7282 c       Implementation of new expressions for gradient (Jan. 2015)
7283 c
7284 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7285         do k=1,constr_homology
7286 c
7287 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7288 c       before. Now the drivatives should be correct
7289 c
7290           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7291 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7292           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7293           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7294 c
7295 c         New implementation
7296 c
7297           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7298      &                 sigma_d(k,i) ! for the grad wrt r'
7299 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7300 c
7301 c
7302 c        New implementation
7303          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7304          do jik=1,3
7305             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7306      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7307      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7308             duscdiff(jik,i)=duscdiff(jik,i)+
7309      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7310      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7311             duscdiffx(jik,i)=duscdiffx(jik,i)+
7312      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7313      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7314 c
7315 #ifdef DEBUG
7316              write(iout,*) "jik",jik,"i",i
7317              write(iout,*) "dxx, dyy, dzz"
7318              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7319              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7320 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7321 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7322 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7323 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7324 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7325 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7326 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7327 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7328 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7329 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7330 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7331 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7332 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7333 c            endif
7334 #endif
7335          enddo
7336         enddo
7337 c
7338 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7339 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7340 c
7341 c        write (iout,*) i," uscdiff",uscdiff(i)
7342 c
7343 c Put together deviations from local geometry
7344
7345 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7346 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7347         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7348 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7349 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7350 c       Uconst_back=Uconst_back+usc_diff(i)
7351 c
7352 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7353 c
7354 c     New implment: multiplied by sum_sguscdiff
7355 c
7356
7357       enddo ! (i-loop for dscdiff)
7358
7359 c      endif
7360
7361 #ifdef DEBUG
7362       write(iout,*) "------- SC restrs end -------"
7363         write (iout,*) "------ After SC loop in e_modeller ------"
7364         do i=loc_start,loc_end
7365          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7366          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7367         enddo
7368       if (waga_theta.eq.1.0d0) then
7369       write (iout,*) "in e_modeller after SC restr end: dutheta"
7370       do i=ithet_start,ithet_end
7371         write (iout,*) i,dutheta(i)
7372       enddo
7373       endif
7374       if (waga_d.eq.1.0d0) then
7375       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7376       do i=1,nres
7377         write (iout,*) i,(duscdiff(j,i),j=1,3)
7378         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7379       enddo
7380       endif
7381 #endif
7382
7383 c Total energy from homology restraints
7384 #ifdef DEBUG
7385       write (iout,*) "odleg",odleg," kat",kat
7386 #endif
7387 c
7388 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7389 c
7390 c     ehomology_constr=odleg+kat
7391 c
7392 c     For Lorentzian-type Urestr
7393 c
7394
7395       if (waga_dist.ge.0.0d0) then
7396 c
7397 c          For Gaussian-type Urestr
7398 c
7399         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7400      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7401 c     write (iout,*) "ehomology_constr=",ehomology_constr
7402       else
7403 c
7404 c          For Lorentzian-type Urestr
7405 c
7406         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7407      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7408 c     write (iout,*) "ehomology_constr=",ehomology_constr
7409       endif
7410 #ifdef DEBUG
7411       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7412      & "Eval",waga_theta,eval,
7413      &   "Erot",waga_d,Erot
7414       write (iout,*) "ehomology_constr",ehomology_constr
7415 #endif
7416       return
7417 c
7418 c FP 01/15 end
7419 c
7420   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7421   747 format(a12,i4,i4,i4,f8.3,f8.3)
7422   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7423   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7424   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7425      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7426       end
7427
7428 c------------------------------------------------------------------------------
7429       subroutine etor_d(etors_d)
7430 C 6/23/01 Compute double torsional energy
7431       implicit real*8 (a-h,o-z)
7432       include 'DIMENSIONS'
7433       include 'COMMON.VAR'
7434       include 'COMMON.GEO'
7435       include 'COMMON.LOCAL'
7436       include 'COMMON.TORSION'
7437       include 'COMMON.INTERACT'
7438       include 'COMMON.DERIV'
7439       include 'COMMON.CHAIN'
7440       include 'COMMON.NAMES'
7441       include 'COMMON.IOUNITS'
7442       include 'COMMON.FFIELD'
7443       include 'COMMON.TORCNSTR'
7444       include 'COMMON.CONTROL'
7445       logical lprn
7446 C Set lprn=.true. for debugging
7447       lprn=.false.
7448 c     lprn=.true.
7449       etors_d=0.0D0
7450 c      write(iout,*) "a tu??"
7451       do i=iphid_start,iphid_end
7452 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7453 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7454 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7455 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7456 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7457          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7458      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7459      &  (itype(i+1).eq.ntyp1)) cycle
7460 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7461         etors_d_ii=0.0D0
7462         itori=itortyp(itype(i-2))
7463         itori1=itortyp(itype(i-1))
7464         itori2=itortyp(itype(i))
7465         phii=phi(i)
7466         phii1=phi(i+1)
7467         gloci1=0.0D0
7468         gloci2=0.0D0
7469         iblock=1
7470         if (iabs(itype(i+1)).eq.20) iblock=2
7471 C Iblock=2 Proline type
7472 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7473 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7474 C        if (itype(i+1).eq.ntyp1) iblock=3
7475 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7476 C IS or IS NOT need for this
7477 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7478 C        is (itype(i-3).eq.ntyp1) ntblock=2
7479 C        ntblock is N-terminal blocking group
7480
7481 C Regular cosine and sine terms
7482         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7483 C Example of changes for NH3+ blocking group
7484 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7485 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7486           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7487           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7488           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7489           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7490           cosphi1=dcos(j*phii)
7491           sinphi1=dsin(j*phii)
7492           cosphi2=dcos(j*phii1)
7493           sinphi2=dsin(j*phii1)
7494           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7495      &     v2cij*cosphi2+v2sij*sinphi2
7496           if (energy_dec) etors_d_ii=etors_d_ii+
7497      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7498           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7499           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7500         enddo
7501         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7502           do l=1,k-1
7503             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7504             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7505             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7506             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7507             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7508             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7509             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7510             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7511             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7512      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7513             if (energy_dec) etors_d_ii=etors_d_ii+
7514      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7515      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7516             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7517      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7518             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7519      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7520           enddo
7521         enddo
7522           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7523      &         'etor_d',i,etors_d_ii
7524         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7525         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7526       enddo
7527       return
7528       end
7529 #endif
7530 c------------------------------------------------------------------------------
7531       subroutine eback_sc_corr(esccor)
7532 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7533 c        conformational states; temporarily implemented as differences
7534 c        between UNRES torsional potentials (dependent on three types of
7535 c        residues) and the torsional potentials dependent on all 20 types
7536 c        of residues computed from AM1  energy surfaces of terminally-blocked
7537 c        amino-acid residues.
7538       implicit real*8 (a-h,o-z)
7539       include 'DIMENSIONS'
7540       include 'COMMON.VAR'
7541       include 'COMMON.GEO'
7542       include 'COMMON.LOCAL'
7543       include 'COMMON.TORSION'
7544       include 'COMMON.SCCOR'
7545       include 'COMMON.INTERACT'
7546       include 'COMMON.DERIV'
7547       include 'COMMON.CHAIN'
7548       include 'COMMON.NAMES'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.FFIELD'
7551       include 'COMMON.CONTROL'
7552       logical lprn
7553 C Set lprn=.true. for debugging
7554       lprn=.false.
7555 c      lprn=.true.
7556 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7557       esccor=0.0D0
7558       do i=itau_start,itau_end
7559         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7560         isccori=isccortyp(itype(i-2))
7561         isccori1=isccortyp(itype(i-1))
7562 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7563         phii=phi(i)
7564         do intertyp=1,3 !intertyp
7565          esccor_ii=0.0D0
7566 cc Added 09 May 2012 (Adasko)
7567 cc  Intertyp means interaction type of backbone mainchain correlation:
7568 c   1 = SC...Ca...Ca...Ca
7569 c   2 = Ca...Ca...Ca...SC
7570 c   3 = SC...Ca...Ca...SCi
7571         gloci=0.0D0
7572         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7573      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7574      &      (itype(i-1).eq.ntyp1)))
7575      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7576      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7577      &     .or.(itype(i).eq.ntyp1)))
7578      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7579      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7580      &      (itype(i-3).eq.ntyp1)))) cycle
7581         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7582         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7583      & cycle
7584        do j=1,nterm_sccor(isccori,isccori1)
7585           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7586           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7587           cosphi=dcos(j*tauangle(intertyp,i))
7588           sinphi=dsin(j*tauangle(intertyp,i))
7589           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7590           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7591           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7592         enddo
7593          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7594      &         'esccor',i,intertyp,esccor_ii
7595 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7596         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7597         if (lprn)
7598      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7599      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7600      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7601      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7602         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7603        enddo !intertyp
7604       enddo
7605
7606       return
7607       end
7608 c----------------------------------------------------------------------------
7609       subroutine multibody(ecorr)
7610 C This subroutine calculates multi-body contributions to energy following
7611 C the idea of Skolnick et al. If side chains I and J make a contact and
7612 C at the same time side chains I+1 and J+1 make a contact, an extra
7613 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7614       implicit real*8 (a-h,o-z)
7615       include 'DIMENSIONS'
7616       include 'COMMON.IOUNITS'
7617       include 'COMMON.DERIV'
7618       include 'COMMON.INTERACT'
7619       include 'COMMON.CONTACTS'
7620       double precision gx(3),gx1(3)
7621       logical lprn
7622
7623 C Set lprn=.true. for debugging
7624       lprn=.false.
7625
7626       if (lprn) then
7627         write (iout,'(a)') 'Contact function values:'
7628         do i=nnt,nct-2
7629           write (iout,'(i2,20(1x,i2,f10.5))')
7630      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7631         enddo
7632       endif
7633       ecorr=0.0D0
7634       do i=nnt,nct
7635         do j=1,3
7636           gradcorr(j,i)=0.0D0
7637           gradxorr(j,i)=0.0D0
7638         enddo
7639       enddo
7640       do i=nnt,nct-2
7641
7642         DO ISHIFT = 3,4
7643
7644         i1=i+ishift
7645         num_conti=num_cont(i)
7646         num_conti1=num_cont(i1)
7647         do jj=1,num_conti
7648           j=jcont(jj,i)
7649           do kk=1,num_conti1
7650             j1=jcont(kk,i1)
7651             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7652 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7653 cd   &                   ' ishift=',ishift
7654 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7655 C The system gains extra energy.
7656               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7657             endif   ! j1==j+-ishift
7658           enddo     ! kk
7659         enddo       ! jj
7660
7661         ENDDO ! ISHIFT
7662
7663       enddo         ! i
7664       return
7665       end
7666 c------------------------------------------------------------------------------
7667       double precision function esccorr(i,j,k,l,jj,kk)
7668       implicit real*8 (a-h,o-z)
7669       include 'DIMENSIONS'
7670       include 'COMMON.IOUNITS'
7671       include 'COMMON.DERIV'
7672       include 'COMMON.INTERACT'
7673       include 'COMMON.CONTACTS'
7674       double precision gx(3),gx1(3)
7675       logical lprn
7676       lprn=.false.
7677       eij=facont(jj,i)
7678       ekl=facont(kk,k)
7679 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7680 C Calculate the multi-body contribution to energy.
7681 C Calculate multi-body contributions to the gradient.
7682 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7683 cd   & k,l,(gacont(m,kk,k),m=1,3)
7684       do m=1,3
7685         gx(m) =ekl*gacont(m,jj,i)
7686         gx1(m)=eij*gacont(m,kk,k)
7687         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7688         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7689         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7690         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7691       enddo
7692       do m=i,j-1
7693         do ll=1,3
7694           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7695         enddo
7696       enddo
7697       do m=k,l-1
7698         do ll=1,3
7699           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7700         enddo
7701       enddo
7702       esccorr=-eij*ekl
7703       return
7704       end
7705 c------------------------------------------------------------------------------
7706       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7707 C This subroutine calculates multi-body contributions to hydrogen-bonding
7708       implicit real*8 (a-h,o-z)
7709       include 'DIMENSIONS'
7710       include 'COMMON.IOUNITS'
7711 #ifdef MPI
7712       include "mpif.h"
7713       parameter (max_cont=maxconts)
7714       parameter (max_dim=26)
7715       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7716       double precision zapas(max_dim,maxconts,max_fg_procs),
7717      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7718       common /przechowalnia/ zapas
7719       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7720      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7721 #endif
7722       include 'COMMON.SETUP'
7723       include 'COMMON.FFIELD'
7724       include 'COMMON.DERIV'
7725       include 'COMMON.INTERACT'
7726       include 'COMMON.CONTACTS'
7727       include 'COMMON.CONTROL'
7728       include 'COMMON.LOCAL'
7729       double precision gx(3),gx1(3),time00
7730       logical lprn,ldone
7731
7732 C Set lprn=.true. for debugging
7733       lprn=.false.
7734 #ifdef MPI
7735       n_corr=0
7736       n_corr1=0
7737       if (nfgtasks.le.1) goto 30
7738       if (lprn) then
7739         write (iout,'(a)') 'Contact function values before RECEIVE:'
7740         do i=nnt,nct-2
7741           write (iout,'(2i3,50(1x,i2,f5.2))')
7742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7743      &    j=1,num_cont_hb(i))
7744         enddo
7745       endif
7746       call flush(iout)
7747       do i=1,ntask_cont_from
7748         ncont_recv(i)=0
7749       enddo
7750       do i=1,ntask_cont_to
7751         ncont_sent(i)=0
7752       enddo
7753 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7754 c     & ntask_cont_to
7755 C Make the list of contacts to send to send to other procesors
7756 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7757 c      call flush(iout)
7758       do i=iturn3_start,iturn3_end
7759 c        write (iout,*) "make contact list turn3",i," num_cont",
7760 c     &    num_cont_hb(i)
7761         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7762       enddo
7763       do i=iturn4_start,iturn4_end
7764 c        write (iout,*) "make contact list turn4",i," num_cont",
7765 c     &   num_cont_hb(i)
7766         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7767       enddo
7768       do ii=1,nat_sent
7769         i=iat_sent(ii)
7770 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7771 c     &    num_cont_hb(i)
7772         do j=1,num_cont_hb(i)
7773         do k=1,4
7774           jjc=jcont_hb(j,i)
7775           iproc=iint_sent_local(k,jjc,ii)
7776 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7777           if (iproc.gt.0) then
7778             ncont_sent(iproc)=ncont_sent(iproc)+1
7779             nn=ncont_sent(iproc)
7780             zapas(1,nn,iproc)=i
7781             zapas(2,nn,iproc)=jjc
7782             zapas(3,nn,iproc)=facont_hb(j,i)
7783             zapas(4,nn,iproc)=ees0p(j,i)
7784             zapas(5,nn,iproc)=ees0m(j,i)
7785             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7786             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7787             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7788             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7789             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7790             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7791             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7792             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7793             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7794             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7795             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7796             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7797             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7798             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7799             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7800             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7801             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7802             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7803             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7804             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7805             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7806           endif
7807         enddo
7808         enddo
7809       enddo
7810       if (lprn) then
7811       write (iout,*)
7812      &  "Numbers of contacts to be sent to other processors",
7813      &  (ncont_sent(i),i=1,ntask_cont_to)
7814       write (iout,*) "Contacts sent"
7815       do ii=1,ntask_cont_to
7816         nn=ncont_sent(ii)
7817         iproc=itask_cont_to(ii)
7818         write (iout,*) nn," contacts to processor",iproc,
7819      &   " of CONT_TO_COMM group"
7820         do i=1,nn
7821           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7822         enddo
7823       enddo
7824       call flush(iout)
7825       endif
7826       CorrelType=477
7827       CorrelID=fg_rank+1
7828       CorrelType1=478
7829       CorrelID1=nfgtasks+fg_rank+1
7830       ireq=0
7831 C Receive the numbers of needed contacts from other processors
7832       do ii=1,ntask_cont_from
7833         iproc=itask_cont_from(ii)
7834         ireq=ireq+1
7835         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7836      &    FG_COMM,req(ireq),IERR)
7837       enddo
7838 c      write (iout,*) "IRECV ended"
7839 c      call flush(iout)
7840 C Send the number of contacts needed by other processors
7841       do ii=1,ntask_cont_to
7842         iproc=itask_cont_to(ii)
7843         ireq=ireq+1
7844         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7845      &    FG_COMM,req(ireq),IERR)
7846       enddo
7847 c      write (iout,*) "ISEND ended"
7848 c      write (iout,*) "number of requests (nn)",ireq
7849       call flush(iout)
7850       if (ireq.gt.0)
7851      &  call MPI_Waitall(ireq,req,status_array,ierr)
7852 c      write (iout,*)
7853 c     &  "Numbers of contacts to be received from other processors",
7854 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7855 c      call flush(iout)
7856 C Receive contacts
7857       ireq=0
7858       do ii=1,ntask_cont_from
7859         iproc=itask_cont_from(ii)
7860         nn=ncont_recv(ii)
7861 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7862 c     &   " of CONT_TO_COMM group"
7863         call flush(iout)
7864         if (nn.gt.0) then
7865           ireq=ireq+1
7866           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7867      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7868 c          write (iout,*) "ireq,req",ireq,req(ireq)
7869         endif
7870       enddo
7871 C Send the contacts to processors that need them
7872       do ii=1,ntask_cont_to
7873         iproc=itask_cont_to(ii)
7874         nn=ncont_sent(ii)
7875 c        write (iout,*) nn," contacts to processor",iproc,
7876 c     &   " of CONT_TO_COMM group"
7877         if (nn.gt.0) then
7878           ireq=ireq+1
7879           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7880      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7881 c          write (iout,*) "ireq,req",ireq,req(ireq)
7882 c          do i=1,nn
7883 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7884 c          enddo
7885         endif
7886       enddo
7887 c      write (iout,*) "number of requests (contacts)",ireq
7888 c      write (iout,*) "req",(req(i),i=1,4)
7889 c      call flush(iout)
7890       if (ireq.gt.0)
7891      & call MPI_Waitall(ireq,req,status_array,ierr)
7892       do iii=1,ntask_cont_from
7893         iproc=itask_cont_from(iii)
7894         nn=ncont_recv(iii)
7895         if (lprn) then
7896         write (iout,*) "Received",nn," contacts from processor",iproc,
7897      &   " of CONT_FROM_COMM group"
7898         call flush(iout)
7899         do i=1,nn
7900           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7901         enddo
7902         call flush(iout)
7903         endif
7904         do i=1,nn
7905           ii=zapas_recv(1,i,iii)
7906 c Flag the received contacts to prevent double-counting
7907           jj=-zapas_recv(2,i,iii)
7908 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7909 c          call flush(iout)
7910           nnn=num_cont_hb(ii)+1
7911           num_cont_hb(ii)=nnn
7912           jcont_hb(nnn,ii)=jj
7913           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7914           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7915           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7916           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7917           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7918           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7919           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7920           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7921           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7922           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7923           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7924           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7925           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7926           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7927           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7928           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7929           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7930           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7931           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7932           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7933           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7934           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7935           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7936           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7937         enddo
7938       enddo
7939       call flush(iout)
7940       if (lprn) then
7941         write (iout,'(a)') 'Contact function values after receive:'
7942         do i=nnt,nct-2
7943           write (iout,'(2i3,50(1x,i3,f5.2))')
7944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7945      &    j=1,num_cont_hb(i))
7946         enddo
7947         call flush(iout)
7948       endif
7949    30 continue
7950 #endif
7951       if (lprn) then
7952         write (iout,'(a)') 'Contact function values:'
7953         do i=nnt,nct-2
7954           write (iout,'(2i3,50(1x,i3,f5.2))')
7955      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7956      &    j=1,num_cont_hb(i))
7957         enddo
7958       endif
7959       ecorr=0.0D0
7960 C Remove the loop below after debugging !!!
7961       do i=nnt,nct
7962         do j=1,3
7963           gradcorr(j,i)=0.0D0
7964           gradxorr(j,i)=0.0D0
7965         enddo
7966       enddo
7967 C Calculate the local-electrostatic correlation terms
7968       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7969         i1=i+1
7970         num_conti=num_cont_hb(i)
7971         num_conti1=num_cont_hb(i+1)
7972         do jj=1,num_conti
7973           j=jcont_hb(jj,i)
7974           jp=iabs(j)
7975           do kk=1,num_conti1
7976             j1=jcont_hb(kk,i1)
7977             jp1=iabs(j1)
7978 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7979 c     &         ' jj=',jj,' kk=',kk
7980             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7981      &          .or. j.lt.0 .and. j1.gt.0) .and.
7982      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7983 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7984 C The system gains extra energy.
7985               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7986               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7987      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7988               n_corr=n_corr+1
7989             else if (j1.eq.j) then
7990 C Contacts I-J and I-(J+1) occur simultaneously.
7991 C The system loses extra energy.
7992 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7993             endif
7994           enddo ! kk
7995           do kk=1,num_conti
7996             j1=jcont_hb(kk,i)
7997 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7998 c    &         ' jj=',jj,' kk=',kk
7999             if (j1.eq.j+1) then
8000 C Contacts I-J and (I+1)-J occur simultaneously.
8001 C The system loses extra energy.
8002 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8003             endif ! j1==j+1
8004           enddo ! kk
8005         enddo ! jj
8006       enddo ! i
8007       return
8008       end
8009 c------------------------------------------------------------------------------
8010       subroutine add_hb_contact(ii,jj,itask)
8011       implicit real*8 (a-h,o-z)
8012       include "DIMENSIONS"
8013       include "COMMON.IOUNITS"
8014       integer max_cont
8015       integer max_dim
8016       parameter (max_cont=maxconts)
8017       parameter (max_dim=26)
8018       include "COMMON.CONTACTS"
8019       double precision zapas(max_dim,maxconts,max_fg_procs),
8020      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8021       common /przechowalnia/ zapas
8022       integer i,j,ii,jj,iproc,itask(4),nn
8023 c      write (iout,*) "itask",itask
8024       do i=1,2
8025         iproc=itask(i)
8026         if (iproc.gt.0) then
8027           do j=1,num_cont_hb(ii)
8028             jjc=jcont_hb(j,ii)
8029 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8030             if (jjc.eq.jj) then
8031               ncont_sent(iproc)=ncont_sent(iproc)+1
8032               nn=ncont_sent(iproc)
8033               zapas(1,nn,iproc)=ii
8034               zapas(2,nn,iproc)=jjc
8035               zapas(3,nn,iproc)=facont_hb(j,ii)
8036               zapas(4,nn,iproc)=ees0p(j,ii)
8037               zapas(5,nn,iproc)=ees0m(j,ii)
8038               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8039               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8040               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8041               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8042               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8043               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8044               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8045               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8046               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8047               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8048               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8049               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8050               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8051               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8052               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8053               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8054               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8055               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8056               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8057               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8058               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8059               exit
8060             endif
8061           enddo
8062         endif
8063       enddo
8064       return
8065       end
8066 c------------------------------------------------------------------------------
8067       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8068      &  n_corr1)
8069 C This subroutine calculates multi-body contributions to hydrogen-bonding
8070       implicit real*8 (a-h,o-z)
8071       include 'DIMENSIONS'
8072       include 'COMMON.IOUNITS'
8073 #ifdef MPI
8074       include "mpif.h"
8075       parameter (max_cont=maxconts)
8076       parameter (max_dim=70)
8077       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8078       double precision zapas(max_dim,maxconts,max_fg_procs),
8079      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8080       common /przechowalnia/ zapas
8081       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8082      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8083 #endif
8084       include 'COMMON.SETUP'
8085       include 'COMMON.FFIELD'
8086       include 'COMMON.DERIV'
8087       include 'COMMON.LOCAL'
8088       include 'COMMON.INTERACT'
8089       include 'COMMON.CONTACTS'
8090       include 'COMMON.CHAIN'
8091       include 'COMMON.CONTROL'
8092       double precision gx(3),gx1(3)
8093       integer num_cont_hb_old(maxres)
8094       logical lprn,ldone
8095       double precision eello4,eello5,eelo6,eello_turn6
8096       external eello4,eello5,eello6,eello_turn6
8097 C Set lprn=.true. for debugging
8098       lprn=.false.
8099       eturn6=0.0d0
8100 #ifdef MPI
8101       do i=1,nres
8102         num_cont_hb_old(i)=num_cont_hb(i)
8103       enddo
8104       n_corr=0
8105       n_corr1=0
8106       if (nfgtasks.le.1) goto 30
8107       if (lprn) then
8108         write (iout,'(a)') 'Contact function values before RECEIVE:'
8109         do i=nnt,nct-2
8110           write (iout,'(2i3,50(1x,i2,f5.2))')
8111      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8112      &    j=1,num_cont_hb(i))
8113         enddo
8114       endif
8115       call flush(iout)
8116       do i=1,ntask_cont_from
8117         ncont_recv(i)=0
8118       enddo
8119       do i=1,ntask_cont_to
8120         ncont_sent(i)=0
8121       enddo
8122 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8123 c     & ntask_cont_to
8124 C Make the list of contacts to send to send to other procesors
8125       do i=iturn3_start,iturn3_end
8126 c        write (iout,*) "make contact list turn3",i," num_cont",
8127 c     &    num_cont_hb(i)
8128         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8129       enddo
8130       do i=iturn4_start,iturn4_end
8131 c        write (iout,*) "make contact list turn4",i," num_cont",
8132 c     &   num_cont_hb(i)
8133         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8134       enddo
8135       do ii=1,nat_sent
8136         i=iat_sent(ii)
8137 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8138 c     &    num_cont_hb(i)
8139         do j=1,num_cont_hb(i)
8140         do k=1,4
8141           jjc=jcont_hb(j,i)
8142           iproc=iint_sent_local(k,jjc,ii)
8143 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8144           if (iproc.ne.0) then
8145             ncont_sent(iproc)=ncont_sent(iproc)+1
8146             nn=ncont_sent(iproc)
8147             zapas(1,nn,iproc)=i
8148             zapas(2,nn,iproc)=jjc
8149             zapas(3,nn,iproc)=d_cont(j,i)
8150             ind=3
8151             do kk=1,3
8152               ind=ind+1
8153               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8154             enddo
8155             do kk=1,2
8156               do ll=1,2
8157                 ind=ind+1
8158                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8159               enddo
8160             enddo
8161             do jj=1,5
8162               do kk=1,3
8163                 do ll=1,2
8164                   do mm=1,2
8165                     ind=ind+1
8166                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8167                   enddo
8168                 enddo
8169               enddo
8170             enddo
8171           endif
8172         enddo
8173         enddo
8174       enddo
8175       if (lprn) then
8176       write (iout,*)
8177      &  "Numbers of contacts to be sent to other processors",
8178      &  (ncont_sent(i),i=1,ntask_cont_to)
8179       write (iout,*) "Contacts sent"
8180       do ii=1,ntask_cont_to
8181         nn=ncont_sent(ii)
8182         iproc=itask_cont_to(ii)
8183         write (iout,*) nn," contacts to processor",iproc,
8184      &   " of CONT_TO_COMM group"
8185         do i=1,nn
8186           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8187         enddo
8188       enddo
8189       call flush(iout)
8190       endif
8191       CorrelType=477
8192       CorrelID=fg_rank+1
8193       CorrelType1=478
8194       CorrelID1=nfgtasks+fg_rank+1
8195       ireq=0
8196 C Receive the numbers of needed contacts from other processors
8197       do ii=1,ntask_cont_from
8198         iproc=itask_cont_from(ii)
8199         ireq=ireq+1
8200         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8201      &    FG_COMM,req(ireq),IERR)
8202       enddo
8203 c      write (iout,*) "IRECV ended"
8204 c      call flush(iout)
8205 C Send the number of contacts needed by other processors
8206       do ii=1,ntask_cont_to
8207         iproc=itask_cont_to(ii)
8208         ireq=ireq+1
8209         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8210      &    FG_COMM,req(ireq),IERR)
8211       enddo
8212 c      write (iout,*) "ISEND ended"
8213 c      write (iout,*) "number of requests (nn)",ireq
8214       call flush(iout)
8215       if (ireq.gt.0)
8216      &  call MPI_Waitall(ireq,req,status_array,ierr)
8217 c      write (iout,*)
8218 c     &  "Numbers of contacts to be received from other processors",
8219 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8220 c      call flush(iout)
8221 C Receive contacts
8222       ireq=0
8223       do ii=1,ntask_cont_from
8224         iproc=itask_cont_from(ii)
8225         nn=ncont_recv(ii)
8226 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8227 c     &   " of CONT_TO_COMM group"
8228         call flush(iout)
8229         if (nn.gt.0) then
8230           ireq=ireq+1
8231           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8232      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8233 c          write (iout,*) "ireq,req",ireq,req(ireq)
8234         endif
8235       enddo
8236 C Send the contacts to processors that need them
8237       do ii=1,ntask_cont_to
8238         iproc=itask_cont_to(ii)
8239         nn=ncont_sent(ii)
8240 c        write (iout,*) nn," contacts to processor",iproc,
8241 c     &   " of CONT_TO_COMM group"
8242         if (nn.gt.0) then
8243           ireq=ireq+1
8244           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8245      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8246 c          write (iout,*) "ireq,req",ireq,req(ireq)
8247 c          do i=1,nn
8248 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8249 c          enddo
8250         endif
8251       enddo
8252 c      write (iout,*) "number of requests (contacts)",ireq
8253 c      write (iout,*) "req",(req(i),i=1,4)
8254 c      call flush(iout)
8255       if (ireq.gt.0)
8256      & call MPI_Waitall(ireq,req,status_array,ierr)
8257       do iii=1,ntask_cont_from
8258         iproc=itask_cont_from(iii)
8259         nn=ncont_recv(iii)
8260         if (lprn) then
8261         write (iout,*) "Received",nn," contacts from processor",iproc,
8262      &   " of CONT_FROM_COMM group"
8263         call flush(iout)
8264         do i=1,nn
8265           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8266         enddo
8267         call flush(iout)
8268         endif
8269         do i=1,nn
8270           ii=zapas_recv(1,i,iii)
8271 c Flag the received contacts to prevent double-counting
8272           jj=-zapas_recv(2,i,iii)
8273 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8274 c          call flush(iout)
8275           nnn=num_cont_hb(ii)+1
8276           num_cont_hb(ii)=nnn
8277           jcont_hb(nnn,ii)=jj
8278           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8279           ind=3
8280           do kk=1,3
8281             ind=ind+1
8282             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8283           enddo
8284           do kk=1,2
8285             do ll=1,2
8286               ind=ind+1
8287               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8288             enddo
8289           enddo
8290           do jj=1,5
8291             do kk=1,3
8292               do ll=1,2
8293                 do mm=1,2
8294                   ind=ind+1
8295                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8296                 enddo
8297               enddo
8298             enddo
8299           enddo
8300         enddo
8301       enddo
8302       call flush(iout)
8303       if (lprn) then
8304         write (iout,'(a)') 'Contact function values after receive:'
8305         do i=nnt,nct-2
8306           write (iout,'(2i3,50(1x,i3,5f6.3))')
8307      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8308      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8309         enddo
8310         call flush(iout)
8311       endif
8312    30 continue
8313 #endif
8314       if (lprn) then
8315         write (iout,'(a)') 'Contact function values:'
8316         do i=nnt,nct-2
8317           write (iout,'(2i3,50(1x,i2,5f6.3))')
8318      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8319      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8320         enddo
8321       endif
8322       ecorr=0.0D0
8323       ecorr5=0.0d0
8324       ecorr6=0.0d0
8325 C Remove the loop below after debugging !!!
8326       do i=nnt,nct
8327         do j=1,3
8328           gradcorr(j,i)=0.0D0
8329           gradxorr(j,i)=0.0D0
8330         enddo
8331       enddo
8332 C Calculate the dipole-dipole interaction energies
8333       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8334       do i=iatel_s,iatel_e+1
8335         num_conti=num_cont_hb(i)
8336         do jj=1,num_conti
8337           j=jcont_hb(jj,i)
8338 #ifdef MOMENT
8339           call dipole(i,j,jj)
8340 #endif
8341         enddo
8342       enddo
8343       endif
8344 C Calculate the local-electrostatic correlation terms
8345 c                write (iout,*) "gradcorr5 in eello5 before loop"
8346 c                do iii=1,nres
8347 c                  write (iout,'(i5,3f10.5)')
8348 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8349 c                enddo
8350       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8351 c        write (iout,*) "corr loop i",i
8352         i1=i+1
8353         num_conti=num_cont_hb(i)
8354         num_conti1=num_cont_hb(i+1)
8355         do jj=1,num_conti
8356           j=jcont_hb(jj,i)
8357           jp=iabs(j)
8358           do kk=1,num_conti1
8359             j1=jcont_hb(kk,i1)
8360             jp1=iabs(j1)
8361 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8362 c     &         ' jj=',jj,' kk=',kk
8363 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8364             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8365      &          .or. j.lt.0 .and. j1.gt.0) .and.
8366      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8367 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8368 C The system gains extra energy.
8369               n_corr=n_corr+1
8370               sqd1=dsqrt(d_cont(jj,i))
8371               sqd2=dsqrt(d_cont(kk,i1))
8372               sred_geom = sqd1*sqd2
8373               IF (sred_geom.lt.cutoff_corr) THEN
8374                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8375      &            ekont,fprimcont)
8376 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8377 cd     &         ' jj=',jj,' kk=',kk
8378                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8379                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8380                 do l=1,3
8381                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8382                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8383                 enddo
8384                 n_corr1=n_corr1+1
8385 cd               write (iout,*) 'sred_geom=',sred_geom,
8386 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8387 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8388 cd               write (iout,*) "g_contij",g_contij
8389 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8390 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8391                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8392                 if (wcorr4.gt.0.0d0)
8393      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8394                   if (energy_dec.and.wcorr4.gt.0.0d0)
8395      1                 write (iout,'(a6,4i5,0pf7.3)')
8396      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8397 c                write (iout,*) "gradcorr5 before eello5"
8398 c                do iii=1,nres
8399 c                  write (iout,'(i5,3f10.5)')
8400 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8401 c                enddo
8402                 if (wcorr5.gt.0.0d0)
8403      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8404 c                write (iout,*) "gradcorr5 after eello5"
8405 c                do iii=1,nres
8406 c                  write (iout,'(i5,3f10.5)')
8407 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8408 c                enddo
8409                   if (energy_dec.and.wcorr5.gt.0.0d0)
8410      1                 write (iout,'(a6,4i5,0pf7.3)')
8411      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8412 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8413 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8414                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8415      &               .or. wturn6.eq.0.0d0))then
8416 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8417                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8418                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8419      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8420 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8421 cd     &            'ecorr6=',ecorr6
8422 cd                write (iout,'(4e15.5)') sred_geom,
8423 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8424 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8425 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8426                 else if (wturn6.gt.0.0d0
8427      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8428 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8429                   eturn6=eturn6+eello_turn6(i,jj,kk)
8430                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8431      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8432 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8433                 endif
8434               ENDIF
8435 1111          continue
8436             endif
8437           enddo ! kk
8438         enddo ! jj
8439       enddo ! i
8440       do i=1,nres
8441         num_cont_hb(i)=num_cont_hb_old(i)
8442       enddo
8443 c                write (iout,*) "gradcorr5 in eello5"
8444 c                do iii=1,nres
8445 c                  write (iout,'(i5,3f10.5)')
8446 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8447 c                enddo
8448       return
8449       end
8450 c------------------------------------------------------------------------------
8451       subroutine add_hb_contact_eello(ii,jj,itask)
8452       implicit real*8 (a-h,o-z)
8453       include "DIMENSIONS"
8454       include "COMMON.IOUNITS"
8455       integer max_cont
8456       integer max_dim
8457       parameter (max_cont=maxconts)
8458       parameter (max_dim=70)
8459       include "COMMON.CONTACTS"
8460       double precision zapas(max_dim,maxconts,max_fg_procs),
8461      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8462       common /przechowalnia/ zapas
8463       integer i,j,ii,jj,iproc,itask(4),nn
8464 c      write (iout,*) "itask",itask
8465       do i=1,2
8466         iproc=itask(i)
8467         if (iproc.gt.0) then
8468           do j=1,num_cont_hb(ii)
8469             jjc=jcont_hb(j,ii)
8470 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8471             if (jjc.eq.jj) then
8472               ncont_sent(iproc)=ncont_sent(iproc)+1
8473               nn=ncont_sent(iproc)
8474               zapas(1,nn,iproc)=ii
8475               zapas(2,nn,iproc)=jjc
8476               zapas(3,nn,iproc)=d_cont(j,ii)
8477               ind=3
8478               do kk=1,3
8479                 ind=ind+1
8480                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8481               enddo
8482               do kk=1,2
8483                 do ll=1,2
8484                   ind=ind+1
8485                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8486                 enddo
8487               enddo
8488               do jj=1,5
8489                 do kk=1,3
8490                   do ll=1,2
8491                     do mm=1,2
8492                       ind=ind+1
8493                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8494                     enddo
8495                   enddo
8496                 enddo
8497               enddo
8498               exit
8499             endif
8500           enddo
8501         endif
8502       enddo
8503       return
8504       end
8505 c------------------------------------------------------------------------------
8506       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8507       implicit real*8 (a-h,o-z)
8508       include 'DIMENSIONS'
8509       include 'COMMON.IOUNITS'
8510       include 'COMMON.DERIV'
8511       include 'COMMON.INTERACT'
8512       include 'COMMON.CONTACTS'
8513       double precision gx(3),gx1(3)
8514       logical lprn
8515       lprn=.false.
8516       eij=facont_hb(jj,i)
8517       ekl=facont_hb(kk,k)
8518       ees0pij=ees0p(jj,i)
8519       ees0pkl=ees0p(kk,k)
8520       ees0mij=ees0m(jj,i)
8521       ees0mkl=ees0m(kk,k)
8522       ekont=eij*ekl
8523       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8524 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8525 C Following 4 lines for diagnostics.
8526 cd    ees0pkl=0.0D0
8527 cd    ees0pij=1.0D0
8528 cd    ees0mkl=0.0D0
8529 cd    ees0mij=1.0D0
8530 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8531 c     & 'Contacts ',i,j,
8532 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8533 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8534 c     & 'gradcorr_long'
8535 C Calculate the multi-body contribution to energy.
8536 c      ecorr=ecorr+ekont*ees
8537 C Calculate multi-body contributions to the gradient.
8538       coeffpees0pij=coeffp*ees0pij
8539       coeffmees0mij=coeffm*ees0mij
8540       coeffpees0pkl=coeffp*ees0pkl
8541       coeffmees0mkl=coeffm*ees0mkl
8542       do ll=1,3
8543 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8544         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8545      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8546      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8547         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8548      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8549      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8550 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8551         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8552      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8553      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8554         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8555      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8556      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8557         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8558      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8559      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8560         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8561         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8562         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8563      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8564      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8565         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8566         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8567 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8568       enddo
8569 c      write (iout,*)
8570 cgrad      do m=i+1,j-1
8571 cgrad        do ll=1,3
8572 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8573 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8574 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8575 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8576 cgrad        enddo
8577 cgrad      enddo
8578 cgrad      do m=k+1,l-1
8579 cgrad        do ll=1,3
8580 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8581 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8582 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8583 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8584 cgrad        enddo
8585 cgrad      enddo
8586 c      write (iout,*) "ehbcorr",ekont*ees
8587       ehbcorr=ekont*ees
8588       return
8589       end
8590 #ifdef MOMENT
8591 C---------------------------------------------------------------------------
8592       subroutine dipole(i,j,jj)
8593       implicit real*8 (a-h,o-z)
8594       include 'DIMENSIONS'
8595       include 'COMMON.IOUNITS'
8596       include 'COMMON.CHAIN'
8597       include 'COMMON.FFIELD'
8598       include 'COMMON.DERIV'
8599       include 'COMMON.INTERACT'
8600       include 'COMMON.CONTACTS'
8601       include 'COMMON.TORSION'
8602       include 'COMMON.VAR'
8603       include 'COMMON.GEO'
8604       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8605      &  auxmat(2,2)
8606       iti1 = itortyp(itype(i+1))
8607       if (j.lt.nres-1) then
8608         itj1 = itortyp(itype(j+1))
8609       else
8610         itj1=ntortyp
8611       endif
8612       do iii=1,2
8613         dipi(iii,1)=Ub2(iii,i)
8614         dipderi(iii)=Ub2der(iii,i)
8615         dipi(iii,2)=b1(iii,i+1)
8616         dipj(iii,1)=Ub2(iii,j)
8617         dipderj(iii)=Ub2der(iii,j)
8618         dipj(iii,2)=b1(iii,j+1)
8619       enddo
8620       kkk=0
8621       do iii=1,2
8622         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8623         do jjj=1,2
8624           kkk=kkk+1
8625           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8626         enddo
8627       enddo
8628       do kkk=1,5
8629         do lll=1,3
8630           mmm=0
8631           do iii=1,2
8632             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8633      &        auxvec(1))
8634             do jjj=1,2
8635               mmm=mmm+1
8636               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8637             enddo
8638           enddo
8639         enddo
8640       enddo
8641       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8642       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8643       do iii=1,2
8644         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8645       enddo
8646       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8647       do iii=1,2
8648         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8649       enddo
8650       return
8651       end
8652 #endif
8653 C---------------------------------------------------------------------------
8654       subroutine calc_eello(i,j,k,l,jj,kk)
8655 C
8656 C This subroutine computes matrices and vectors needed to calculate
8657 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8658 C
8659       implicit real*8 (a-h,o-z)
8660       include 'DIMENSIONS'
8661       include 'COMMON.IOUNITS'
8662       include 'COMMON.CHAIN'
8663       include 'COMMON.DERIV'
8664       include 'COMMON.INTERACT'
8665       include 'COMMON.CONTACTS'
8666       include 'COMMON.TORSION'
8667       include 'COMMON.VAR'
8668       include 'COMMON.GEO'
8669       include 'COMMON.FFIELD'
8670       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8671      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8672       logical lprn
8673       common /kutas/ lprn
8674 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8675 cd     & ' jj=',jj,' kk=',kk
8676 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8677 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8678 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8679       do iii=1,2
8680         do jjj=1,2
8681           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8682           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8683         enddo
8684       enddo
8685       call transpose2(aa1(1,1),aa1t(1,1))
8686       call transpose2(aa2(1,1),aa2t(1,1))
8687       do kkk=1,5
8688         do lll=1,3
8689           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8690      &      aa1tder(1,1,lll,kkk))
8691           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8692      &      aa2tder(1,1,lll,kkk))
8693         enddo
8694       enddo
8695       if (l.eq.j+1) then
8696 C parallel orientation of the two CA-CA-CA frames.
8697         if (i.gt.1) then
8698           iti=itortyp(itype(i))
8699         else
8700           iti=ntortyp
8701         endif
8702         itk1=itortyp(itype(k+1))
8703         itj=itortyp(itype(j))
8704         if (l.lt.nres-1) then
8705           itl1=itortyp(itype(l+1))
8706         else
8707           itl1=ntortyp
8708         endif
8709 C A1 kernel(j+1) A2T
8710 cd        do iii=1,2
8711 cd          write (iout,'(3f10.5,5x,3f10.5)')
8712 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8713 cd        enddo
8714         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8715      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8716      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8717 C Following matrices are needed only for 6-th order cumulants
8718         IF (wcorr6.gt.0.0d0) THEN
8719         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8720      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8721      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8722         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8723      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8724      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8725      &   ADtEAderx(1,1,1,1,1,1))
8726         lprn=.false.
8727         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8728      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8729      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8730      &   ADtEA1derx(1,1,1,1,1,1))
8731         ENDIF
8732 C End 6-th order cumulants
8733 cd        lprn=.false.
8734 cd        if (lprn) then
8735 cd        write (2,*) 'In calc_eello6'
8736 cd        do iii=1,2
8737 cd          write (2,*) 'iii=',iii
8738 cd          do kkk=1,5
8739 cd            write (2,*) 'kkk=',kkk
8740 cd            do jjj=1,2
8741 cd              write (2,'(3(2f10.5),5x)')
8742 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8743 cd            enddo
8744 cd          enddo
8745 cd        enddo
8746 cd        endif
8747         call transpose2(EUgder(1,1,k),auxmat(1,1))
8748         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8749         call transpose2(EUg(1,1,k),auxmat(1,1))
8750         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8751         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8752         do iii=1,2
8753           do kkk=1,5
8754             do lll=1,3
8755               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8756      &          EAEAderx(1,1,lll,kkk,iii,1))
8757             enddo
8758           enddo
8759         enddo
8760 C A1T kernel(i+1) A2
8761         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8762      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8763      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8764 C Following matrices are needed only for 6-th order cumulants
8765         IF (wcorr6.gt.0.0d0) THEN
8766         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8767      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8768      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8769         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8770      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8771      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8772      &   ADtEAderx(1,1,1,1,1,2))
8773         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8774      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8775      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8776      &   ADtEA1derx(1,1,1,1,1,2))
8777         ENDIF
8778 C End 6-th order cumulants
8779         call transpose2(EUgder(1,1,l),auxmat(1,1))
8780         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8781         call transpose2(EUg(1,1,l),auxmat(1,1))
8782         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8783         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8784         do iii=1,2
8785           do kkk=1,5
8786             do lll=1,3
8787               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8788      &          EAEAderx(1,1,lll,kkk,iii,2))
8789             enddo
8790           enddo
8791         enddo
8792 C AEAb1 and AEAb2
8793 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8794 C They are needed only when the fifth- or the sixth-order cumulants are
8795 C indluded.
8796         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8797         call transpose2(AEA(1,1,1),auxmat(1,1))
8798         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8799         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8800         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8801         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8802         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8803         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8804         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8805         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8806         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8807         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8808         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8809         call transpose2(AEA(1,1,2),auxmat(1,1))
8810         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8811         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8812         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8813         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8814         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8815         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8816         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8817         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8818         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8819         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8820         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8821 C Calculate the Cartesian derivatives of the vectors.
8822         do iii=1,2
8823           do kkk=1,5
8824             do lll=1,3
8825               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8826               call matvec2(auxmat(1,1),b1(1,i),
8827      &          AEAb1derx(1,lll,kkk,iii,1,1))
8828               call matvec2(auxmat(1,1),Ub2(1,i),
8829      &          AEAb2derx(1,lll,kkk,iii,1,1))
8830               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8831      &          AEAb1derx(1,lll,kkk,iii,2,1))
8832               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8833      &          AEAb2derx(1,lll,kkk,iii,2,1))
8834               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8835               call matvec2(auxmat(1,1),b1(1,j),
8836      &          AEAb1derx(1,lll,kkk,iii,1,2))
8837               call matvec2(auxmat(1,1),Ub2(1,j),
8838      &          AEAb2derx(1,lll,kkk,iii,1,2))
8839               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8840      &          AEAb1derx(1,lll,kkk,iii,2,2))
8841               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8842      &          AEAb2derx(1,lll,kkk,iii,2,2))
8843             enddo
8844           enddo
8845         enddo
8846         ENDIF
8847 C End vectors
8848       else
8849 C Antiparallel orientation of the two CA-CA-CA frames.
8850         if (i.gt.1) then
8851           iti=itortyp(itype(i))
8852         else
8853           iti=ntortyp
8854         endif
8855         itk1=itortyp(itype(k+1))
8856         itl=itortyp(itype(l))
8857         itj=itortyp(itype(j))
8858         if (j.lt.nres-1) then
8859           itj1=itortyp(itype(j+1))
8860         else
8861           itj1=ntortyp
8862         endif
8863 C A2 kernel(j-1)T A1T
8864         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8865      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8866      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8867 C Following matrices are needed only for 6-th order cumulants
8868         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8869      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8870         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8871      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8872      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8873         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8874      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8875      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8876      &   ADtEAderx(1,1,1,1,1,1))
8877         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8878      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8879      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8880      &   ADtEA1derx(1,1,1,1,1,1))
8881         ENDIF
8882 C End 6-th order cumulants
8883         call transpose2(EUgder(1,1,k),auxmat(1,1))
8884         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8885         call transpose2(EUg(1,1,k),auxmat(1,1))
8886         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8887         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8888         do iii=1,2
8889           do kkk=1,5
8890             do lll=1,3
8891               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8892      &          EAEAderx(1,1,lll,kkk,iii,1))
8893             enddo
8894           enddo
8895         enddo
8896 C A2T kernel(i+1)T A1
8897         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8898      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8899      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8900 C Following matrices are needed only for 6-th order cumulants
8901         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8902      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8903         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8904      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8905      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8906         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8907      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8908      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8909      &   ADtEAderx(1,1,1,1,1,2))
8910         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8911      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8912      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8913      &   ADtEA1derx(1,1,1,1,1,2))
8914         ENDIF
8915 C End 6-th order cumulants
8916         call transpose2(EUgder(1,1,j),auxmat(1,1))
8917         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8918         call transpose2(EUg(1,1,j),auxmat(1,1))
8919         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8920         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8921         do iii=1,2
8922           do kkk=1,5
8923             do lll=1,3
8924               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8925      &          EAEAderx(1,1,lll,kkk,iii,2))
8926             enddo
8927           enddo
8928         enddo
8929 C AEAb1 and AEAb2
8930 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8931 C They are needed only when the fifth- or the sixth-order cumulants are
8932 C indluded.
8933         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8934      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8935         call transpose2(AEA(1,1,1),auxmat(1,1))
8936         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8937         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8938         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8939         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8940         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8941         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8942         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8943         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8944         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8945         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8946         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8947         call transpose2(AEA(1,1,2),auxmat(1,1))
8948         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8949         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8950         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8951         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8952         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8953         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8954         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8955         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8956         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8957         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8958         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8959 C Calculate the Cartesian derivatives of the vectors.
8960         do iii=1,2
8961           do kkk=1,5
8962             do lll=1,3
8963               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8964               call matvec2(auxmat(1,1),b1(1,i),
8965      &          AEAb1derx(1,lll,kkk,iii,1,1))
8966               call matvec2(auxmat(1,1),Ub2(1,i),
8967      &          AEAb2derx(1,lll,kkk,iii,1,1))
8968               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8969      &          AEAb1derx(1,lll,kkk,iii,2,1))
8970               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8971      &          AEAb2derx(1,lll,kkk,iii,2,1))
8972               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8973               call matvec2(auxmat(1,1),b1(1,l),
8974      &          AEAb1derx(1,lll,kkk,iii,1,2))
8975               call matvec2(auxmat(1,1),Ub2(1,l),
8976      &          AEAb2derx(1,lll,kkk,iii,1,2))
8977               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8978      &          AEAb1derx(1,lll,kkk,iii,2,2))
8979               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8980      &          AEAb2derx(1,lll,kkk,iii,2,2))
8981             enddo
8982           enddo
8983         enddo
8984         ENDIF
8985 C End vectors
8986       endif
8987       return
8988       end
8989 C---------------------------------------------------------------------------
8990       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8991      &  KK,KKderg,AKA,AKAderg,AKAderx)
8992       implicit none
8993       integer nderg
8994       logical transp
8995       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8996      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8997      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8998       integer iii,kkk,lll
8999       integer jjj,mmm
9000       logical lprn
9001       common /kutas/ lprn
9002       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9003       do iii=1,nderg
9004         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9005      &    AKAderg(1,1,iii))
9006       enddo
9007 cd      if (lprn) write (2,*) 'In kernel'
9008       do kkk=1,5
9009 cd        if (lprn) write (2,*) 'kkk=',kkk
9010         do lll=1,3
9011           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9012      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9013 cd          if (lprn) then
9014 cd            write (2,*) 'lll=',lll
9015 cd            write (2,*) 'iii=1'
9016 cd            do jjj=1,2
9017 cd              write (2,'(3(2f10.5),5x)')
9018 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9019 cd            enddo
9020 cd          endif
9021           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9022      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9023 cd          if (lprn) then
9024 cd            write (2,*) 'lll=',lll
9025 cd            write (2,*) 'iii=2'
9026 cd            do jjj=1,2
9027 cd              write (2,'(3(2f10.5),5x)')
9028 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9029 cd            enddo
9030 cd          endif
9031         enddo
9032       enddo
9033       return
9034       end
9035 C---------------------------------------------------------------------------
9036       double precision function eello4(i,j,k,l,jj,kk)
9037       implicit real*8 (a-h,o-z)
9038       include 'DIMENSIONS'
9039       include 'COMMON.IOUNITS'
9040       include 'COMMON.CHAIN'
9041       include 'COMMON.DERIV'
9042       include 'COMMON.INTERACT'
9043       include 'COMMON.CONTACTS'
9044       include 'COMMON.TORSION'
9045       include 'COMMON.VAR'
9046       include 'COMMON.GEO'
9047       double precision pizda(2,2),ggg1(3),ggg2(3)
9048 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9049 cd        eello4=0.0d0
9050 cd        return
9051 cd      endif
9052 cd      print *,'eello4:',i,j,k,l,jj,kk
9053 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9054 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9055 cold      eij=facont_hb(jj,i)
9056 cold      ekl=facont_hb(kk,k)
9057 cold      ekont=eij*ekl
9058       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9059 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9060       gcorr_loc(k-1)=gcorr_loc(k-1)
9061      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9062       if (l.eq.j+1) then
9063         gcorr_loc(l-1)=gcorr_loc(l-1)
9064      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9065       else
9066         gcorr_loc(j-1)=gcorr_loc(j-1)
9067      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9068       endif
9069       do iii=1,2
9070         do kkk=1,5
9071           do lll=1,3
9072             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9073      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9074 cd            derx(lll,kkk,iii)=0.0d0
9075           enddo
9076         enddo
9077       enddo
9078 cd      gcorr_loc(l-1)=0.0d0
9079 cd      gcorr_loc(j-1)=0.0d0
9080 cd      gcorr_loc(k-1)=0.0d0
9081 cd      eel4=1.0d0
9082 cd      write (iout,*)'Contacts have occurred for peptide groups',
9083 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9084 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9085       if (j.lt.nres-1) then
9086         j1=j+1
9087         j2=j-1
9088       else
9089         j1=j-1
9090         j2=j-2
9091       endif
9092       if (l.lt.nres-1) then
9093         l1=l+1
9094         l2=l-1
9095       else
9096         l1=l-1
9097         l2=l-2
9098       endif
9099       do ll=1,3
9100 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9101 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9102         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9103         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9104 cgrad        ghalf=0.5d0*ggg1(ll)
9105         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9106         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9107         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9108         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9109         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9110         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9111 cgrad        ghalf=0.5d0*ggg2(ll)
9112         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9113         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9114         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9115         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9116         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9117         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9118       enddo
9119 cgrad      do m=i+1,j-1
9120 cgrad        do ll=1,3
9121 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9122 cgrad        enddo
9123 cgrad      enddo
9124 cgrad      do m=k+1,l-1
9125 cgrad        do ll=1,3
9126 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9127 cgrad        enddo
9128 cgrad      enddo
9129 cgrad      do m=i+2,j2
9130 cgrad        do ll=1,3
9131 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9132 cgrad        enddo
9133 cgrad      enddo
9134 cgrad      do m=k+2,l2
9135 cgrad        do ll=1,3
9136 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9137 cgrad        enddo
9138 cgrad      enddo
9139 cd      do iii=1,nres-3
9140 cd        write (2,*) iii,gcorr_loc(iii)
9141 cd      enddo
9142       eello4=ekont*eel4
9143 cd      write (2,*) 'ekont',ekont
9144 cd      write (iout,*) 'eello4',ekont*eel4
9145       return
9146       end
9147 C---------------------------------------------------------------------------
9148       double precision function eello5(i,j,k,l,jj,kk)
9149       implicit real*8 (a-h,o-z)
9150       include 'DIMENSIONS'
9151       include 'COMMON.IOUNITS'
9152       include 'COMMON.CHAIN'
9153       include 'COMMON.DERIV'
9154       include 'COMMON.INTERACT'
9155       include 'COMMON.CONTACTS'
9156       include 'COMMON.TORSION'
9157       include 'COMMON.VAR'
9158       include 'COMMON.GEO'
9159       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9160       double precision ggg1(3),ggg2(3)
9161 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9162 C                                                                              C
9163 C                            Parallel chains                                   C
9164 C                                                                              C
9165 C          o             o                   o             o                   C
9166 C         /l\           / \             \   / \           / \   /              C
9167 C        /   \         /   \             \ /   \         /   \ /               C
9168 C       j| o |l1       | o |              o| o |         | o |o                C
9169 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9170 C      \i/   \         /   \ /             /   \         /   \                 C
9171 C       o    k1             o                                                  C
9172 C         (I)          (II)                (III)          (IV)                 C
9173 C                                                                              C
9174 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9175 C                                                                              C
9176 C                            Antiparallel chains                               C
9177 C                                                                              C
9178 C          o             o                   o             o                   C
9179 C         /j\           / \             \   / \           / \   /              C
9180 C        /   \         /   \             \ /   \         /   \ /               C
9181 C      j1| o |l        | o |              o| o |         | o |o                C
9182 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9183 C      \i/   \         /   \ /             /   \         /   \                 C
9184 C       o     k1            o                                                  C
9185 C         (I)          (II)                (III)          (IV)                 C
9186 C                                                                              C
9187 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9188 C                                                                              C
9189 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9190 C                                                                              C
9191 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9192 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9193 cd        eello5=0.0d0
9194 cd        return
9195 cd      endif
9196 cd      write (iout,*)
9197 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9198 cd     &   ' and',k,l
9199       itk=itortyp(itype(k))
9200       itl=itortyp(itype(l))
9201       itj=itortyp(itype(j))
9202       eello5_1=0.0d0
9203       eello5_2=0.0d0
9204       eello5_3=0.0d0
9205       eello5_4=0.0d0
9206 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9207 cd     &   eel5_3_num,eel5_4_num)
9208       do iii=1,2
9209         do kkk=1,5
9210           do lll=1,3
9211             derx(lll,kkk,iii)=0.0d0
9212           enddo
9213         enddo
9214       enddo
9215 cd      eij=facont_hb(jj,i)
9216 cd      ekl=facont_hb(kk,k)
9217 cd      ekont=eij*ekl
9218 cd      write (iout,*)'Contacts have occurred for peptide groups',
9219 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9220 cd      goto 1111
9221 C Contribution from the graph I.
9222 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9223 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9224       call transpose2(EUg(1,1,k),auxmat(1,1))
9225       call matmat2(AEA(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       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9229      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9230 C Explicit gradient in virtual-dihedral angles.
9231       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9232      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9233      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9234       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9235       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9236       vv(1)=pizda(1,1)-pizda(2,2)
9237       vv(2)=pizda(1,2)+pizda(2,1)
9238       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9239      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9240      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9241       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9242       vv(1)=pizda(1,1)-pizda(2,2)
9243       vv(2)=pizda(1,2)+pizda(2,1)
9244       if (l.eq.j+1) then
9245         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9246      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9248       else
9249         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9250      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9251      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9252       endif
9253 C Cartesian gradient
9254       do iii=1,2
9255         do kkk=1,5
9256           do lll=1,3
9257             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9258      &        pizda(1,1))
9259             vv(1)=pizda(1,1)-pizda(2,2)
9260             vv(2)=pizda(1,2)+pizda(2,1)
9261             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9262      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9263      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9264           enddo
9265         enddo
9266       enddo
9267 c      goto 1112
9268 c1111  continue
9269 C Contribution from graph II
9270       call transpose2(EE(1,1,itk),auxmat(1,1))
9271       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9272       vv(1)=pizda(1,1)+pizda(2,2)
9273       vv(2)=pizda(2,1)-pizda(1,2)
9274       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9275      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9276 C Explicit gradient in virtual-dihedral angles.
9277       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9278      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9279       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9280       vv(1)=pizda(1,1)+pizda(2,2)
9281       vv(2)=pizda(2,1)-pizda(1,2)
9282       if (l.eq.j+1) then
9283         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9284      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9285      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9286       else
9287         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9288      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9289      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9290       endif
9291 C Cartesian gradient
9292       do iii=1,2
9293         do kkk=1,5
9294           do lll=1,3
9295             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9296      &        pizda(1,1))
9297             vv(1)=pizda(1,1)+pizda(2,2)
9298             vv(2)=pizda(2,1)-pizda(1,2)
9299             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9300      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9301      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9302           enddo
9303         enddo
9304       enddo
9305 cd      goto 1112
9306 cd1111  continue
9307       if (l.eq.j+1) then
9308 cd        goto 1110
9309 C Parallel orientation
9310 C Contribution from graph III
9311         call transpose2(EUg(1,1,l),auxmat(1,1))
9312         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9313         vv(1)=pizda(1,1)-pizda(2,2)
9314         vv(2)=pizda(1,2)+pizda(2,1)
9315         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9316      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9317 C Explicit gradient in virtual-dihedral angles.
9318         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9319      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9320      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9321         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9322         vv(1)=pizda(1,1)-pizda(2,2)
9323         vv(2)=pizda(1,2)+pizda(2,1)
9324         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9325      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9326      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9327         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9328         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9329         vv(1)=pizda(1,1)-pizda(2,2)
9330         vv(2)=pizda(1,2)+pizda(2,1)
9331         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9332      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9333      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9334 C Cartesian gradient
9335         do iii=1,2
9336           do kkk=1,5
9337             do lll=1,3
9338               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9339      &          pizda(1,1))
9340               vv(1)=pizda(1,1)-pizda(2,2)
9341               vv(2)=pizda(1,2)+pizda(2,1)
9342               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9343      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9344      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9345             enddo
9346           enddo
9347         enddo
9348 cd        goto 1112
9349 C Contribution from graph IV
9350 cd1110    continue
9351         call transpose2(EE(1,1,itl),auxmat(1,1))
9352         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9353         vv(1)=pizda(1,1)+pizda(2,2)
9354         vv(2)=pizda(2,1)-pizda(1,2)
9355         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9356      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9357 C Explicit gradient in virtual-dihedral angles.
9358         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9359      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9360         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9361         vv(1)=pizda(1,1)+pizda(2,2)
9362         vv(2)=pizda(2,1)-pizda(1,2)
9363         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9364      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9365      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9366 C Cartesian gradient
9367         do iii=1,2
9368           do kkk=1,5
9369             do lll=1,3
9370               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9371      &          pizda(1,1))
9372               vv(1)=pizda(1,1)+pizda(2,2)
9373               vv(2)=pizda(2,1)-pizda(1,2)
9374               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9375      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9376      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9377             enddo
9378           enddo
9379         enddo
9380       else
9381 C Antiparallel orientation
9382 C Contribution from graph III
9383 c        goto 1110
9384         call transpose2(EUg(1,1,j),auxmat(1,1))
9385         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9386         vv(1)=pizda(1,1)-pizda(2,2)
9387         vv(2)=pizda(1,2)+pizda(2,1)
9388         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9389      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9390 C Explicit gradient in virtual-dihedral angles.
9391         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9392      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9393      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9394         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9395         vv(1)=pizda(1,1)-pizda(2,2)
9396         vv(2)=pizda(1,2)+pizda(2,1)
9397         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9398      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9399      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9400         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9401         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9402         vv(1)=pizda(1,1)-pizda(2,2)
9403         vv(2)=pizda(1,2)+pizda(2,1)
9404         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9405      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9406      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9407 C Cartesian gradient
9408         do iii=1,2
9409           do kkk=1,5
9410             do lll=1,3
9411               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9412      &          pizda(1,1))
9413               vv(1)=pizda(1,1)-pizda(2,2)
9414               vv(2)=pizda(1,2)+pizda(2,1)
9415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9416      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9417      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9418             enddo
9419           enddo
9420         enddo
9421 cd        goto 1112
9422 C Contribution from graph IV
9423 1110    continue
9424         call transpose2(EE(1,1,itj),auxmat(1,1))
9425         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9426         vv(1)=pizda(1,1)+pizda(2,2)
9427         vv(2)=pizda(2,1)-pizda(1,2)
9428         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9429      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9430 C Explicit gradient in virtual-dihedral angles.
9431         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9432      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9433         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9434         vv(1)=pizda(1,1)+pizda(2,2)
9435         vv(2)=pizda(2,1)-pizda(1,2)
9436         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9437      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9438      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9439 C Cartesian gradient
9440         do iii=1,2
9441           do kkk=1,5
9442             do lll=1,3
9443               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9444      &          pizda(1,1))
9445               vv(1)=pizda(1,1)+pizda(2,2)
9446               vv(2)=pizda(2,1)-pizda(1,2)
9447               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9448      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9449      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9450             enddo
9451           enddo
9452         enddo
9453       endif
9454 1112  continue
9455       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9456 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9457 cd        write (2,*) 'ijkl',i,j,k,l
9458 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9459 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9460 cd      endif
9461 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9462 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9463 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9464 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9465       if (j.lt.nres-1) then
9466         j1=j+1
9467         j2=j-1
9468       else
9469         j1=j-1
9470         j2=j-2
9471       endif
9472       if (l.lt.nres-1) then
9473         l1=l+1
9474         l2=l-1
9475       else
9476         l1=l-1
9477         l2=l-2
9478       endif
9479 cd      eij=1.0d0
9480 cd      ekl=1.0d0
9481 cd      ekont=1.0d0
9482 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9483 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9484 C        summed up outside the subrouine as for the other subroutines
9485 C        handling long-range interactions. The old code is commented out
9486 C        with "cgrad" to keep track of changes.
9487       do ll=1,3
9488 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9489 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9490         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9491         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9492 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9493 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9494 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9495 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9496 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9497 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9498 c     &   gradcorr5ij,
9499 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9500 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9501 cgrad        ghalf=0.5d0*ggg1(ll)
9502 cd        ghalf=0.0d0
9503         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9504         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9505         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9506         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9507         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9508         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9509 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9510 cgrad        ghalf=0.5d0*ggg2(ll)
9511 cd        ghalf=0.0d0
9512         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9513         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9514         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9515         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9516         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9517         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9518       enddo
9519 cd      goto 1112
9520 cgrad      do m=i+1,j-1
9521 cgrad        do ll=1,3
9522 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9523 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9524 cgrad        enddo
9525 cgrad      enddo
9526 cgrad      do m=k+1,l-1
9527 cgrad        do ll=1,3
9528 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9529 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9530 cgrad        enddo
9531 cgrad      enddo
9532 c1112  continue
9533 cgrad      do m=i+2,j2
9534 cgrad        do ll=1,3
9535 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9536 cgrad        enddo
9537 cgrad      enddo
9538 cgrad      do m=k+2,l2
9539 cgrad        do ll=1,3
9540 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9541 cgrad        enddo
9542 cgrad      enddo
9543 cd      do iii=1,nres-3
9544 cd        write (2,*) iii,g_corr5_loc(iii)
9545 cd      enddo
9546       eello5=ekont*eel5
9547 cd      write (2,*) 'ekont',ekont
9548 cd      write (iout,*) 'eello5',ekont*eel5
9549       return
9550       end
9551 c--------------------------------------------------------------------------
9552       double precision function eello6(i,j,k,l,jj,kk)
9553       implicit real*8 (a-h,o-z)
9554       include 'DIMENSIONS'
9555       include 'COMMON.IOUNITS'
9556       include 'COMMON.CHAIN'
9557       include 'COMMON.DERIV'
9558       include 'COMMON.INTERACT'
9559       include 'COMMON.CONTACTS'
9560       include 'COMMON.TORSION'
9561       include 'COMMON.VAR'
9562       include 'COMMON.GEO'
9563       include 'COMMON.FFIELD'
9564       double precision ggg1(3),ggg2(3)
9565 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9566 cd        eello6=0.0d0
9567 cd        return
9568 cd      endif
9569 cd      write (iout,*)
9570 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9571 cd     &   ' and',k,l
9572       eello6_1=0.0d0
9573       eello6_2=0.0d0
9574       eello6_3=0.0d0
9575       eello6_4=0.0d0
9576       eello6_5=0.0d0
9577       eello6_6=0.0d0
9578 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9579 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9580       do iii=1,2
9581         do kkk=1,5
9582           do lll=1,3
9583             derx(lll,kkk,iii)=0.0d0
9584           enddo
9585         enddo
9586       enddo
9587 cd      eij=facont_hb(jj,i)
9588 cd      ekl=facont_hb(kk,k)
9589 cd      ekont=eij*ekl
9590 cd      eij=1.0d0
9591 cd      ekl=1.0d0
9592 cd      ekont=1.0d0
9593       if (l.eq.j+1) then
9594         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9595         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9596         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9597         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9598         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9599         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9600       else
9601         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9602         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9603         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9604         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9605         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9606           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9607         else
9608           eello6_5=0.0d0
9609         endif
9610         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9611       endif
9612 C If turn contributions are considered, they will be handled separately.
9613       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9614 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9615 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9616 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9617 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9618 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9619 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9620 cd      goto 1112
9621       if (j.lt.nres-1) then
9622         j1=j+1
9623         j2=j-1
9624       else
9625         j1=j-1
9626         j2=j-2
9627       endif
9628       if (l.lt.nres-1) then
9629         l1=l+1
9630         l2=l-1
9631       else
9632         l1=l-1
9633         l2=l-2
9634       endif
9635       do ll=1,3
9636 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9637 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9638 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9639 cgrad        ghalf=0.5d0*ggg1(ll)
9640 cd        ghalf=0.0d0
9641         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9642         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9643         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9644         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9645         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9646         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9647         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9648         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9649 cgrad        ghalf=0.5d0*ggg2(ll)
9650 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9651 cd        ghalf=0.0d0
9652         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9653         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9654         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9655         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9656         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9657         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9658       enddo
9659 cd      goto 1112
9660 cgrad      do m=i+1,j-1
9661 cgrad        do ll=1,3
9662 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9663 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9664 cgrad        enddo
9665 cgrad      enddo
9666 cgrad      do m=k+1,l-1
9667 cgrad        do ll=1,3
9668 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9669 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9670 cgrad        enddo
9671 cgrad      enddo
9672 cgrad1112  continue
9673 cgrad      do m=i+2,j2
9674 cgrad        do ll=1,3
9675 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9676 cgrad        enddo
9677 cgrad      enddo
9678 cgrad      do m=k+2,l2
9679 cgrad        do ll=1,3
9680 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9681 cgrad        enddo
9682 cgrad      enddo
9683 cd      do iii=1,nres-3
9684 cd        write (2,*) iii,g_corr6_loc(iii)
9685 cd      enddo
9686       eello6=ekont*eel6
9687 cd      write (2,*) 'ekont',ekont
9688 cd      write (iout,*) 'eello6',ekont*eel6
9689       return
9690       end
9691 c--------------------------------------------------------------------------
9692       double precision function eello6_graph1(i,j,k,l,imat,swap)
9693       implicit real*8 (a-h,o-z)
9694       include 'DIMENSIONS'
9695       include 'COMMON.IOUNITS'
9696       include 'COMMON.CHAIN'
9697       include 'COMMON.DERIV'
9698       include 'COMMON.INTERACT'
9699       include 'COMMON.CONTACTS'
9700       include 'COMMON.TORSION'
9701       include 'COMMON.VAR'
9702       include 'COMMON.GEO'
9703       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9704       logical swap
9705       logical lprn
9706       common /kutas/ lprn
9707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9708 C                                                                              C
9709 C      Parallel       Antiparallel                                             C
9710 C                                                                              C
9711 C          o             o                                                     C
9712 C         /l\           /j\                                                    C
9713 C        /   \         /   \                                                   C
9714 C       /| o |         | o |\                                                  C
9715 C     \ j|/k\|  /   \  |/k\|l /                                                C
9716 C      \ /   \ /     \ /   \ /                                                 C
9717 C       o     o       o     o                                                  C
9718 C       i             i                                                        C
9719 C                                                                              C
9720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9721       itk=itortyp(itype(k))
9722       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9723       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9724       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9725       call transpose2(EUgC(1,1,k),auxmat(1,1))
9726       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9727       vv1(1)=pizda1(1,1)-pizda1(2,2)
9728       vv1(2)=pizda1(1,2)+pizda1(2,1)
9729       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9730       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9731       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9732       s5=scalar2(vv(1),Dtobr2(1,i))
9733 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9734       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9735       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9736      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9737      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9738      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9739      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9740      & +scalar2(vv(1),Dtobr2der(1,i)))
9741       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9742       vv1(1)=pizda1(1,1)-pizda1(2,2)
9743       vv1(2)=pizda1(1,2)+pizda1(2,1)
9744       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9745       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9746       if (l.eq.j+1) then
9747         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9748      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9749      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9750      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9751      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9752       else
9753         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9754      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9755      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9756      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9757      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9758       endif
9759       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9760       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9761       vv1(1)=pizda1(1,1)-pizda1(2,2)
9762       vv1(2)=pizda1(1,2)+pizda1(2,1)
9763       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9764      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9765      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9766      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9767       do iii=1,2
9768         if (swap) then
9769           ind=3-iii
9770         else
9771           ind=iii
9772         endif
9773         do kkk=1,5
9774           do lll=1,3
9775             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9776             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9777             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9778             call transpose2(EUgC(1,1,k),auxmat(1,1))
9779             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9780      &        pizda1(1,1))
9781             vv1(1)=pizda1(1,1)-pizda1(2,2)
9782             vv1(2)=pizda1(1,2)+pizda1(2,1)
9783             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9784             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9785      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9786             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9787      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9788             s5=scalar2(vv(1),Dtobr2(1,i))
9789             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9790           enddo
9791         enddo
9792       enddo
9793       return
9794       end
9795 c----------------------------------------------------------------------------
9796       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9797       implicit real*8 (a-h,o-z)
9798       include 'DIMENSIONS'
9799       include 'COMMON.IOUNITS'
9800       include 'COMMON.CHAIN'
9801       include 'COMMON.DERIV'
9802       include 'COMMON.INTERACT'
9803       include 'COMMON.CONTACTS'
9804       include 'COMMON.TORSION'
9805       include 'COMMON.VAR'
9806       include 'COMMON.GEO'
9807       logical swap
9808       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9809      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9810       logical lprn
9811       common /kutas/ lprn
9812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9813 C                                                                              C
9814 C      Parallel       Antiparallel                                             C
9815 C                                                                              C
9816 C          o             o                                                     C
9817 C     \   /l\           /j\   /                                                C
9818 C      \ /   \         /   \ /                                                 C
9819 C       o| o |         | o |o                                                  C
9820 C     \ j|/k\|      \  |/k\|l                                                  C
9821 C      \ /   \       \ /   \                                                   C
9822 C       o             o                                                        C
9823 C       i             i                                                        C
9824 C                                                                              C
9825 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9826 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9827 C AL 7/4/01 s1 would occur in the sixth-order moment,
9828 C           but not in a cluster cumulant
9829 #ifdef MOMENT
9830       s1=dip(1,jj,i)*dip(1,kk,k)
9831 #endif
9832       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9833       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9834       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9835       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9836       call transpose2(EUg(1,1,k),auxmat(1,1))
9837       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9838       vv(1)=pizda(1,1)-pizda(2,2)
9839       vv(2)=pizda(1,2)+pizda(2,1)
9840       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9841 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9842 #ifdef MOMENT
9843       eello6_graph2=-(s1+s2+s3+s4)
9844 #else
9845       eello6_graph2=-(s2+s3+s4)
9846 #endif
9847 c      eello6_graph2=-s3
9848 C Derivatives in gamma(i-1)
9849       if (i.gt.1) then
9850 #ifdef MOMENT
9851         s1=dipderg(1,jj,i)*dip(1,kk,k)
9852 #endif
9853         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9854         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9855         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9856         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9857 #ifdef MOMENT
9858         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9859 #else
9860         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9861 #endif
9862 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9863       endif
9864 C Derivatives in gamma(k-1)
9865 #ifdef MOMENT
9866       s1=dip(1,jj,i)*dipderg(1,kk,k)
9867 #endif
9868       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9869       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9870       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9871       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9872       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9873       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9874       vv(1)=pizda(1,1)-pizda(2,2)
9875       vv(2)=pizda(1,2)+pizda(2,1)
9876       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9877 #ifdef MOMENT
9878       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9879 #else
9880       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9881 #endif
9882 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9883 C Derivatives in gamma(j-1) or gamma(l-1)
9884       if (j.gt.1) then
9885 #ifdef MOMENT
9886         s1=dipderg(3,jj,i)*dip(1,kk,k)
9887 #endif
9888         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9889         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9890         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9891         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9892         vv(1)=pizda(1,1)-pizda(2,2)
9893         vv(2)=pizda(1,2)+pizda(2,1)
9894         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9895 #ifdef MOMENT
9896         if (swap) then
9897           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9898         else
9899           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9900         endif
9901 #endif
9902         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9903 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9904       endif
9905 C Derivatives in gamma(l-1) or gamma(j-1)
9906       if (l.gt.1) then
9907 #ifdef MOMENT
9908         s1=dip(1,jj,i)*dipderg(3,kk,k)
9909 #endif
9910         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9911         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9912         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9913         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9914         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9915         vv(1)=pizda(1,1)-pizda(2,2)
9916         vv(2)=pizda(1,2)+pizda(2,1)
9917         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9918 #ifdef MOMENT
9919         if (swap) then
9920           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9921         else
9922           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9923         endif
9924 #endif
9925         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9926 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9927       endif
9928 C Cartesian derivatives.
9929       if (lprn) then
9930         write (2,*) 'In eello6_graph2'
9931         do iii=1,2
9932           write (2,*) 'iii=',iii
9933           do kkk=1,5
9934             write (2,*) 'kkk=',kkk
9935             do jjj=1,2
9936               write (2,'(3(2f10.5),5x)')
9937      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9938             enddo
9939           enddo
9940         enddo
9941       endif
9942       do iii=1,2
9943         do kkk=1,5
9944           do lll=1,3
9945 #ifdef MOMENT
9946             if (iii.eq.1) then
9947               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9948             else
9949               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9950             endif
9951 #endif
9952             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9953      &        auxvec(1))
9954             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9955             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9956      &        auxvec(1))
9957             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9958             call transpose2(EUg(1,1,k),auxmat(1,1))
9959             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9960      &        pizda(1,1))
9961             vv(1)=pizda(1,1)-pizda(2,2)
9962             vv(2)=pizda(1,2)+pizda(2,1)
9963             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9964 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9965 #ifdef MOMENT
9966             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9967 #else
9968             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9969 #endif
9970             if (swap) then
9971               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9972             else
9973               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9974             endif
9975           enddo
9976         enddo
9977       enddo
9978       return
9979       end
9980 c----------------------------------------------------------------------------
9981       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9982       implicit real*8 (a-h,o-z)
9983       include 'DIMENSIONS'
9984       include 'COMMON.IOUNITS'
9985       include 'COMMON.CHAIN'
9986       include 'COMMON.DERIV'
9987       include 'COMMON.INTERACT'
9988       include 'COMMON.CONTACTS'
9989       include 'COMMON.TORSION'
9990       include 'COMMON.VAR'
9991       include 'COMMON.GEO'
9992       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9993       logical swap
9994 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9995 C                                                                              C
9996 C      Parallel       Antiparallel                                             C
9997 C                                                                              C
9998 C          o             o                                                     C
9999 C         /l\   /   \   /j\                                                    C
10000 C        /   \ /     \ /   \                                                   C
10001 C       /| o |o       o| o |\                                                  C
10002 C       j|/k\|  /      |/k\|l /                                                C
10003 C        /   \ /       /   \ /                                                 C
10004 C       /     o       /     o                                                  C
10005 C       i             i                                                        C
10006 C                                                                              C
10007 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10008 C
10009 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10010 C           energy moment and not to the cluster cumulant.
10011       iti=itortyp(itype(i))
10012       if (j.lt.nres-1) then
10013         itj1=itortyp(itype(j+1))
10014       else
10015         itj1=ntortyp
10016       endif
10017       itk=itortyp(itype(k))
10018       itk1=itortyp(itype(k+1))
10019       if (l.lt.nres-1) then
10020         itl1=itortyp(itype(l+1))
10021       else
10022         itl1=ntortyp
10023       endif
10024 #ifdef MOMENT
10025       s1=dip(4,jj,i)*dip(4,kk,k)
10026 #endif
10027       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10028       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10029       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10030       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10031       call transpose2(EE(1,1,itk),auxmat(1,1))
10032       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10033       vv(1)=pizda(1,1)+pizda(2,2)
10034       vv(2)=pizda(2,1)-pizda(1,2)
10035       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10036 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10037 cd     & "sum",-(s2+s3+s4)
10038 #ifdef MOMENT
10039       eello6_graph3=-(s1+s2+s3+s4)
10040 #else
10041       eello6_graph3=-(s2+s3+s4)
10042 #endif
10043 c      eello6_graph3=-s4
10044 C Derivatives in gamma(k-1)
10045       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10046       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10047       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10048       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10049 C Derivatives in gamma(l-1)
10050       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10051       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10052       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10053       vv(1)=pizda(1,1)+pizda(2,2)
10054       vv(2)=pizda(2,1)-pizda(1,2)
10055       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10056       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10057 C Cartesian derivatives.
10058       do iii=1,2
10059         do kkk=1,5
10060           do lll=1,3
10061 #ifdef MOMENT
10062             if (iii.eq.1) then
10063               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10064             else
10065               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10066             endif
10067 #endif
10068             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10069      &        auxvec(1))
10070             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10071             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10072      &        auxvec(1))
10073             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10074             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10075      &        pizda(1,1))
10076             vv(1)=pizda(1,1)+pizda(2,2)
10077             vv(2)=pizda(2,1)-pizda(1,2)
10078             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10079 #ifdef MOMENT
10080             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10081 #else
10082             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10083 #endif
10084             if (swap) then
10085               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10086             else
10087               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10088             endif
10089 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10090           enddo
10091         enddo
10092       enddo
10093       return
10094       end
10095 c----------------------------------------------------------------------------
10096       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10097       implicit real*8 (a-h,o-z)
10098       include 'DIMENSIONS'
10099       include 'COMMON.IOUNITS'
10100       include 'COMMON.CHAIN'
10101       include 'COMMON.DERIV'
10102       include 'COMMON.INTERACT'
10103       include 'COMMON.CONTACTS'
10104       include 'COMMON.TORSION'
10105       include 'COMMON.VAR'
10106       include 'COMMON.GEO'
10107       include 'COMMON.FFIELD'
10108       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10109      & auxvec1(2),auxmat1(2,2)
10110       logical swap
10111 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10112 C                                                                              C
10113 C      Parallel       Antiparallel                                             C
10114 C                                                                              C
10115 C          o             o                                                     C
10116 C         /l\   /   \   /j\                                                    C
10117 C        /   \ /     \ /   \                                                   C
10118 C       /| o |o       o| o |\                                                  C
10119 C     \ j|/k\|      \  |/k\|l                                                  C
10120 C      \ /   \       \ /   \                                                   C
10121 C       o     \       o     \                                                  C
10122 C       i             i                                                        C
10123 C                                                                              C
10124 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10125 C
10126 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10127 C           energy moment and not to the cluster cumulant.
10128 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10129       iti=itortyp(itype(i))
10130       itj=itortyp(itype(j))
10131       if (j.lt.nres-1) then
10132         itj1=itortyp(itype(j+1))
10133       else
10134         itj1=ntortyp
10135       endif
10136       itk=itortyp(itype(k))
10137       if (k.lt.nres-1) then
10138         itk1=itortyp(itype(k+1))
10139       else
10140         itk1=ntortyp
10141       endif
10142       itl=itortyp(itype(l))
10143       if (l.lt.nres-1) then
10144         itl1=itortyp(itype(l+1))
10145       else
10146         itl1=ntortyp
10147       endif
10148 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10149 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10150 cd     & ' itl',itl,' itl1',itl1
10151 #ifdef MOMENT
10152       if (imat.eq.1) then
10153         s1=dip(3,jj,i)*dip(3,kk,k)
10154       else
10155         s1=dip(2,jj,j)*dip(2,kk,l)
10156       endif
10157 #endif
10158       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10159       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10160       if (j.eq.l+1) then
10161         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10162         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10163       else
10164         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10165         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10166       endif
10167       call transpose2(EUg(1,1,k),auxmat(1,1))
10168       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10169       vv(1)=pizda(1,1)-pizda(2,2)
10170       vv(2)=pizda(2,1)+pizda(1,2)
10171       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10172 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10173 #ifdef MOMENT
10174       eello6_graph4=-(s1+s2+s3+s4)
10175 #else
10176       eello6_graph4=-(s2+s3+s4)
10177 #endif
10178 C Derivatives in gamma(i-1)
10179       if (i.gt.1) then
10180 #ifdef MOMENT
10181         if (imat.eq.1) then
10182           s1=dipderg(2,jj,i)*dip(3,kk,k)
10183         else
10184           s1=dipderg(4,jj,j)*dip(2,kk,l)
10185         endif
10186 #endif
10187         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10188         if (j.eq.l+1) then
10189           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10190           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10191         else
10192           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10193           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10194         endif
10195         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10196         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10197 cd          write (2,*) 'turn6 derivatives'
10198 #ifdef MOMENT
10199           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10200 #else
10201           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10202 #endif
10203         else
10204 #ifdef MOMENT
10205           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10206 #else
10207           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10208 #endif
10209         endif
10210       endif
10211 C Derivatives in gamma(k-1)
10212 #ifdef MOMENT
10213       if (imat.eq.1) then
10214         s1=dip(3,jj,i)*dipderg(2,kk,k)
10215       else
10216         s1=dip(2,jj,j)*dipderg(4,kk,l)
10217       endif
10218 #endif
10219       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10220       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10221       if (j.eq.l+1) then
10222         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10223         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10224       else
10225         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10226         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10227       endif
10228       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10229       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10230       vv(1)=pizda(1,1)-pizda(2,2)
10231       vv(2)=pizda(2,1)+pizda(1,2)
10232       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10233       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10234 #ifdef MOMENT
10235         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10236 #else
10237         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10238 #endif
10239       else
10240 #ifdef MOMENT
10241         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10242 #else
10243         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10244 #endif
10245       endif
10246 C Derivatives in gamma(j-1) or gamma(l-1)
10247       if (l.eq.j+1 .and. l.gt.1) then
10248         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10249         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10250         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10251         vv(1)=pizda(1,1)-pizda(2,2)
10252         vv(2)=pizda(2,1)+pizda(1,2)
10253         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10254         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10255       else if (j.gt.1) then
10256         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10257         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10258         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10259         vv(1)=pizda(1,1)-pizda(2,2)
10260         vv(2)=pizda(2,1)+pizda(1,2)
10261         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10262         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10263           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10264         else
10265           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10266         endif
10267       endif
10268 C Cartesian derivatives.
10269       do iii=1,2
10270         do kkk=1,5
10271           do lll=1,3
10272 #ifdef MOMENT
10273             if (iii.eq.1) then
10274               if (imat.eq.1) then
10275                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10276               else
10277                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10278               endif
10279             else
10280               if (imat.eq.1) then
10281                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10282               else
10283                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10284               endif
10285             endif
10286 #endif
10287             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10288      &        auxvec(1))
10289             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10290             if (j.eq.l+1) then
10291               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10292      &          b1(1,j+1),auxvec(1))
10293               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10294             else
10295               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10296      &          b1(1,l+1),auxvec(1))
10297               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10298             endif
10299             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10300      &        pizda(1,1))
10301             vv(1)=pizda(1,1)-pizda(2,2)
10302             vv(2)=pizda(2,1)+pizda(1,2)
10303             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10304             if (swap) then
10305               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10306 #ifdef MOMENT
10307                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10308      &             -(s1+s2+s4)
10309 #else
10310                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10311      &             -(s2+s4)
10312 #endif
10313                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10314               else
10315 #ifdef MOMENT
10316                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10317 #else
10318                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10319 #endif
10320                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10321               endif
10322             else
10323 #ifdef MOMENT
10324               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10325 #else
10326               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10327 #endif
10328               if (l.eq.j+1) then
10329                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10330               else
10331                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10332               endif
10333             endif
10334           enddo
10335         enddo
10336       enddo
10337       return
10338       end
10339 c----------------------------------------------------------------------------
10340       double precision function eello_turn6(i,jj,kk)
10341       implicit real*8 (a-h,o-z)
10342       include 'DIMENSIONS'
10343       include 'COMMON.IOUNITS'
10344       include 'COMMON.CHAIN'
10345       include 'COMMON.DERIV'
10346       include 'COMMON.INTERACT'
10347       include 'COMMON.CONTACTS'
10348       include 'COMMON.TORSION'
10349       include 'COMMON.VAR'
10350       include 'COMMON.GEO'
10351       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10352      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10353      &  ggg1(3),ggg2(3)
10354       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10355      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10356 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10357 C           the respective energy moment and not to the cluster cumulant.
10358       s1=0.0d0
10359       s8=0.0d0
10360       s13=0.0d0
10361 c
10362       eello_turn6=0.0d0
10363       j=i+4
10364       k=i+1
10365       l=i+3
10366       iti=itortyp(itype(i))
10367       itk=itortyp(itype(k))
10368       itk1=itortyp(itype(k+1))
10369       itl=itortyp(itype(l))
10370       itj=itortyp(itype(j))
10371 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10372 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10373 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10374 cd        eello6=0.0d0
10375 cd        return
10376 cd      endif
10377 cd      write (iout,*)
10378 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10379 cd     &   ' and',k,l
10380 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10381       do iii=1,2
10382         do kkk=1,5
10383           do lll=1,3
10384             derx_turn(lll,kkk,iii)=0.0d0
10385           enddo
10386         enddo
10387       enddo
10388 cd      eij=1.0d0
10389 cd      ekl=1.0d0
10390 cd      ekont=1.0d0
10391       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10392 cd      eello6_5=0.0d0
10393 cd      write (2,*) 'eello6_5',eello6_5
10394 #ifdef MOMENT
10395       call transpose2(AEA(1,1,1),auxmat(1,1))
10396       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10397       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10398       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10399 #endif
10400       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10401       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10402       s2 = scalar2(b1(1,k),vtemp1(1))
10403 #ifdef MOMENT
10404       call transpose2(AEA(1,1,2),atemp(1,1))
10405       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10406       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10407       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10408 #endif
10409       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10410       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10411       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10412 #ifdef MOMENT
10413       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10414       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10415       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10416       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10417       ss13 = scalar2(b1(1,k),vtemp4(1))
10418       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10419 #endif
10420 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10421 c      s1=0.0d0
10422 c      s2=0.0d0
10423 c      s8=0.0d0
10424 c      s12=0.0d0
10425 c      s13=0.0d0
10426       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10427 C Derivatives in gamma(i+2)
10428       s1d =0.0d0
10429       s8d =0.0d0
10430 #ifdef MOMENT
10431       call transpose2(AEA(1,1,1),auxmatd(1,1))
10432       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10433       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10434       call transpose2(AEAderg(1,1,2),atempd(1,1))
10435       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10436       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10437 #endif
10438       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10439       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10440       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10441 c      s1d=0.0d0
10442 c      s2d=0.0d0
10443 c      s8d=0.0d0
10444 c      s12d=0.0d0
10445 c      s13d=0.0d0
10446       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10447 C Derivatives in gamma(i+3)
10448 #ifdef MOMENT
10449       call transpose2(AEA(1,1,1),auxmatd(1,1))
10450       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10451       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10452       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10453 #endif
10454       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10455       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10456       s2d = scalar2(b1(1,k),vtemp1d(1))
10457 #ifdef MOMENT
10458       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10459       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10460 #endif
10461       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10462 #ifdef MOMENT
10463       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10464       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10465       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10466 #endif
10467 c      s1d=0.0d0
10468 c      s2d=0.0d0
10469 c      s8d=0.0d0
10470 c      s12d=0.0d0
10471 c      s13d=0.0d0
10472 #ifdef MOMENT
10473       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10474      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10475 #else
10476       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10477      &               -0.5d0*ekont*(s2d+s12d)
10478 #endif
10479 C Derivatives in gamma(i+4)
10480       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10481       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10482       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10483 #ifdef MOMENT
10484       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10485       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10486       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10487 #endif
10488 c      s1d=0.0d0
10489 c      s2d=0.0d0
10490 c      s8d=0.0d0
10491 C      s12d=0.0d0
10492 c      s13d=0.0d0
10493 #ifdef MOMENT
10494       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10495 #else
10496       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10497 #endif
10498 C Derivatives in gamma(i+5)
10499 #ifdef MOMENT
10500       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10501       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10502       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10503 #endif
10504       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10505       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10506       s2d = scalar2(b1(1,k),vtemp1d(1))
10507 #ifdef MOMENT
10508       call transpose2(AEA(1,1,2),atempd(1,1))
10509       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10510       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10511 #endif
10512       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10513       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10514 #ifdef MOMENT
10515       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10516       ss13d = scalar2(b1(1,k),vtemp4d(1))
10517       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10518 #endif
10519 c      s1d=0.0d0
10520 c      s2d=0.0d0
10521 c      s8d=0.0d0
10522 c      s12d=0.0d0
10523 c      s13d=0.0d0
10524 #ifdef MOMENT
10525       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10526      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10527 #else
10528       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10529      &               -0.5d0*ekont*(s2d+s12d)
10530 #endif
10531 C Cartesian derivatives
10532       do iii=1,2
10533         do kkk=1,5
10534           do lll=1,3
10535 #ifdef MOMENT
10536             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10537             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10538             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10539 #endif
10540             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10541             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10542      &          vtemp1d(1))
10543             s2d = scalar2(b1(1,k),vtemp1d(1))
10544 #ifdef MOMENT
10545             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10546             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10547             s8d = -(atempd(1,1)+atempd(2,2))*
10548      &           scalar2(cc(1,1,itl),vtemp2(1))
10549 #endif
10550             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10551      &           auxmatd(1,1))
10552             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10553             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10554 c      s1d=0.0d0
10555 c      s2d=0.0d0
10556 c      s8d=0.0d0
10557 c      s12d=0.0d0
10558 c      s13d=0.0d0
10559 #ifdef MOMENT
10560             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10561      &        - 0.5d0*(s1d+s2d)
10562 #else
10563             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10564      &        - 0.5d0*s2d
10565 #endif
10566 #ifdef MOMENT
10567             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10568      &        - 0.5d0*(s8d+s12d)
10569 #else
10570             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10571      &        - 0.5d0*s12d
10572 #endif
10573           enddo
10574         enddo
10575       enddo
10576 #ifdef MOMENT
10577       do kkk=1,5
10578         do lll=1,3
10579           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10580      &      achuj_tempd(1,1))
10581           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10582           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10583           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10584           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10585           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10586      &      vtemp4d(1))
10587           ss13d = scalar2(b1(1,k),vtemp4d(1))
10588           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10589           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10590         enddo
10591       enddo
10592 #endif
10593 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10594 cd     &  16*eel_turn6_num
10595 cd      goto 1112
10596       if (j.lt.nres-1) then
10597         j1=j+1
10598         j2=j-1
10599       else
10600         j1=j-1
10601         j2=j-2
10602       endif
10603       if (l.lt.nres-1) then
10604         l1=l+1
10605         l2=l-1
10606       else
10607         l1=l-1
10608         l2=l-2
10609       endif
10610       do ll=1,3
10611 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10612 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10613 cgrad        ghalf=0.5d0*ggg1(ll)
10614 cd        ghalf=0.0d0
10615         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10616         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10617         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10618      &    +ekont*derx_turn(ll,2,1)
10619         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10620         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10621      &    +ekont*derx_turn(ll,4,1)
10622         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10623         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10624         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10625 cgrad        ghalf=0.5d0*ggg2(ll)
10626 cd        ghalf=0.0d0
10627         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10628      &    +ekont*derx_turn(ll,2,2)
10629         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10630         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10631      &    +ekont*derx_turn(ll,4,2)
10632         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10633         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10634         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10635       enddo
10636 cd      goto 1112
10637 cgrad      do m=i+1,j-1
10638 cgrad        do ll=1,3
10639 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10640 cgrad        enddo
10641 cgrad      enddo
10642 cgrad      do m=k+1,l-1
10643 cgrad        do ll=1,3
10644 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10645 cgrad        enddo
10646 cgrad      enddo
10647 cgrad1112  continue
10648 cgrad      do m=i+2,j2
10649 cgrad        do ll=1,3
10650 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10651 cgrad        enddo
10652 cgrad      enddo
10653 cgrad      do m=k+2,l2
10654 cgrad        do ll=1,3
10655 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10656 cgrad        enddo
10657 cgrad      enddo
10658 cd      do iii=1,nres-3
10659 cd        write (2,*) iii,g_corr6_loc(iii)
10660 cd      enddo
10661       eello_turn6=ekont*eel_turn6
10662 cd      write (2,*) 'ekont',ekont
10663 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10664       return
10665       end
10666
10667 C-----------------------------------------------------------------------------
10668       double precision function scalar(u,v)
10669 !DIR$ INLINEALWAYS scalar
10670 #ifndef OSF
10671 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10672 #endif
10673       implicit none
10674       double precision u(3),v(3)
10675 cd      double precision sc
10676 cd      integer i
10677 cd      sc=0.0d0
10678 cd      do i=1,3
10679 cd        sc=sc+u(i)*v(i)
10680 cd      enddo
10681 cd      scalar=sc
10682
10683       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10684       return
10685       end
10686 crc-------------------------------------------------
10687       SUBROUTINE MATVEC2(A1,V1,V2)
10688 !DIR$ INLINEALWAYS MATVEC2
10689 #ifndef OSF
10690 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10691 #endif
10692       implicit real*8 (a-h,o-z)
10693       include 'DIMENSIONS'
10694       DIMENSION A1(2,2),V1(2),V2(2)
10695 c      DO 1 I=1,2
10696 c        VI=0.0
10697 c        DO 3 K=1,2
10698 c    3     VI=VI+A1(I,K)*V1(K)
10699 c        Vaux(I)=VI
10700 c    1 CONTINUE
10701
10702       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10703       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10704
10705       v2(1)=vaux1
10706       v2(2)=vaux2
10707       END
10708 C---------------------------------------
10709       SUBROUTINE MATMAT2(A1,A2,A3)
10710 #ifndef OSF
10711 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10712 #endif
10713       implicit real*8 (a-h,o-z)
10714       include 'DIMENSIONS'
10715       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10716 c      DIMENSION AI3(2,2)
10717 c        DO  J=1,2
10718 c          A3IJ=0.0
10719 c          DO K=1,2
10720 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10721 c          enddo
10722 c          A3(I,J)=A3IJ
10723 c       enddo
10724 c      enddo
10725
10726       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10727       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10728       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10729       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10730
10731       A3(1,1)=AI3_11
10732       A3(2,1)=AI3_21
10733       A3(1,2)=AI3_12
10734       A3(2,2)=AI3_22
10735       END
10736
10737 c-------------------------------------------------------------------------
10738       double precision function scalar2(u,v)
10739 !DIR$ INLINEALWAYS scalar2
10740       implicit none
10741       double precision u(2),v(2)
10742       double precision sc
10743       integer i
10744       scalar2=u(1)*v(1)+u(2)*v(2)
10745       return
10746       end
10747
10748 C-----------------------------------------------------------------------------
10749
10750       subroutine transpose2(a,at)
10751 !DIR$ INLINEALWAYS transpose2
10752 #ifndef OSF
10753 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10754 #endif
10755       implicit none
10756       double precision a(2,2),at(2,2)
10757       at(1,1)=a(1,1)
10758       at(1,2)=a(2,1)
10759       at(2,1)=a(1,2)
10760       at(2,2)=a(2,2)
10761       return
10762       end
10763 c--------------------------------------------------------------------------
10764       subroutine transpose(n,a,at)
10765       implicit none
10766       integer n,i,j
10767       double precision a(n,n),at(n,n)
10768       do i=1,n
10769         do j=1,n
10770           at(j,i)=a(i,j)
10771         enddo
10772       enddo
10773       return
10774       end
10775 C---------------------------------------------------------------------------
10776       subroutine prodmat3(a1,a2,kk,transp,prod)
10777 !DIR$ INLINEALWAYS prodmat3
10778 #ifndef OSF
10779 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10780 #endif
10781       implicit none
10782       integer i,j
10783       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10784       logical transp
10785 crc      double precision auxmat(2,2),prod_(2,2)
10786
10787       if (transp) then
10788 crc        call transpose2(kk(1,1),auxmat(1,1))
10789 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10790 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10791
10792            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10793      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10794            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10795      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10796            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10797      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10798            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10799      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10800
10801       else
10802 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10803 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10804
10805            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10806      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10807            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10808      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10809            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10810      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10811            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10812      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10813
10814       endif
10815 c      call transpose2(a2(1,1),a2t(1,1))
10816
10817 crc      print *,transp
10818 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10819 crc      print *,((prod(i,j),i=1,2),j=1,2)
10820
10821       return
10822       end
10823 CCC----------------------------------------------
10824       subroutine Eliptransfer(eliptran)
10825       implicit real*8 (a-h,o-z)
10826       include 'DIMENSIONS'
10827       include 'COMMON.GEO'
10828       include 'COMMON.VAR'
10829       include 'COMMON.LOCAL'
10830       include 'COMMON.CHAIN'
10831       include 'COMMON.DERIV'
10832       include 'COMMON.NAMES'
10833       include 'COMMON.INTERACT'
10834       include 'COMMON.IOUNITS'
10835       include 'COMMON.CALC'
10836       include 'COMMON.CONTROL'
10837       include 'COMMON.SPLITELE'
10838       include 'COMMON.SBRIDGE'
10839 C this is done by Adasko
10840 C      print *,"wchodze"
10841 C structure of box:
10842 C      water
10843 C--bordliptop-- buffore starts
10844 C--bufliptop--- here true lipid starts
10845 C      lipid
10846 C--buflipbot--- lipid ends buffore starts
10847 C--bordlipbot--buffore ends
10848       eliptran=0.0
10849       do i=ilip_start,ilip_end
10850 C       do i=1,1
10851         if (itype(i).eq.ntyp1) cycle
10852
10853         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10854         if (positi.le.0) positi=positi+boxzsize
10855 C        print *,i
10856 C first for peptide groups
10857 c for each residue check if it is in lipid or lipid water border area
10858        if ((positi.gt.bordlipbot)
10859      &.and.(positi.lt.bordliptop)) then
10860 C the energy transfer exist
10861         if (positi.lt.buflipbot) then
10862 C what fraction I am in
10863          fracinbuf=1.0d0-
10864      &        ((positi-bordlipbot)/lipbufthick)
10865 C lipbufthick is thickenes of lipid buffore
10866          sslip=sscalelip(fracinbuf)
10867          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10868          eliptran=eliptran+sslip*pepliptran
10869          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10870          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10871 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10872
10873 C        print *,"doing sccale for lower part"
10874 C         print *,i,sslip,fracinbuf,ssgradlip
10875         elseif (positi.gt.bufliptop) then
10876          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10877          sslip=sscalelip(fracinbuf)
10878          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10879          eliptran=eliptran+sslip*pepliptran
10880          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10881          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10882 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10883 C          print *, "doing sscalefor top part"
10884 C         print *,i,sslip,fracinbuf,ssgradlip
10885         else
10886          eliptran=eliptran+pepliptran
10887 C         print *,"I am in true lipid"
10888         endif
10889 C       else
10890 C       eliptran=elpitran+0.0 ! I am in water
10891        endif
10892        enddo
10893 C       print *, "nic nie bylo w lipidzie?"
10894 C now multiply all by the peptide group transfer factor
10895 C       eliptran=eliptran*pepliptran
10896 C now the same for side chains
10897 CV       do i=1,1
10898        do i=ilip_start,ilip_end
10899         if (itype(i).eq.ntyp1) cycle
10900         positi=(mod(c(3,i+nres),boxzsize))
10901         if (positi.le.0) positi=positi+boxzsize
10902 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10903 c for each residue check if it is in lipid or lipid water border area
10904 C       respos=mod(c(3,i+nres),boxzsize)
10905 C       print *,positi,bordlipbot,buflipbot
10906        if ((positi.gt.bordlipbot)
10907      & .and.(positi.lt.bordliptop)) then
10908 C the energy transfer exist
10909         if (positi.lt.buflipbot) then
10910          fracinbuf=1.0d0-
10911      &     ((positi-bordlipbot)/lipbufthick)
10912 C lipbufthick is thickenes of lipid buffore
10913          sslip=sscalelip(fracinbuf)
10914          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10915          eliptran=eliptran+sslip*liptranene(itype(i))
10916          gliptranx(3,i)=gliptranx(3,i)
10917      &+ssgradlip*liptranene(itype(i))
10918          gliptranc(3,i-1)= gliptranc(3,i-1)
10919      &+ssgradlip*liptranene(itype(i))
10920 C         print *,"doing sccale for lower part"
10921         elseif (positi.gt.bufliptop) then
10922          fracinbuf=1.0d0-
10923      &((bordliptop-positi)/lipbufthick)
10924          sslip=sscalelip(fracinbuf)
10925          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10926          eliptran=eliptran+sslip*liptranene(itype(i))
10927          gliptranx(3,i)=gliptranx(3,i)
10928      &+ssgradlip*liptranene(itype(i))
10929          gliptranc(3,i-1)= gliptranc(3,i-1)
10930      &+ssgradlip*liptranene(itype(i))
10931 C          print *, "doing sscalefor top part",sslip,fracinbuf
10932         else
10933          eliptran=eliptran+liptranene(itype(i))
10934 C         print *,"I am in true lipid"
10935         endif
10936         endif ! if in lipid or buffor
10937 C       else
10938 C       eliptran=elpitran+0.0 ! I am in water
10939        enddo
10940        return
10941        end
10942 C---------------------------------------------------------
10943 C AFM soubroutine for constant force
10944        subroutine AFMforce(Eafmforce)
10945        implicit real*8 (a-h,o-z)
10946       include 'DIMENSIONS'
10947       include 'COMMON.GEO'
10948       include 'COMMON.VAR'
10949       include 'COMMON.LOCAL'
10950       include 'COMMON.CHAIN'
10951       include 'COMMON.DERIV'
10952       include 'COMMON.NAMES'
10953       include 'COMMON.INTERACT'
10954       include 'COMMON.IOUNITS'
10955       include 'COMMON.CALC'
10956       include 'COMMON.CONTROL'
10957       include 'COMMON.SPLITELE'
10958       include 'COMMON.SBRIDGE'
10959       real*8 diffafm(3)
10960       dist=0.0d0
10961       Eafmforce=0.0d0
10962       do i=1,3
10963       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10964       dist=dist+diffafm(i)**2
10965       enddo
10966       dist=dsqrt(dist)
10967       Eafmforce=-forceAFMconst*(dist-distafminit)
10968       do i=1,3
10969       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10970       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10971       enddo
10972 C      print *,'AFM',Eafmforce
10973       return
10974       end
10975 C---------------------------------------------------------
10976 C AFM subroutine with pseudoconstant velocity
10977        subroutine AFMvel(Eafmforce)
10978        implicit real*8 (a-h,o-z)
10979       include 'DIMENSIONS'
10980       include 'COMMON.GEO'
10981       include 'COMMON.VAR'
10982       include 'COMMON.LOCAL'
10983       include 'COMMON.CHAIN'
10984       include 'COMMON.DERIV'
10985       include 'COMMON.NAMES'
10986       include 'COMMON.INTERACT'
10987       include 'COMMON.IOUNITS'
10988       include 'COMMON.CALC'
10989       include 'COMMON.CONTROL'
10990       include 'COMMON.SPLITELE'
10991       include 'COMMON.SBRIDGE'
10992       real*8 diffafm(3)
10993 C Only for check grad COMMENT if not used for checkgrad
10994 C      totT=3.0d0
10995 C--------------------------------------------------------
10996 C      print *,"wchodze"
10997       dist=0.0d0
10998       Eafmforce=0.0d0
10999       do i=1,3
11000       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11001       dist=dist+diffafm(i)**2
11002       enddo
11003       dist=dsqrt(dist)
11004       Eafmforce=0.5d0*forceAFMconst
11005      & *(distafminit+totTafm*velAFMconst-dist)**2
11006 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11007       do i=1,3
11008       gradafm(i,afmend-1)=-forceAFMconst*
11009      &(distafminit+totTafm*velAFMconst-dist)
11010      &*diffafm(i)/dist
11011       gradafm(i,afmbeg-1)=forceAFMconst*
11012      &(distafminit+totTafm*velAFMconst-dist)
11013      &*diffafm(i)/dist
11014       enddo
11015 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11016       return
11017       end
11018