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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c    Here are the energies showed per procesor if the are more processors
 305 c    per molecule then we sum it up in sum_energy subroutine
 306 c      print *," Processor",myrank," calls SUM_ENERGY"
 307       call sum_energy(energia,.true.)
 308       if (dyn_ss) call dyn_set_nss
 309 c      print *," Processor",myrank," left SUM_ENERGY"
 310 #ifdef TIMING
 311       time_sumene=time_sumene+MPI_Wtime()-time00
 312 #endif
 313       return
 314       end
 315 c-------------------------------------------------------------------------------
 316       subroutine sum_energy(energia,reduce)
 317       implicit real*8 (a-h,o-z)
 318       include 'DIMENSIONS'
 319 #ifndef ISNAN
 320       external proc_proc
 321 #ifdef WINPGI
 322 cMS$ATTRIBUTES C ::  proc_proc
 323 #endif
 324 #endif
 325 #ifdef MPI
 326       include "mpif.h"
 327 #endif
 328       include 'COMMON.SETUP'
 329       include 'COMMON.IOUNITS'
 330       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 331       include 'COMMON.FFIELD'
 332       include 'COMMON.DERIV'
 333       include 'COMMON.INTERACT'
 334       include 'COMMON.SBRIDGE'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.VAR'
 337       include 'COMMON.CONTROL'
 338       include 'COMMON.TIME1'
 339       logical reduce
 340 #ifdef MPI
 341       if (nfgtasks.gt.1 .and. reduce) then
 342 #ifdef DEBUG
 343         write (iout,*) "energies before REDUCE"
 344         call enerprint(energia)
 345         call flush(iout)
 346 #endif
 347         do i=0,n_ene
 348           enebuff(i)=energia(i)
 349         enddo
 350         time00=MPI_Wtime()
 351         call MPI_Barrier(FG_COMM,IERR)
 352         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 353         time00=MPI_Wtime()
 354         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 355      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 356 #ifdef DEBUG
 357         write (iout,*) "energies after REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         time_Reduce=time_Reduce+MPI_Wtime()-time00
 362       endif
 363       if (fg_rank.eq.0) then
 364 #endif
 365       evdw=energia(1)
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 446 #endif
 447       include 'COMMON.SETUP'
 448       include 'COMMON.IOUNITS'
 449       include 'COMMON.FFIELD'
 450       include 'COMMON.DERIV'
 451       include 'COMMON.INTERACT'
 452       include 'COMMON.SBRIDGE'
 453       include 'COMMON.CHAIN'
 454       include 'COMMON.VAR'
 455       include 'COMMON.CONTROL'
 456       include 'COMMON.TIME1'
 457       include 'COMMON.MAXGRAD'
 458       include 'COMMON.SCCOR'
 459 #ifdef TIMING
 460       time01=MPI_Wtime()
 461 #endif
 462 #ifdef DEBUG
 463       write (iout,*) "sum_gradient gvdwc, gvdwx"
 464       do i=1,nres
 465         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 466      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 467       enddo
 468       call flush(iout)
 469 #endif
 470 #ifdef MPI
 471 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 472         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 473      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 474 #endif
 475 C
 476 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 477 C            in virtual-bond-vector coordinates
 478 C
 479 #ifdef DEBUG
 480 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 481 c      do i=1,nres-1
 482 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 483 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 484 c      enddo
 485 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 486 c      do i=1,nres-1
 487 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 488 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 489 c      enddo
 490       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 491       do i=1,nres
 492         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 493      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 494      &   g_corr5_loc(i)
 495       enddo
 496       call flush(iout)
 497 #endif
 498 #ifdef SPLITELE
 499       do i=1,nct
 500         do j=1,3
 501           gradbufc(j,i)=wsc*gvdwc(j,i)+
 502      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 503      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 504      &                wel_loc*gel_loc_long(j,i)+
 505      &                wcorr*gradcorr_long(j,i)+
 506      &                wcorr5*gradcorr5_long(j,i)+
 507      &                wcorr6*gradcorr6_long(j,i)+
 508      &                wturn6*gcorr6_turn_long(j,i)+
 509      &                wstrain*ghpbc(j,i)
 510         enddo
 511       enddo
 512 #else
 513       do i=1,nct
 514         do j=1,3
 515           gradbufc(j,i)=wsc*gvdwc(j,i)+
 516      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 517      &                welec*gelc_long(j,i)+
 518      &                wbond*gradb(j,i)+
 519      &                wel_loc*gel_loc_long(j,i)+
 520      &                wcorr*gradcorr_long(j,i)+
 521      &                wcorr5*gradcorr5_long(j,i)+
 522      &                wcorr6*gradcorr6_long(j,i)+
 523      &                wturn6*gcorr6_turn_long(j,i)+
 524      &                wstrain*ghpbc(j,i)
 525         enddo
 526       enddo
 527 #endif
 528 #ifdef MPI
 529       if (nfgtasks.gt.1) then
 530       time00=MPI_Wtime()
 531 #ifdef DEBUG
 532       write (iout,*) "gradbufc before allreduce"
 533       do i=1,nres
 534         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 535       enddo
 536       call flush(iout)
 537 #endif
 538       do i=1,nres
 539         do j=1,3
 540           gradbufc_sum(j,i)=gradbufc(j,i)
 541         enddo
 542       enddo
 543 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 544 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 545 c      time_reduce=time_reduce+MPI_Wtime()-time00
 546 #ifdef DEBUG
 547 c      write (iout,*) "gradbufc_sum after allreduce"
 548 c      do i=1,nres
 549 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 550 c      enddo
 551 c      call flush(iout)
 552 #endif
 553 #ifdef TIMING
 554 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 555 #endif
 556       do i=nnt,nres
 557         do k=1,3
 558           gradbufc(k,i)=0.0d0
 559         enddo
 560       enddo
 561 #ifdef DEBUG
 562       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 563       write (iout,*) (i," jgrad_start",jgrad_start(i),
 564      &                  " jgrad_end  ",jgrad_end(i),
 565      &                  i=igrad_start,igrad_end)
 566 #endif
 567 c
 568 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 569 c do not parallelize this part.
 570 c
 571 c      do i=igrad_start,igrad_end
 572 c        do j=jgrad_start(i),jgrad_end(i)
 573 c          do k=1,3
 574 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 575 c          enddo
 576 c        enddo
 577 c      enddo
 578       do j=1,3
 579         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 580       enddo
 581       do i=nres-2,nnt,-1
 582         do j=1,3
 583           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 584         enddo
 585       enddo
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc after summing"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       else
 594 #endif
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       do i=1,nres
 603         do j=1,3
 604           gradbufc_sum(j,i)=gradbufc(j,i)
 605           gradbufc(j,i)=0.0d0
 606         enddo
 607       enddo
 608       do j=1,3
 609         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 610       enddo
 611       do i=nres-2,nnt,-1
 612         do j=1,3
 613           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 614         enddo
 615       enddo
 616 c      do i=nnt,nres-1
 617 c        do k=1,3
 618 c          gradbufc(k,i)=0.0d0
 619 c        enddo
 620 c        do j=i+1,nres
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626 #ifdef DEBUG
 627       write (iout,*) "gradbufc after summing"
 628       do i=1,nres
 629         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 630       enddo
 631       call flush(iout)
 632 #endif
 633 #ifdef MPI
 634       endif
 635 #endif
 636       do k=1,3
 637         gradbufc(k,nres)=0.0d0
 638       enddo
 639       do i=1,nct
 640         do j=1,3
 641 #ifdef SPLITELE
 642           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 643      &                wel_loc*gel_loc(j,i)+
 644      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 645      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 646      &                wel_loc*gel_loc_long(j,i)+
 647      &                wcorr*gradcorr_long(j,i)+
 648      &                wcorr5*gradcorr5_long(j,i)+
 649      &                wcorr6*gradcorr6_long(j,i)+
 650      &                wturn6*gcorr6_turn_long(j,i))+
 651      &                wbond*gradb(j,i)+
 652      &                wcorr*gradcorr(j,i)+
 653      &                wturn3*gcorr3_turn(j,i)+
 654      &                wturn4*gcorr4_turn(j,i)+
 655      &                wcorr5*gradcorr5(j,i)+
 656      &                wcorr6*gradcorr6(j,i)+
 657      &                wturn6*gcorr6_turn(j,i)+
 658      &                wsccor*gsccorc(j,i)
 659      &               +wscloc*gscloc(j,i)
 660 #else
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679 #endif
 680           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 681      &                  wbond*gradbx(j,i)+
 682      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 683      &                  wsccor*gsccorx(j,i)
 684      &                 +wscloc*gsclocx(j,i)
 685         enddo
 686       enddo
 687 #ifdef DEBUG
 688       write (iout,*) "gloc before adding corr"
 689       do i=1,4*nres
 690         write (iout,*) i,gloc(i,icg)
 691       enddo
 692 #endif
 693       do i=1,nres-3
 694         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 695      &   +wcorr5*g_corr5_loc(i)
 696      &   +wcorr6*g_corr6_loc(i)
 697      &   +wturn4*gel_loc_turn4(i)
 698      &   +wturn3*gel_loc_turn3(i)
 699      &   +wturn6*gel_loc_turn6(i)
 700      &   +wel_loc*gel_loc_loc(i)
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gloc after adding corr"
 704       do i=1,4*nres
 705         write (iout,*) i,gloc(i,icg)
 706       enddo
 707 #endif
 708 #ifdef MPI
 709       if (nfgtasks.gt.1) then
 710         do j=1,3
 711           do i=1,nres
 712             gradbufc(j,i)=gradc(j,i,icg)
 713             gradbufx(j,i)=gradx(j,i,icg)
 714           enddo
 715         enddo
 716         do i=1,4*nres
 717           glocbuf(i)=gloc(i,icg)
 718         enddo
 719 c#define DEBUG
 720 #ifdef DEBUG
 721       write (iout,*) "gloc_sc before reduce"
 722       do i=1,nres
 723        do j=1,1
 724         write (iout,*) i,j,gloc_sc(j,i,icg)
 725        enddo
 726       enddo
 727 #endif
 728 c#undef DEBUG
 729         do i=1,nres
 730          do j=1,3
 731           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 732          enddo
 733         enddo
 734         time00=MPI_Wtime()
 735         call MPI_Barrier(FG_COMM,IERR)
 736         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 737         time00=MPI_Wtime()
 738         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 739      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 740         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 741      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 742         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 743      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 744         time_reduce=time_reduce+MPI_Wtime()-time00
 745         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 746      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 747         time_reduce=time_reduce+MPI_Wtime()-time00
 748 c#define DEBUG
 749 #ifdef DEBUG
 750       write (iout,*) "gloc_sc after reduce"
 751       do i=1,nres
 752        do j=1,1
 753         write (iout,*) i,j,gloc_sc(j,i,icg)
 754        enddo
 755       enddo
 756 #endif
 757 c#undef DEBUG
 758 #ifdef DEBUG
 759       write (iout,*) "gloc after reduce"
 760       do i=1,4*nres
 761         write (iout,*) i,gloc(i,icg)
 762       enddo
 763 #endif
 764       endif
 765 #endif
 766       if (gnorm_check) then
 767 c
 768 c Compute the maximum elements of the gradient
 769 c
 770       gvdwc_max=0.0d0
 771       gvdwc_scp_max=0.0d0
 772       gelc_max=0.0d0
 773       gvdwpp_max=0.0d0
 774       gradb_max=0.0d0
 775       ghpbc_max=0.0d0
 776       gradcorr_max=0.0d0
 777       gel_loc_max=0.0d0
 778       gcorr3_turn_max=0.0d0
 779       gcorr4_turn_max=0.0d0
 780       gradcorr5_max=0.0d0
 781       gradcorr6_max=0.0d0
 782       gcorr6_turn_max=0.0d0
 783       gsccorc_max=0.0d0
 784       gscloc_max=0.0d0
 785       gvdwx_max=0.0d0
 786       gradx_scp_max=0.0d0
 787       ghpbx_max=0.0d0
 788       gradxorr_max=0.0d0
 789       gsccorx_max=0.0d0
 790       gsclocx_max=0.0d0
 791       do i=1,nct
 792         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 793         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 794         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 795         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 796      &   gvdwc_scp_max=gvdwc_scp_norm
 797         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 798         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 799         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 800         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 801         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 802         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 803         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 804         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 805         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 806         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 807         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 808         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 809         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 810      &    gcorr3_turn(1,i)))
 811         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 812      &    gcorr3_turn_max=gcorr3_turn_norm
 813         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 814      &    gcorr4_turn(1,i)))
 815         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 816      &    gcorr4_turn_max=gcorr4_turn_norm
 817         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 818         if (gradcorr5_norm.gt.gradcorr5_max)
 819      &    gradcorr5_max=gradcorr5_norm
 820         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 821         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 822         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 823      &    gcorr6_turn(1,i)))
 824         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 825      &    gcorr6_turn_max=gcorr6_turn_norm
 826         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 827         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 828         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 829         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 830         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 831         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 832         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 833         if (gradx_scp_norm.gt.gradx_scp_max)
 834      &    gradx_scp_max=gradx_scp_norm
 835         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 836         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 837         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 838         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 839         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 840         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 841         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 842         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 843       enddo
 844       if (gradout) then
 845 #ifdef AIX
 846         open(istat,file=statname,position="append")
 847 #else
 848         open(istat,file=statname,access="append")
 849 #endif
 850         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 851      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 852      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 853      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 854      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 855      &     gsccorx_max,gsclocx_max
 856         close(istat)
 857         if (gvdwc_max.gt.1.0d4) then
 858           write (iout,*) "gvdwc gvdwx gradb gradbx"
 859           do i=nnt,nct
 860             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 861      &        gradb(j,i),gradbx(j,i),j=1,3)
 862           enddo
 863           call pdbout(0.0d0,'cipiszcze',iout)
 864           call flush(iout)
 865         endif
 866       endif
 867       endif
 868 #ifdef DEBUG
 869       write (iout,*) "gradc gradx gloc"
 870       do i=1,nres
 871         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 872      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 873       enddo
 874 #endif
 875 #ifdef TIMING
 876       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 877 #endif
 878       return
 879       end
 880 c-------------------------------------------------------------------------------
 881       subroutine rescale_weights(t_bath)
 882       implicit real*8 (a-h,o-z)
 883       include 'DIMENSIONS'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.FFIELD'
 886       include 'COMMON.SBRIDGE'
 887       double precision kfac /2.4d0/
 888       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 889 c      facT=temp0/t_bath
 890 c      facT=2*temp0/(t_bath+temp0)
 891       if (rescale_mode.eq.0) then
 892         facT=1.0d0
 893         facT2=1.0d0
 894         facT3=1.0d0
 895         facT4=1.0d0
 896         facT5=1.0d0
 897       else if (rescale_mode.eq.1) then
 898         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 899         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 900         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 901         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 902         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 903       else if (rescale_mode.eq.2) then
 904         x=t_bath/temp0
 905         x2=x*x
 906         x3=x2*x
 907         x4=x3*x
 908         x5=x4*x
 909         facT=licznik/dlog(dexp(x)+dexp(-x))
 910         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 911         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 912         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 913         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 914       else
 915         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 916         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 917 #ifdef MPI
 918        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 919 #endif
 920        stop 555
 921       endif
 922       welec=weights(3)*fact
 923       wcorr=weights(4)*fact3
 924       wcorr5=weights(5)*fact4
 925       wcorr6=weights(6)*fact5
 926       wel_loc=weights(7)*fact2
 927       wturn3=weights(8)*fact2
 928       wturn4=weights(9)*fact3
 929       wturn6=weights(10)*fact5
 930       wtor=weights(13)*fact
 931       wtor_d=weights(14)*fact2
 932       wsccor=weights(21)*fact
 933
 934       return
 935       end
 936 C------------------------------------------------------------------------
 937       subroutine enerprint(energia)
 938       implicit real*8 (a-h,o-z)
 939       include 'DIMENSIONS'
 940       include 'COMMON.IOUNITS'
 941       include 'COMMON.FFIELD'
 942       include 'COMMON.SBRIDGE'
 943       include 'COMMON.MD'
 944       double precision energia(0:n_ene)
 945       etot=energia(0)
 946       evdw=energia(1)
 947       evdw2=energia(2)
 948 #ifdef SCP14
 949       evdw2=energia(2)+energia(18)
 950 #else
 951       evdw2=energia(2)
 952 #endif
 953       ees=energia(3)
 954 #ifdef SPLITELE
 955       evdw1=energia(16)
 956 #endif
 957       ecorr=energia(4)
 958       ecorr5=energia(5)
 959       ecorr6=energia(6)
 960       eel_loc=energia(7)
 961       eello_turn3=energia(8)
 962       eello_turn4=energia(9)
 963       eello_turn6=energia(10)
 964       ebe=energia(11)
 965       escloc=energia(12)
 966       etors=energia(13)
 967       etors_d=energia(14)
 968       ehpb=energia(15)
 969       edihcnstr=energia(19)
 970       estr=energia(17)
 971       Uconst=energia(20)
 972       esccor=energia(21)
 973 #ifdef SPLITELE
 974       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 975      &  estr,wbond,ebe,wang,
 976      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 977      &  ecorr,wcorr,
 978      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 979      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 980      &  edihcnstr,ebr*nss,
 981      &  Uconst,etot
 982    10 format (/'Virtual-chain energies:'//
 983      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 984      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 985      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 986      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 987      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 988      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 989      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 990      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 991      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 992      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 993      & ' (SS bridges & dist. cnstr.)'/
 994      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 998      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 999      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1000      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1001      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1002      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1003      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1004      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1005      & 'ETOT=  ',1pE16.6,' (total)')
1006 #else
1007       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1008      &  estr,wbond,ebe,wang,
1009      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1010      &  ecorr,wcorr,
1011      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1012      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1013      &  ebr*nss,Uconst,etot
1014    10 format (/'Virtual-chain energies:'//
1015      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1016      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1017      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1018      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1019      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1020      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1021      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1022      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1023      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1024      & ' (SS bridges & dist. cnstr.)'/
1025      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1028      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1029      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1030      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1031      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1032      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1033      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1034      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1035      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1036      & 'ETOT=  ',1pE16.6,' (total)')
1037 #endif
1038       return
1039       end
1040 C-----------------------------------------------------------------------
1041       subroutine elj(evdw)
1042 C
1043 C This subroutine calculates the interaction energy of nonbonded side chains
1044 C assuming the LJ potential of interaction.
1045 C
1046       implicit real*8 (a-h,o-z)
1047       include 'DIMENSIONS'
1048       parameter (accur=1.0d-10)
1049       include 'COMMON.GEO'
1050       include 'COMMON.VAR'
1051       include 'COMMON.LOCAL'
1052       include 'COMMON.CHAIN'
1053       include 'COMMON.DERIV'
1054       include 'COMMON.INTERACT'
1055       include 'COMMON.TORSION'
1056       include 'COMMON.SBRIDGE'
1057       include 'COMMON.NAMES'
1058       include 'COMMON.IOUNITS'
1059       include 'COMMON.CONTACTS'
1060       dimension gg(3)
1061 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1062       evdw=0.0D0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070 C Change 12/1/95
1071         num_conti=0
1072 C
1073 C Calculate SC interaction energy.
1074 C
1075         do iint=1,nint_gr(i)
1076 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1077 cd   &                  'iend=',iend(i,iint)
1078           do j=istart(i,iint),iend(i,iint)
1079             itypj=iabs(itype(j))
1080             if (itypj.eq.ntyp1) cycle
1081             xj=c(1,nres+j)-xi
1082             yj=c(2,nres+j)-yi
1083             zj=c(3,nres+j)-zi
1084 C Change 12/1/95 to calculate four-body interactions
1085             rij=xj*xj+yj*yj+zj*zj
1086             rrij=1.0D0/rij
1087 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1088             eps0ij=eps(itypi,itypj)
1089             fac=rrij**expon2
1090             e1=fac*fac*aa(itypi,itypj)
1091             e2=fac*bb(itypi,itypj)
1092             evdwij=e1+e2
1093 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1096 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1097 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1098 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1099             evdw=evdw+evdwij
1100 C
1101 C Calculate the components of the gradient in DC and X
1102 C
1103             fac=-rrij*(e1+evdwij)
1104             gg(1)=xj*fac
1105             gg(2)=yj*fac
1106             gg(3)=zj*fac
1107             do k=1,3
1108               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1109               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1110               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1111               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1112             enddo
1113 cgrad            do k=i,j-1
1114 cgrad              do l=1,3
1115 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1116 cgrad              enddo
1117 cgrad            enddo
1118 C
1119 C 12/1/95, revised on 5/20/97
1120 C
1121 C Calculate the contact function. The ith column of the array JCONT will
1122 C contain the numbers of atoms that make contacts with the atom I (of numbers
1123 C greater than I). The arrays FACONT and GACONT will contain the values of
1124 C the contact function and its derivative.
1125 C
1126 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1127 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1128 C Uncomment next line, if the correlation interactions are contact function only
1129             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1130               rij=dsqrt(rij)
1131               sigij=sigma(itypi,itypj)
1132               r0ij=rs0(itypi,itypj)
1133 C
1134 C Check whether the SC's are not too far to make a contact.
1135 C
1136               rcut=1.5d0*r0ij
1137               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1138 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1139 C
1140               if (fcont.gt.0.0D0) then
1141 C If the SC-SC distance if close to sigma, apply spline.
1142 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1143 cAdam &             fcont1,fprimcont1)
1144 cAdam           fcont1=1.0d0-fcont1
1145 cAdam           if (fcont1.gt.0.0d0) then
1146 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1147 cAdam             fcont=fcont*fcont1
1148 cAdam           endif
1149 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1150 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1151 cga             do k=1,3
1152 cga               gg(k)=gg(k)*eps0ij
1153 cga             enddo
1154 cga             eps0ij=-evdwij*eps0ij
1155 C Uncomment for AL's type of SC correlation interactions.
1156 cadam           eps0ij=-evdwij
1157                 num_conti=num_conti+1
1158                 jcont(num_conti,i)=j
1159                 facont(num_conti,i)=fcont*eps0ij
1160                 fprimcont=eps0ij*fprimcont/rij
1161                 fcont=expon*fcont
1162 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1163 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1164 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1165 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1166                 gacont(1,num_conti,i)=-fprimcont*xj
1167                 gacont(2,num_conti,i)=-fprimcont*yj
1168                 gacont(3,num_conti,i)=-fprimcont*zj
1169 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1170 cd              write (iout,'(2i3,3f10.5)')
1171 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1172               endif
1173             endif
1174           enddo      ! j
1175         enddo        ! iint
1176 C Change 12/1/95
1177         num_cont(i)=num_conti
1178       enddo          ! i
1179       do i=1,nct
1180         do j=1,3
1181           gvdwc(j,i)=expon*gvdwc(j,i)
1182           gvdwx(j,i)=expon*gvdwx(j,i)
1183         enddo
1184       enddo
1185 C******************************************************************************
1186 C
1187 C                              N O T E !!!
1188 C
1189 C To save time, the factor of EXPON has been extracted from ALL components
1190 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1191 C use!
1192 C
1193 C******************************************************************************
1194       return
1195       end
1196 C-----------------------------------------------------------------------------
1197       subroutine eljk(evdw)
1198 C
1199 C This subroutine calculates the interaction energy of nonbonded side chains
1200 C assuming the LJK potential of interaction.
1201 C
1202       implicit real*8 (a-h,o-z)
1203       include 'DIMENSIONS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.DERIV'
1209       include 'COMMON.INTERACT'
1210       include 'COMMON.IOUNITS'
1211       include 'COMMON.NAMES'
1212       dimension gg(3)
1213       logical scheck
1214 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1215       evdw=0.0D0
1216       do i=iatsc_s,iatsc_e
1217         itypi=iabs(itype(i))
1218         if (itypi.eq.ntyp1) cycle
1219         itypi1=iabs(itype(i+1))
1220         xi=c(1,nres+i)
1221         yi=c(2,nres+i)
1222         zi=c(3,nres+i)
1223 C
1224 C Calculate SC interaction energy.
1225 C
1226         do iint=1,nint_gr(i)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             fac_augm=rrij**expon
1235             e_augm=augm(itypi,itypj)*fac_augm
1236             r_inv_ij=dsqrt(rrij)
1237             rij=1.0D0/r_inv_ij
1238             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1239             fac=r_shift_inv**expon
1240             e1=fac*fac*aa(itypi,itypj)
1241             e2=fac*bb(itypi,itypj)
1242             evdwij=e_augm+e1+e2
1243 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1247 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1248 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1249 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1250             evdw=evdw+evdwij
1251 C
1252 C Calculate the components of the gradient in DC and X
1253 C
1254             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1255             gg(1)=xj*fac
1256             gg(2)=yj*fac
1257             gg(3)=zj*fac
1258             do k=1,3
1259               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1260               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1261               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1262               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1263             enddo
1264 cgrad            do k=i,j-1
1265 cgrad              do l=1,3
1266 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1267 cgrad              enddo
1268 cgrad            enddo
1269           enddo      ! j
1270         enddo        ! iint
1271       enddo          ! i
1272       do i=1,nct
1273         do j=1,3
1274           gvdwc(j,i)=expon*gvdwc(j,i)
1275           gvdwx(j,i)=expon*gvdwx(j,i)
1276         enddo
1277       enddo
1278       return
1279       end
1280 C-----------------------------------------------------------------------------
1281       subroutine ebp(evdw)
1282 C
1283 C This subroutine calculates the interaction energy of nonbonded side chains
1284 C assuming the Berne-Pechukas potential of interaction.
1285 C
1286       implicit real*8 (a-h,o-z)
1287       include 'DIMENSIONS'
1288       include 'COMMON.GEO'
1289       include 'COMMON.VAR'
1290       include 'COMMON.LOCAL'
1291       include 'COMMON.CHAIN'
1292       include 'COMMON.DERIV'
1293       include 'COMMON.NAMES'
1294       include 'COMMON.INTERACT'
1295       include 'COMMON.IOUNITS'
1296       include 'COMMON.CALC'
1297       common /srutu/ icall
1298 c     double precision rrsave(maxdim)
1299       logical lprn
1300       evdw=0.0D0
1301 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1302       evdw=0.0D0
1303 c     if (icall.eq.0) then
1304 c       lprn=.true.
1305 c     else
1306         lprn=.false.
1307 c     endif
1308       ind=0
1309       do i=iatsc_s,iatsc_e
1310         itypi=iabs(itype(i))
1311         if (itypi.eq.ntyp1) cycle
1312         itypi1=iabs(itype(i+1))
1313         xi=c(1,nres+i)
1314         yi=c(2,nres+i)
1315         zi=c(3,nres+i)
1316         dxi=dc_norm(1,nres+i)
1317         dyi=dc_norm(2,nres+i)
1318         dzi=dc_norm(3,nres+i)
1319 c        dsci_inv=dsc_inv(itypi)
1320         dsci_inv=vbld_inv(i+nres)
1321 C
1322 C Calculate SC interaction energy.
1323 C
1324         do iint=1,nint_gr(i)
1325           do j=istart(i,iint),iend(i,iint)
1326             ind=ind+1
1327             itypj=iabs(itype(j))
1328             if (itypj.eq.ntyp1) cycle
1329 c            dscj_inv=dsc_inv(itypj)
1330             dscj_inv=vbld_inv(j+nres)
1331             chi1=chi(itypi,itypj)
1332             chi2=chi(itypj,itypi)
1333             chi12=chi1*chi2
1334             chip1=chip(itypi)
1335             chip2=chip(itypj)
1336             chip12=chip1*chip2
1337             alf1=alp(itypi)
1338             alf2=alp(itypj)
1339             alf12=0.5D0*(alf1+alf2)
1340 C For diagnostics only!!!
1341 c           chi1=0.0D0
1342 c           chi2=0.0D0
1343 c           chi12=0.0D0
1344 c           chip1=0.0D0
1345 c           chip2=0.0D0
1346 c           chip12=0.0D0
1347 c           alf1=0.0D0
1348 c           alf2=0.0D0
1349 c           alf12=0.0D0
1350             xj=c(1,nres+j)-xi
1351             yj=c(2,nres+j)-yi
1352             zj=c(3,nres+j)-zi
1353             dxj=dc_norm(1,nres+j)
1354             dyj=dc_norm(2,nres+j)
1355             dzj=dc_norm(3,nres+j)
1356             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1357 cd          if (icall.eq.0) then
1358 cd            rrsave(ind)=rrij
1359 cd          else
1360 cd            rrij=rrsave(ind)
1361 cd          endif
1362             rij=dsqrt(rrij)
1363 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1364             call sc_angular
1365 C Calculate whole angle-dependent part of epsilon and contributions
1366 C to its derivatives
1367             fac=(rrij*sigsq)**expon2
1368             e1=fac*fac*aa(itypi,itypj)
1369             e2=fac*bb(itypi,itypj)
1370             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1371             eps2der=evdwij*eps3rt
1372             eps3der=evdwij*eps2rt
1373             evdwij=evdwij*eps2rt*eps3rt
1374             evdw=evdw+evdwij
1375             if (lprn) then
1376             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1379 cd     &        restyp(itypi),i,restyp(itypj),j,
1380 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1381 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1382 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1383 cd     &        evdwij
1384             endif
1385 C Calculate gradient components.
1386             e1=e1*eps1*eps2rt**2*eps3rt**2
1387             fac=-expon*(e1+evdwij)
1388             sigder=fac/sigsq
1389             fac=rrij*fac
1390 C Calculate radial part of the gradient
1391             gg(1)=xj*fac
1392             gg(2)=yj*fac
1393             gg(3)=zj*fac
1394 C Calculate the angular part of the gradient and sum add the contributions
1395 C to the appropriate components of the Cartesian gradient.
1396             call sc_grad
1397           enddo      ! j
1398         enddo        ! iint
1399       enddo          ! i
1400 c     stop
1401       return
1402       end
1403 C-----------------------------------------------------------------------------
1404       subroutine egb(evdw)
1405 C
1406 C This subroutine calculates the interaction energy of nonbonded side chains
1407 C assuming the Gay-Berne potential of interaction.
1408 C
1409       implicit real*8 (a-h,o-z)
1410       include 'DIMENSIONS'
1411       include 'COMMON.GEO'
1412       include 'COMMON.VAR'
1413       include 'COMMON.LOCAL'
1414       include 'COMMON.CHAIN'
1415       include 'COMMON.DERIV'
1416       include 'COMMON.NAMES'
1417       include 'COMMON.INTERACT'
1418       include 'COMMON.IOUNITS'
1419       include 'COMMON.CALC'
1420       include 'COMMON.CONTROL'
1421       include 'COMMON.SBRIDGE'
1422       logical lprn
1423
1424 c      write(iout,*) "Jestem w egb(evdw)"
1425
1426       evdw=0.0D0
1427 ccccc      energy_dec=.false.
1428 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1429       evdw=0.0D0
1430       lprn=.false.
1431 c     if (icall.eq.0) lprn=.false.
1432       ind=0
1433       do i=iatsc_s,iatsc_e
1434         itypi=iabs(itype(i))
1435         if (itypi.eq.ntyp1) cycle
1436         itypi1=iabs(itype(i+1))
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1446 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1447 C
1448 C Calculate SC interaction energy.
1449 C
1450         do iint=1,nint_gr(i)
1451           do j=istart(i,iint),iend(i,iint)
1452             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1453
1454 c              write(iout,*) "PRZED ZWYKLE", evdwij
1455               call dyn_ssbond_ene(i,j,evdwij)
1456 c              write(iout,*) "PO ZWYKLE", evdwij
1457
1458               evdw=evdw+evdwij
1459               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1460      &                        'evdw',i,j,evdwij,' ss'
1461 C triple bond artifac removal
1462              do k=j+1,iend(i,iint)
1463 C search over all next residues
1464               if (dyn_ss_mask(k)) then
1465 C check if they are cysteins
1466 C              write(iout,*) 'k=',k
1467
1468 c              write(iout,*) "PRZED TRI", evdwij
1469                evdwij_przed_tri=evdwij
1470               call triple_ssbond_ene(i,j,k,evdwij)
1471 c               if(evdwij_przed_tri.ne.evdwij) then
1472 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1473 c               endif
1474
1475 c              write(iout,*) "PO TRI", evdwij
1476 C call the energy function that removes the artifical triple disulfide
1477 C bond the soubroutine is located in ssMD.F
1478               evdw=evdw+evdwij
1479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1480      &                        'evdw',i,j,evdwij,'tss'
1481               endif!dyn_ss_mask(k)
1482              enddo! k
1483             ELSE
1484             ind=ind+1
1485             itypj=iabs(itype(j))
1486             if (itypj.eq.ntyp1) cycle
1487 c            dscj_inv=dsc_inv(itypj)
1488             dscj_inv=vbld_inv(j+nres)
1489 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1490 c     &       1.0d0/vbld(j+nres)
1491 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1492             sig0ij=sigma(itypi,itypj)
1493             chi1=chi(itypi,itypj)
1494             chi2=chi(itypj,itypi)
1495             chi12=chi1*chi2
1496             chip1=chip(itypi)
1497             chip2=chip(itypj)
1498             chip12=chip1*chip2
1499             alf1=alp(itypi)
1500             alf2=alp(itypj)
1501             alf12=0.5D0*(alf1+alf2)
1502 C For diagnostics only!!!
1503 c           chi1=0.0D0
1504 c           chi2=0.0D0
1505 c           chi12=0.0D0
1506 c           chip1=0.0D0
1507 c           chip2=0.0D0
1508 c           chip12=0.0D0
1509 c           alf1=0.0D0
1510 c           alf2=0.0D0
1511 c           alf12=0.0D0
1512             xj=c(1,nres+j)-xi
1513             yj=c(2,nres+j)-yi
1514             zj=c(3,nres+j)-zi
1515             dxj=dc_norm(1,nres+j)
1516             dyj=dc_norm(2,nres+j)
1517             dzj=dc_norm(3,nres+j)
1518 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1519 c            write (iout,*) "j",j," dc_norm",
1520 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1521             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1522             rij=dsqrt(rrij)
1523 C Calculate angle-dependent terms of energy and contributions to their
1524 C derivatives.
1525             call sc_angular
1526             sigsq=1.0D0/sigsq
1527             sig=sig0ij*dsqrt(sigsq)
1528             rij_shift=1.0D0/rij-sig+sig0ij
1529 c for diagnostics; uncomment
1530 c            rij_shift=1.2*sig0ij
1531 C I hate to put IF's in the loops, but here don't have another choice!!!!
1532             if (rij_shift.le.0.0D0) then
1533               evdw=1.0D20
1534 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1535 cd     &        restyp(itypi),i,restyp(itypj),j,
1536 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1537               return
1538             endif
1539             sigder=-sig*sigsq
1540 c---------------------------------------------------------------
1541             rij_shift=1.0D0/rij_shift
1542             fac=rij_shift**expon
1543             e1=fac*fac*aa(itypi,itypj)
1544             e2=fac*bb(itypi,itypj)
1545             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1546             eps2der=evdwij*eps3rt
1547             eps3der=evdwij*eps2rt
1548 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1549 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1550             evdwij=evdwij*eps2rt*eps3rt
1551             evdw=evdw+evdwij
1552             if (lprn) then
1553             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1556      &        restyp(itypi),i,restyp(itypj),j,
1557      &        epsi,sigm,chi1,chi2,chip1,chip2,
1558      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1559      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1560      &        evdwij
1561             endif
1562
1563             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1564      &                        'evdw',i,j,evdwij
1565
1566 C Calculate gradient components.
1567             e1=e1*eps1*eps2rt**2*eps3rt**2
1568             fac=-expon*(e1+evdwij)*rij_shift
1569             sigder=fac*sigder
1570             fac=rij*fac
1571 c            fac=0.0d0
1572 C Calculate the radial part of the gradient
1573             gg(1)=xj*fac
1574             gg(2)=yj*fac
1575             gg(3)=zj*fac
1576 C Calculate angular part of the gradient.
1577             call sc_grad
1578             ENDIF    ! dyn_ss
1579           enddo      ! j
1580         enddo        ! iint
1581       enddo          ! i
1582 c      write (iout,*) "Number of loop steps in EGB:",ind
1583 cccc      energy_dec=.false.
1584       return
1585       end
1586 C-----------------------------------------------------------------------------
1587       subroutine egbv(evdw)
1588 C
1589 C This subroutine calculates the interaction energy of nonbonded side chains
1590 C assuming the Gay-Berne-Vorobjev potential of interaction.
1591 C
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.GEO'
1595       include 'COMMON.VAR'
1596       include 'COMMON.LOCAL'
1597       include 'COMMON.CHAIN'
1598       include 'COMMON.DERIV'
1599       include 'COMMON.NAMES'
1600       include 'COMMON.INTERACT'
1601       include 'COMMON.IOUNITS'
1602       include 'COMMON.CALC'
1603       common /srutu/ icall
1604       logical lprn
1605       evdw=0.0D0
1606 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1607       evdw=0.0D0
1608       lprn=.false.
1609 c     if (icall.eq.0) lprn=.true.
1610       ind=0
1611       do i=iatsc_s,iatsc_e
1612         itypi=iabs(itype(i))
1613         if (itypi.eq.ntyp1) cycle
1614         itypi1=iabs(itype(i+1))
1615         xi=c(1,nres+i)
1616         yi=c(2,nres+i)
1617         zi=c(3,nres+i)
1618         dxi=dc_norm(1,nres+i)
1619         dyi=dc_norm(2,nres+i)
1620         dzi=dc_norm(3,nres+i)
1621 c        dsci_inv=dsc_inv(itypi)
1622         dsci_inv=vbld_inv(i+nres)
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             ind=ind+1
1629             itypj=iabs(itype(j))
1630             if (itypj.eq.ntyp1) cycle
1631 c            dscj_inv=dsc_inv(itypj)
1632             dscj_inv=vbld_inv(j+nres)
1633             sig0ij=sigma(itypi,itypj)
1634             r0ij=r0(itypi,itypj)
1635             chi1=chi(itypi,itypj)
1636             chi2=chi(itypj,itypi)
1637             chi12=chi1*chi2
1638             chip1=chip(itypi)
1639             chip2=chip(itypj)
1640             chip12=chip1*chip2
1641             alf1=alp(itypi)
1642             alf2=alp(itypj)
1643             alf12=0.5D0*(alf1+alf2)
1644 C For diagnostics only!!!
1645 c           chi1=0.0D0
1646 c           chi2=0.0D0
1647 c           chi12=0.0D0
1648 c           chip1=0.0D0
1649 c           chip2=0.0D0
1650 c           chip12=0.0D0
1651 c           alf1=0.0D0
1652 c           alf2=0.0D0
1653 c           alf12=0.0D0
1654             xj=c(1,nres+j)-xi
1655             yj=c(2,nres+j)-yi
1656             zj=c(3,nres+j)-zi
1657             dxj=dc_norm(1,nres+j)
1658             dyj=dc_norm(2,nres+j)
1659             dzj=dc_norm(3,nres+j)
1660             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1661             rij=dsqrt(rrij)
1662 C Calculate angle-dependent terms of energy and contributions to their
1663 C derivatives.
1664             call sc_angular
1665             sigsq=1.0D0/sigsq
1666             sig=sig0ij*dsqrt(sigsq)
1667             rij_shift=1.0D0/rij-sig+r0ij
1668 C I hate to put IF's in the loops, but here don't have another choice!!!!
1669             if (rij_shift.le.0.0D0) then
1670               evdw=1.0D20
1671               return
1672             endif
1673             sigder=-sig*sigsq
1674 c---------------------------------------------------------------
1675             rij_shift=1.0D0/rij_shift
1676             fac=rij_shift**expon
1677             e1=fac*fac*aa(itypi,itypj)
1678             e2=fac*bb(itypi,itypj)
1679             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1680             eps2der=evdwij*eps3rt
1681             eps3der=evdwij*eps2rt
1682             fac_augm=rrij**expon
1683             e_augm=augm(itypi,itypj)*fac_augm
1684             evdwij=evdwij*eps2rt*eps3rt
1685             evdw=evdw+evdwij+e_augm
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1692      &        chi1,chi2,chip1,chip2,
1693      &        eps1,eps2rt**2,eps3rt**2,
1694      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1695      &        evdwij+e_augm
1696             endif
1697 C Calculate gradient components.
1698             e1=e1*eps1*eps2rt**2*eps3rt**2
1699             fac=-expon*(e1+evdwij)*rij_shift
1700             sigder=fac*sigder
1701             fac=rij*fac-2*expon*rrij*e_augm
1702 C Calculate the radial part of the gradient
1703             gg(1)=xj*fac
1704             gg(2)=yj*fac
1705             gg(3)=zj*fac
1706 C Calculate angular part of the gradient.
1707             call sc_grad
1708           enddo      ! j
1709         enddo        ! iint
1710       enddo          ! i
1711       end
1712 C-----------------------------------------------------------------------------
1713       subroutine sc_angular
1714 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1715 C om12. Called by ebp, egb, and egbv.
1716       implicit none
1717       include 'COMMON.CALC'
1718       include 'COMMON.IOUNITS'
1719       erij(1)=xj*rij
1720       erij(2)=yj*rij
1721       erij(3)=zj*rij
1722       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1723       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1724       om12=dxi*dxj+dyi*dyj+dzi*dzj
1725       chiom12=chi12*om12
1726 C Calculate eps1(om12) and its derivative in om12
1727       faceps1=1.0D0-om12*chiom12
1728       faceps1_inv=1.0D0/faceps1
1729       eps1=dsqrt(faceps1_inv)
1730 C Following variable is eps1*deps1/dom12
1731       eps1_om12=faceps1_inv*chiom12
1732 c diagnostics only
1733 c      faceps1_inv=om12
1734 c      eps1=om12
1735 c      eps1_om12=1.0d0
1736 c      write (iout,*) "om12",om12," eps1",eps1
1737 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1738 C and om12.
1739       om1om2=om1*om2
1740       chiom1=chi1*om1
1741       chiom2=chi2*om2
1742       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1743       sigsq=1.0D0-facsig*faceps1_inv
1744       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1745       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1746       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1747 c diagnostics only
1748 c      sigsq=1.0d0
1749 c      sigsq_om1=0.0d0
1750 c      sigsq_om2=0.0d0
1751 c      sigsq_om12=0.0d0
1752 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1753 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1754 c     &    " eps1",eps1
1755 C Calculate eps2 and its derivatives in om1, om2, and om12.
1756       chipom1=chip1*om1
1757       chipom2=chip2*om2
1758       chipom12=chip12*om12
1759       facp=1.0D0-om12*chipom12
1760       facp_inv=1.0D0/facp
1761       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1762 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1763 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1764 C Following variable is the square root of eps2
1765       eps2rt=1.0D0-facp1*facp_inv
1766 C Following three variables are the derivatives of the square root of eps
1767 C in om1, om2, and om12.
1768       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1769       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1770       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1771 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1772       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1773 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1774 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1775 c     &  " eps2rt_om12",eps2rt_om12
1776 C Calculate whole angle-dependent part of epsilon and contributions
1777 C to its derivatives
1778       return
1779       end
1780 C----------------------------------------------------------------------------
1781       subroutine sc_grad
1782       implicit real*8 (a-h,o-z)
1783       include 'DIMENSIONS'
1784       include 'COMMON.CHAIN'
1785       include 'COMMON.DERIV'
1786       include 'COMMON.CALC'
1787       include 'COMMON.IOUNITS'
1788       double precision dcosom1(3),dcosom2(3)
1789       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1790       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1791       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1792      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1793 c diagnostics only
1794 c      eom1=0.0d0
1795 c      eom2=0.0d0
1796 c      eom12=evdwij*eps1_om12
1797 c end diagnostics
1798 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1799 c     &  " sigder",sigder
1800 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1801 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1802       do k=1,3
1803         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1804         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1805       enddo
1806       do k=1,3
1807         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1808       enddo
1809 c      write (iout,*) "gg",(gg(k),k=1,3)
1810       do k=1,3
1811         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1812      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1813      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1814         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1815      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1816      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1817 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1818 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1819 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1820 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1821       enddo
1822 C
1823 C Calculate the components of the gradient in DC and X
1824 C
1825 cgrad      do k=i,j-1
1826 cgrad        do l=1,3
1827 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1828 cgrad        enddo
1829 cgrad      enddo
1830       do l=1,3
1831         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1832         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1833       enddo
1834       return
1835       end
1836 C-----------------------------------------------------------------------
1837       subroutine e_softsphere(evdw)
1838 C
1839 C This subroutine calculates the interaction energy of nonbonded side chains
1840 C assuming the LJ potential of interaction.
1841 C
1842       implicit real*8 (a-h,o-z)
1843       include 'DIMENSIONS'
1844       parameter (accur=1.0d-10)
1845       include 'COMMON.GEO'
1846       include 'COMMON.VAR'
1847       include 'COMMON.LOCAL'
1848       include 'COMMON.CHAIN'
1849       include 'COMMON.DERIV'
1850       include 'COMMON.INTERACT'
1851       include 'COMMON.TORSION'
1852       include 'COMMON.SBRIDGE'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.IOUNITS'
1855       include 'COMMON.CONTACTS'
1856       dimension gg(3)
1857 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1858       evdw=0.0D0
1859       do i=iatsc_s,iatsc_e
1860         itypi=iabs(itype(i))
1861         if (itypi.eq.ntyp1) cycle
1862         itypi1=iabs(itype(i+1))
1863         xi=c(1,nres+i)
1864         yi=c(2,nres+i)
1865         zi=c(3,nres+i)
1866 C
1867 C Calculate SC interaction energy.
1868 C
1869         do iint=1,nint_gr(i)
1870 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1871 cd   &                  'iend=',iend(i,iint)
1872           do j=istart(i,iint),iend(i,iint)
1873             itypj=iabs(itype(j))
1874             if (itypj.eq.ntyp1) cycle
1875             xj=c(1,nres+j)-xi
1876             yj=c(2,nres+j)-yi
1877             zj=c(3,nres+j)-zi
1878             rij=xj*xj+yj*yj+zj*zj
1879 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1880             r0ij=r0(itypi,itypj)
1881             r0ijsq=r0ij*r0ij
1882 c            print *,i,j,r0ij,dsqrt(rij)
1883             if (rij.lt.r0ijsq) then
1884               evdwij=0.25d0*(rij-r0ijsq)**2
1885               fac=rij-r0ijsq
1886             else
1887               evdwij=0.0d0
1888               fac=0.0d0
1889             endif
1890             evdw=evdw+evdwij
1891 C
1892 C Calculate the components of the gradient in DC and X
1893 C
1894             gg(1)=xj*fac
1895             gg(2)=yj*fac
1896             gg(3)=zj*fac
1897             do k=1,3
1898               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1899               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1900               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1901               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1902             enddo
1903 cgrad            do k=i,j-1
1904 cgrad              do l=1,3
1905 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad              enddo
1907 cgrad            enddo
1908           enddo ! j
1909         enddo ! iint
1910       enddo ! i
1911       return
1912       end
1913 C--------------------------------------------------------------------------
1914       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1915      &              eello_turn4)
1916 C
1917 C Soft-sphere potential of p-p interaction
1918 C
1919       implicit real*8 (a-h,o-z)
1920       include 'DIMENSIONS'
1921       include 'COMMON.CONTROL'
1922       include 'COMMON.IOUNITS'
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.CONTACTS'
1930       include 'COMMON.TORSION'
1931       include 'COMMON.VECTORS'
1932       include 'COMMON.FFIELD'
1933       dimension ggg(3)
1934 cd      write(iout,*) 'In EELEC_soft_sphere'
1935       ees=0.0D0
1936       evdw1=0.0D0
1937       eel_loc=0.0d0
1938       eello_turn3=0.0d0
1939       eello_turn4=0.0d0
1940       ind=0
1941       do i=iatel_s,iatel_e
1942         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1943         dxi=dc(1,i)
1944         dyi=dc(2,i)
1945         dzi=dc(3,i)
1946         xmedi=c(1,i)+0.5d0*dxi
1947         ymedi=c(2,i)+0.5d0*dyi
1948         zmedi=c(3,i)+0.5d0*dzi
1949         num_conti=0
1950 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1951         do j=ielstart(i),ielend(i)
1952           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1953           ind=ind+1
1954           iteli=itel(i)
1955           itelj=itel(j)
1956           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1957           r0ij=rpp(iteli,itelj)
1958           r0ijsq=r0ij*r0ij
1959           dxj=dc(1,j)
1960           dyj=dc(2,j)
1961           dzj=dc(3,j)
1962           xj=c(1,j)+0.5D0*dxj-xmedi
1963           yj=c(2,j)+0.5D0*dyj-ymedi
1964           zj=c(3,j)+0.5D0*dzj-zmedi
1965           rij=xj*xj+yj*yj+zj*zj
1966           if (rij.lt.r0ijsq) then
1967             evdw1ij=0.25d0*(rij-r0ijsq)**2
1968             fac=rij-r0ijsq
1969           else
1970             evdw1ij=0.0d0
1971             fac=0.0d0
1972           endif
1973           evdw1=evdw1+evdw1ij
1974 C
1975 C Calculate contributions to the Cartesian gradient.
1976 C
1977           ggg(1)=fac*xj
1978           ggg(2)=fac*yj
1979           ggg(3)=fac*zj
1980           do k=1,3
1981             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1982             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1983           enddo
1984 *
1985 * Loop over residues i+1 thru j-1.
1986 *
1987 cgrad          do k=i+1,j-1
1988 cgrad            do l=1,3
1989 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1990 cgrad            enddo
1991 cgrad          enddo
1992         enddo ! j
1993       enddo   ! i
1994 cgrad      do i=nnt,nct-1
1995 cgrad        do k=1,3
1996 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1997 cgrad        enddo
1998 cgrad        do j=i+1,nct-1
1999 cgrad          do k=1,3
2000 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2001 cgrad          enddo
2002 cgrad        enddo
2003 cgrad      enddo
2004       return
2005       end
2006 c------------------------------------------------------------------------------
2007       subroutine vec_and_deriv
2008       implicit real*8 (a-h,o-z)
2009       include 'DIMENSIONS'
2010 #ifdef MPI
2011       include 'mpif.h'
2012 #endif
2013       include 'COMMON.IOUNITS'
2014       include 'COMMON.GEO'
2015       include 'COMMON.VAR'
2016       include 'COMMON.LOCAL'
2017       include 'COMMON.CHAIN'
2018       include 'COMMON.VECTORS'
2019       include 'COMMON.SETUP'
2020       include 'COMMON.TIME1'
2021       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2022 C Compute the local reference systems. For reference system (i), the
2023 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2024 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2025 #ifdef PARVEC
2026       do i=ivec_start,ivec_end
2027 #else
2028       do i=1,nres-1
2029 #endif
2030           if (i.eq.nres-1) then
2031 C Case of the last full residue
2032 C Compute the Z-axis
2033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2034             costh=dcos(pi-theta(nres))
2035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2036             do k=1,3
2037               uz(k,i)=fac*uz(k,i)
2038             enddo
2039 C Compute the derivatives of uz
2040             uzder(1,1,1)= 0.0d0
2041             uzder(2,1,1)=-dc_norm(3,i-1)
2042             uzder(3,1,1)= dc_norm(2,i-1)
2043             uzder(1,2,1)= dc_norm(3,i-1)
2044             uzder(2,2,1)= 0.0d0
2045             uzder(3,2,1)=-dc_norm(1,i-1)
2046             uzder(1,3,1)=-dc_norm(2,i-1)
2047             uzder(2,3,1)= dc_norm(1,i-1)
2048             uzder(3,3,1)= 0.0d0
2049             uzder(1,1,2)= 0.0d0
2050             uzder(2,1,2)= dc_norm(3,i)
2051             uzder(3,1,2)=-dc_norm(2,i)
2052             uzder(1,2,2)=-dc_norm(3,i)
2053             uzder(2,2,2)= 0.0d0
2054             uzder(3,2,2)= dc_norm(1,i)
2055             uzder(1,3,2)= dc_norm(2,i)
2056             uzder(2,3,2)=-dc_norm(1,i)
2057             uzder(3,3,2)= 0.0d0
2058 C Compute the Y-axis
2059             facy=fac
2060             do k=1,3
2061               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2062             enddo
2063 C Compute the derivatives of uy
2064             do j=1,3
2065               do k=1,3
2066                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2067      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2068                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2069               enddo
2070               uyder(j,j,1)=uyder(j,j,1)-costh
2071               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2072             enddo
2073             do j=1,2
2074               do k=1,3
2075                 do l=1,3
2076                   uygrad(l,k,j,i)=uyder(l,k,j)
2077                   uzgrad(l,k,j,i)=uzder(l,k,j)
2078                 enddo
2079               enddo
2080             enddo
2081             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2082             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2083             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2084             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2085           else
2086 C Other residues
2087 C Compute the Z-axis
2088             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2089             costh=dcos(pi-theta(i+2))
2090             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2091             do k=1,3
2092               uz(k,i)=fac*uz(k,i)
2093             enddo
2094 C Compute the derivatives of uz
2095             uzder(1,1,1)= 0.0d0
2096             uzder(2,1,1)=-dc_norm(3,i+1)
2097             uzder(3,1,1)= dc_norm(2,i+1)
2098             uzder(1,2,1)= dc_norm(3,i+1)
2099             uzder(2,2,1)= 0.0d0
2100             uzder(3,2,1)=-dc_norm(1,i+1)
2101             uzder(1,3,1)=-dc_norm(2,i+1)
2102             uzder(2,3,1)= dc_norm(1,i+1)
2103             uzder(3,3,1)= 0.0d0
2104             uzder(1,1,2)= 0.0d0
2105             uzder(2,1,2)= dc_norm(3,i)
2106             uzder(3,1,2)=-dc_norm(2,i)
2107             uzder(1,2,2)=-dc_norm(3,i)
2108             uzder(2,2,2)= 0.0d0
2109             uzder(3,2,2)= dc_norm(1,i)
2110             uzder(1,3,2)= dc_norm(2,i)
2111             uzder(2,3,2)=-dc_norm(1,i)
2112             uzder(3,3,2)= 0.0d0
2113 C Compute the Y-axis
2114             facy=fac
2115             do k=1,3
2116               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2117             enddo
2118 C Compute the derivatives of uy
2119             do j=1,3
2120               do k=1,3
2121                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2122      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2123                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2124               enddo
2125               uyder(j,j,1)=uyder(j,j,1)-costh
2126               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2127             enddo
2128             do j=1,2
2129               do k=1,3
2130                 do l=1,3
2131                   uygrad(l,k,j,i)=uyder(l,k,j)
2132                   uzgrad(l,k,j,i)=uzder(l,k,j)
2133                 enddo
2134               enddo
2135             enddo
2136             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2137             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2138             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2139             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2140           endif
2141       enddo
2142       do i=1,nres-1
2143         vbld_inv_temp(1)=vbld_inv(i+1)
2144         if (i.lt.nres-1) then
2145           vbld_inv_temp(2)=vbld_inv(i+2)
2146           else
2147           vbld_inv_temp(2)=vbld_inv(i)
2148           endif
2149         do j=1,2
2150           do k=1,3
2151             do l=1,3
2152               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2153               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2154             enddo
2155           enddo
2156         enddo
2157       enddo
2158 #if defined(PARVEC) && defined(MPI)
2159       if (nfgtasks1.gt.1) then
2160         time00=MPI_Wtime()
2161 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2162 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2163 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2164         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2165      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2166      &   FG_COMM1,IERR)
2167         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2168      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2169      &   FG_COMM1,IERR)
2170         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2171      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2172      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2173         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2174      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2175      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2176         time_gather=time_gather+MPI_Wtime()-time00
2177       endif
2178 c      if (fg_rank.eq.0) then
2179 c        write (iout,*) "Arrays UY and UZ"
2180 c        do i=1,nres-1
2181 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2182 c     &     (uz(k,i),k=1,3)
2183 c        enddo
2184 c      endif
2185 #endif
2186       return
2187       end
2188 C-----------------------------------------------------------------------------
2189       subroutine check_vecgrad
2190       implicit real*8 (a-h,o-z)
2191       include 'DIMENSIONS'
2192       include 'COMMON.IOUNITS'
2193       include 'COMMON.GEO'
2194       include 'COMMON.VAR'
2195       include 'COMMON.LOCAL'
2196       include 'COMMON.CHAIN'
2197       include 'COMMON.VECTORS'
2198       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2199       dimension uyt(3,maxres),uzt(3,maxres)
2200       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2201       double precision delta /1.0d-7/
2202       call vec_and_deriv
2203 cd      do i=1,nres
2204 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2205 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2206 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2207 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2208 cd     &     (dc_norm(if90,i),if90=1,3)
2209 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2210 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2211 cd          write(iout,'(a)')
2212 cd      enddo
2213       do i=1,nres
2214         do j=1,2
2215           do k=1,3
2216             do l=1,3
2217               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2218               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2219             enddo
2220           enddo
2221         enddo
2222       enddo
2223       call vec_and_deriv
2224       do i=1,nres
2225         do j=1,3
2226           uyt(j,i)=uy(j,i)
2227           uzt(j,i)=uz(j,i)
2228         enddo
2229       enddo
2230       do i=1,nres
2231 cd        write (iout,*) 'i=',i
2232         do k=1,3
2233           erij(k)=dc_norm(k,i)
2234         enddo
2235         do j=1,3
2236           do k=1,3
2237             dc_norm(k,i)=erij(k)
2238           enddo
2239           dc_norm(j,i)=dc_norm(j,i)+delta
2240 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2241 c          do k=1,3
2242 c            dc_norm(k,i)=dc_norm(k,i)/fac
2243 c          enddo
2244 c          write (iout,*) (dc_norm(k,i),k=1,3)
2245 c          write (iout,*) (erij(k),k=1,3)
2246           call vec_and_deriv
2247           do k=1,3
2248             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2249             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2250             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2251             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2252           enddo
2253 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2254 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2255 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2256         enddo
2257         do k=1,3
2258           dc_norm(k,i)=erij(k)
2259         enddo
2260 cd        do k=1,3
2261 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2262 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2263 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2264 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2265 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2266 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2267 cd          write (iout,'(a)')
2268 cd        enddo
2269       enddo
2270       return
2271       end
2272 C--------------------------------------------------------------------------
2273       subroutine set_matrices
2274       implicit real*8 (a-h,o-z)
2275       include 'DIMENSIONS'
2276 #ifdef MPI
2277       include "mpif.h"
2278       include "COMMON.SETUP"
2279       integer IERR
2280       integer status(MPI_STATUS_SIZE)
2281 #endif
2282       include 'COMMON.IOUNITS'
2283       include 'COMMON.GEO'
2284       include 'COMMON.VAR'
2285       include 'COMMON.LOCAL'
2286       include 'COMMON.CHAIN'
2287       include 'COMMON.DERIV'
2288       include 'COMMON.INTERACT'
2289       include 'COMMON.CONTACTS'
2290       include 'COMMON.TORSION'
2291       include 'COMMON.VECTORS'
2292       include 'COMMON.FFIELD'
2293       double precision auxvec(2),auxmat(2,2)
2294 C
2295 C Compute the virtual-bond-torsional-angle dependent quantities needed
2296 C to calculate the el-loc multibody terms of various order.
2297 C
2298 #ifdef PARMAT
2299       do i=ivec_start+2,ivec_end+2
2300 #else
2301       do i=3,nres+1
2302 #endif
2303         if (i .lt. nres+1) then
2304           sin1=dsin(phi(i))
2305           cos1=dcos(phi(i))
2306           sintab(i-2)=sin1
2307           costab(i-2)=cos1
2308           obrot(1,i-2)=cos1
2309           obrot(2,i-2)=sin1
2310           sin2=dsin(2*phi(i))
2311           cos2=dcos(2*phi(i))
2312           sintab2(i-2)=sin2
2313           costab2(i-2)=cos2
2314           obrot2(1,i-2)=cos2
2315           obrot2(2,i-2)=sin2
2316           Ug(1,1,i-2)=-cos1
2317           Ug(1,2,i-2)=-sin1
2318           Ug(2,1,i-2)=-sin1
2319           Ug(2,2,i-2)= cos1
2320           Ug2(1,1,i-2)=-cos2
2321           Ug2(1,2,i-2)=-sin2
2322           Ug2(2,1,i-2)=-sin2
2323           Ug2(2,2,i-2)= cos2
2324         else
2325           costab(i-2)=1.0d0
2326           sintab(i-2)=0.0d0
2327           obrot(1,i-2)=1.0d0
2328           obrot(2,i-2)=0.0d0
2329           obrot2(1,i-2)=0.0d0
2330           obrot2(2,i-2)=0.0d0
2331           Ug(1,1,i-2)=1.0d0
2332           Ug(1,2,i-2)=0.0d0
2333           Ug(2,1,i-2)=0.0d0
2334           Ug(2,2,i-2)=1.0d0
2335           Ug2(1,1,i-2)=0.0d0
2336           Ug2(1,2,i-2)=0.0d0
2337           Ug2(2,1,i-2)=0.0d0
2338           Ug2(2,2,i-2)=0.0d0
2339         endif
2340         if (i .gt. 3 .and. i .lt. nres+1) then
2341           obrot_der(1,i-2)=-sin1
2342           obrot_der(2,i-2)= cos1
2343           Ugder(1,1,i-2)= sin1
2344           Ugder(1,2,i-2)=-cos1
2345           Ugder(2,1,i-2)=-cos1
2346           Ugder(2,2,i-2)=-sin1
2347           dwacos2=cos2+cos2
2348           dwasin2=sin2+sin2
2349           obrot2_der(1,i-2)=-dwasin2
2350           obrot2_der(2,i-2)= dwacos2
2351           Ug2der(1,1,i-2)= dwasin2
2352           Ug2der(1,2,i-2)=-dwacos2
2353           Ug2der(2,1,i-2)=-dwacos2
2354           Ug2der(2,2,i-2)=-dwasin2
2355         else
2356           obrot_der(1,i-2)=0.0d0
2357           obrot_der(2,i-2)=0.0d0
2358           Ugder(1,1,i-2)=0.0d0
2359           Ugder(1,2,i-2)=0.0d0
2360           Ugder(2,1,i-2)=0.0d0
2361           Ugder(2,2,i-2)=0.0d0
2362           obrot2_der(1,i-2)=0.0d0
2363           obrot2_der(2,i-2)=0.0d0
2364           Ug2der(1,1,i-2)=0.0d0
2365           Ug2der(1,2,i-2)=0.0d0
2366           Ug2der(2,1,i-2)=0.0d0
2367           Ug2der(2,2,i-2)=0.0d0
2368         endif
2369 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2370         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2371           iti = itortyp(itype(i-2))
2372         else
2373           iti=ntortyp+1
2374         endif
2375 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2376         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2377           iti1 = itortyp(itype(i-1))
2378         else
2379           iti1=ntortyp+1
2380         endif
2381 cd        write (iout,*) '*******i',i,' iti1',iti
2382 cd        write (iout,*) 'b1',b1(:,iti)
2383 cd        write (iout,*) 'b2',b2(:,iti)
2384 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2385 c        if (i .gt. iatel_s+2) then
2386         if (i .gt. nnt+2) then
2387           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2388           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2389           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2390      &    then
2391           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2392           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2393           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2394           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2395           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2396           endif
2397         else
2398           do k=1,2
2399             Ub2(k,i-2)=0.0d0
2400             Ctobr(k,i-2)=0.0d0
2401             Dtobr2(k,i-2)=0.0d0
2402             do l=1,2
2403               EUg(l,k,i-2)=0.0d0
2404               CUg(l,k,i-2)=0.0d0
2405               DUg(l,k,i-2)=0.0d0
2406               DtUg2(l,k,i-2)=0.0d0
2407             enddo
2408           enddo
2409         endif
2410         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2411         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2412         do k=1,2
2413           muder(k,i-2)=Ub2der(k,i-2)
2414         enddo
2415 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2416         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2417           if (itype(i-1).le.ntyp) then
2418             iti1 = itortyp(itype(i-1))
2419           else
2420             iti1=ntortyp+1
2421           endif
2422         else
2423           iti1=ntortyp+1
2424         endif
2425         do k=1,2
2426           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2427         enddo
2428 cd        write (iout,*) 'mu ',mu(:,i-2)
2429 cd        write (iout,*) 'mu1',mu1(:,i-2)
2430 cd        write (iout,*) 'mu2',mu2(:,i-2)
2431         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2432      &  then
2433         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2434         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2435         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2436         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2437         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2438 C Vectors and matrices dependent on a single virtual-bond dihedral.
2439         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2440         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2441         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2442         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2443         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2444         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2445         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2446         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2447         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2448         endif
2449       enddo
2450 C Matrices dependent on two consecutive virtual-bond dihedrals.
2451 C The order of matrices is from left to right.
2452       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2453      &then
2454 c      do i=max0(ivec_start,2),ivec_end
2455       do i=2,nres-1
2456         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2457         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2458         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2459         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2460         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2461         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2462         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2463         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2464       enddo
2465       endif
2466 #if defined(MPI) && defined(PARMAT)
2467 #ifdef DEBUG
2468 c      if (fg_rank.eq.0) then
2469         write (iout,*) "Arrays UG and UGDER before GATHER"
2470         do i=1,nres-1
2471           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2472      &     ((ug(l,k,i),l=1,2),k=1,2),
2473      &     ((ugder(l,k,i),l=1,2),k=1,2)
2474         enddo
2475         write (iout,*) "Arrays UG2 and UG2DER"
2476         do i=1,nres-1
2477           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2478      &     ((ug2(l,k,i),l=1,2),k=1,2),
2479      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2480         enddo
2481         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2482         do i=1,nres-1
2483           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2484      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2485      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2486         enddo
2487         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2488         do i=1,nres-1
2489           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2490      &     costab(i),sintab(i),costab2(i),sintab2(i)
2491         enddo
2492         write (iout,*) "Array MUDER"
2493         do i=1,nres-1
2494           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2495         enddo
2496 c      endif
2497 #endif
2498       if (nfgtasks.gt.1) then
2499         time00=MPI_Wtime()
2500 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2503 #ifdef MATGATHER
2504         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2505      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2506      &   FG_COMM1,IERR)
2507         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2508      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2509      &   FG_COMM1,IERR)
2510         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2511      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2512      &   FG_COMM1,IERR)
2513         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2514      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2515      &   FG_COMM1,IERR)
2516         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2517      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2523      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2524      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2525         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2526      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2527      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2528         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2529      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2530      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2531         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2532      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2533      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2534         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2535      &  then
2536         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2543      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2544      &   FG_COMM1,IERR)
2545        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2546      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2547      &   FG_COMM1,IERR)
2548         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2549      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2550      &   FG_COMM1,IERR)
2551         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2552      &   ivec_count(fg_rank1),
2553      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2554      &   FG_COMM1,IERR)
2555         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2574      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2575      &   FG_COMM1,IERR)
2576         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2577      &   ivec_count(fg_rank1),
2578      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2582      &   FG_COMM1,IERR)
2583        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2593      &   ivec_count(fg_rank1),
2594      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2595      &   FG_COMM1,IERR)
2596         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2597      &   ivec_count(fg_rank1),
2598      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2599      &   FG_COMM1,IERR)
2600         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2601      &   ivec_count(fg_rank1),
2602      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2603      &   MPI_MAT2,FG_COMM1,IERR)
2604         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2605      &   ivec_count(fg_rank1),
2606      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2607      &   MPI_MAT2,FG_COMM1,IERR)
2608         endif
2609 #else
2610 c Passes matrix info through the ring
2611       isend=fg_rank1
2612       irecv=fg_rank1-1
2613       if (irecv.lt.0) irecv=nfgtasks1-1
2614       iprev=irecv
2615       inext=fg_rank1+1
2616       if (inext.ge.nfgtasks1) inext=0
2617       do i=1,nfgtasks1-1
2618 c        write (iout,*) "isend",isend," irecv",irecv
2619 c        call flush(iout)
2620         lensend=lentyp(isend)
2621         lenrecv=lentyp(irecv)
2622 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2623 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2624 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2625 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2626 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2627 c        write (iout,*) "Gather ROTAT1"
2628 c        call flush(iout)
2629 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2630 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2631 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2632 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2633 c        write (iout,*) "Gather ROTAT2"
2634 c        call flush(iout)
2635         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2636      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2637      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2638      &   iprev,4400+irecv,FG_COMM,status,IERR)
2639 c        write (iout,*) "Gather ROTAT_OLD"
2640 c        call flush(iout)
2641         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2642      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2643      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2644      &   iprev,5500+irecv,FG_COMM,status,IERR)
2645 c        write (iout,*) "Gather PRECOMP11"
2646 c        call flush(iout)
2647         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2648      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2649      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2650      &   iprev,6600+irecv,FG_COMM,status,IERR)
2651 c        write (iout,*) "Gather PRECOMP12"
2652 c        call flush(iout)
2653         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2654      &  then
2655         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2656      &   MPI_ROTAT2(lensend),inext,7700+isend,
2657      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2658      &   iprev,7700+irecv,FG_COMM,status,IERR)
2659 c        write (iout,*) "Gather PRECOMP21"
2660 c        call flush(iout)
2661         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2662      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2663      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2664      &   iprev,8800+irecv,FG_COMM,status,IERR)
2665 c        write (iout,*) "Gather PRECOMP22"
2666 c        call flush(iout)
2667         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2668      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2669      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2670      &   MPI_PRECOMP23(lenrecv),
2671      &   iprev,9900+irecv,FG_COMM,status,IERR)
2672 c        write (iout,*) "Gather PRECOMP23"
2673 c        call flush(iout)
2674         endif
2675         isend=irecv
2676         irecv=irecv-1
2677         if (irecv.lt.0) irecv=nfgtasks1-1
2678       enddo
2679 #endif
2680         time_gather=time_gather+MPI_Wtime()-time00
2681       endif
2682 #ifdef DEBUG
2683 c      if (fg_rank.eq.0) then
2684         write (iout,*) "Arrays UG and UGDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2687      &     ((ug(l,k,i),l=1,2),k=1,2),
2688      &     ((ugder(l,k,i),l=1,2),k=1,2)
2689         enddo
2690         write (iout,*) "Arrays UG2 and UG2DER"
2691         do i=1,nres-1
2692           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2693      &     ((ug2(l,k,i),l=1,2),k=1,2),
2694      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2695         enddo
2696         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2697         do i=1,nres-1
2698           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2699      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2700      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2701         enddo
2702         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2703         do i=1,nres-1
2704           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2705      &     costab(i),sintab(i),costab2(i),sintab2(i)
2706         enddo
2707         write (iout,*) "Array MUDER"
2708         do i=1,nres-1
2709           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2710         enddo
2711 c      endif
2712 #endif
2713 #endif
2714 cd      do i=1,nres
2715 cd        iti = itortyp(itype(i))
2716 cd        write (iout,*) i
2717 cd        do j=1,2
2718 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2719 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2720 cd        enddo
2721 cd      enddo
2722       return
2723       end
2724 C--------------------------------------------------------------------------
2725       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2726 C
2727 C This subroutine calculates the average interaction energy and its gradient
2728 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2729 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2730 C The potential depends both on the distance of peptide-group centers and on
2731 C the orientation of the CA-CA virtual bonds.
2732 C
2733       implicit real*8 (a-h,o-z)
2734 #ifdef MPI
2735       include 'mpif.h'
2736 #endif
2737       include 'DIMENSIONS'
2738       include 'COMMON.CONTROL'
2739       include 'COMMON.SETUP'
2740       include 'COMMON.IOUNITS'
2741       include 'COMMON.GEO'
2742       include 'COMMON.VAR'
2743       include 'COMMON.LOCAL'
2744       include 'COMMON.CHAIN'
2745       include 'COMMON.DERIV'
2746       include 'COMMON.INTERACT'
2747       include 'COMMON.CONTACTS'
2748       include 'COMMON.TORSION'
2749       include 'COMMON.VECTORS'
2750       include 'COMMON.FFIELD'
2751       include 'COMMON.TIME1'
2752       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2753      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2754       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2755      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2756       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2757      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2758      &    num_conti,j1,j2
2759 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2760 #ifdef MOMENT
2761       double precision scal_el /1.0d0/
2762 #else
2763       double precision scal_el /0.5d0/
2764 #endif
2765 C 12/13/98
2766 C 13-go grudnia roku pamietnego...
2767       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2768      &                   0.0d0,1.0d0,0.0d0,
2769      &                   0.0d0,0.0d0,1.0d0/
2770 cd      write(iout,*) 'In EELEC'
2771 cd      do i=1,nloctyp
2772 cd        write(iout,*) 'Type',i
2773 cd        write(iout,*) 'B1',B1(:,i)
2774 cd        write(iout,*) 'B2',B2(:,i)
2775 cd        write(iout,*) 'CC',CC(:,:,i)
2776 cd        write(iout,*) 'DD',DD(:,:,i)
2777 cd        write(iout,*) 'EE',EE(:,:,i)
2778 cd      enddo
2779 cd      call check_vecgrad
2780 cd      stop
2781       if (icheckgrad.eq.1) then
2782         do i=1,nres-1
2783           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2784           do k=1,3
2785             dc_norm(k,i)=dc(k,i)*fac
2786           enddo
2787 c          write (iout,*) 'i',i,' fac',fac
2788         enddo
2789       endif
2790       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2791      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2792      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2793 c        call vec_and_deriv
2794 #ifdef TIMING
2795         time01=MPI_Wtime()
2796 #endif
2797         call set_matrices
2798 #ifdef TIMING
2799         time_mat=time_mat+MPI_Wtime()-time01
2800 #endif
2801       endif
2802 cd      do i=1,nres-1
2803 cd        write (iout,*) 'i=',i
2804 cd        do k=1,3
2805 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2806 cd        enddo
2807 cd        do k=1,3
2808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2810 cd        enddo
2811 cd      enddo
2812       t_eelecij=0.0d0
2813       ees=0.0D0
2814       evdw1=0.0D0
2815       eel_loc=0.0d0
2816       eello_turn3=0.0d0
2817       eello_turn4=0.0d0
2818       ind=0
2819       do i=1,nres
2820         num_cont_hb(i)=0
2821       enddo
2822 cd      print '(a)','Enter EELEC'
2823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2824       do i=1,nres
2825         gel_loc_loc(i)=0.0d0
2826         gcorr_loc(i)=0.0d0
2827       enddo
2828 c
2829 c
2830 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2831 C
2832 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2833 C
2834       do i=iturn3_start,iturn3_end
2835         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2836      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2837         dxi=dc(1,i)
2838         dyi=dc(2,i)
2839         dzi=dc(3,i)
2840         dx_normi=dc_norm(1,i)
2841         dy_normi=dc_norm(2,i)
2842         dz_normi=dc_norm(3,i)
2843         xmedi=c(1,i)+0.5d0*dxi
2844         ymedi=c(2,i)+0.5d0*dyi
2845         zmedi=c(3,i)+0.5d0*dzi
2846         num_conti=0
2847         call eelecij(i,i+2,ees,evdw1,eel_loc)
2848         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2849         num_cont_hb(i)=num_conti
2850       enddo
2851       do i=iturn4_start,iturn4_end
2852         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2853      &    .or. itype(i+3).eq.ntyp1
2854      &    .or. itype(i+4).eq.ntyp1) cycle
2855         dxi=dc(1,i)
2856         dyi=dc(2,i)
2857         dzi=dc(3,i)
2858         dx_normi=dc_norm(1,i)
2859         dy_normi=dc_norm(2,i)
2860         dz_normi=dc_norm(3,i)
2861         xmedi=c(1,i)+0.5d0*dxi
2862         ymedi=c(2,i)+0.5d0*dyi
2863         zmedi=c(3,i)+0.5d0*dzi
2864         num_conti=num_cont_hb(i)
2865         call eelecij(i,i+3,ees,evdw1,eel_loc)
2866         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2867      &   call eturn4(i,eello_turn4)
2868         num_cont_hb(i)=num_conti
2869       enddo   ! i
2870 c
2871 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2872 c
2873       do i=iatel_s,iatel_e
2874         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2875         dxi=dc(1,i)
2876         dyi=dc(2,i)
2877         dzi=dc(3,i)
2878         dx_normi=dc_norm(1,i)
2879         dy_normi=dc_norm(2,i)
2880         dz_normi=dc_norm(3,i)
2881         xmedi=c(1,i)+0.5d0*dxi
2882         ymedi=c(2,i)+0.5d0*dyi
2883         zmedi=c(3,i)+0.5d0*dzi
2884 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2885         num_conti=num_cont_hb(i)
2886         do j=ielstart(i),ielend(i)
2887 c          write (iout,*) i,j,itype(i),itype(j)
2888           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2889           call eelecij(i,j,ees,evdw1,eel_loc)
2890         enddo ! j
2891         num_cont_hb(i)=num_conti
2892       enddo   ! i
2893 c      write (iout,*) "Number of loop steps in EELEC:",ind
2894 cd      do i=1,nres
2895 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2896 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2897 cd      enddo
2898 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2899 ccc      eel_loc=eel_loc+eello_turn3
2900 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2901       return
2902       end
2903 C-------------------------------------------------------------------------------
2904       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2905       implicit real*8 (a-h,o-z)
2906       include 'DIMENSIONS'
2907 #ifdef MPI
2908       include "mpif.h"
2909 #endif
2910       include 'COMMON.CONTROL'
2911       include 'COMMON.IOUNITS'
2912       include 'COMMON.GEO'
2913       include 'COMMON.VAR'
2914       include 'COMMON.LOCAL'
2915       include 'COMMON.CHAIN'
2916       include 'COMMON.DERIV'
2917       include 'COMMON.INTERACT'
2918       include 'COMMON.CONTACTS'
2919       include 'COMMON.TORSION'
2920       include 'COMMON.VECTORS'
2921       include 'COMMON.FFIELD'
2922       include 'COMMON.TIME1'
2923       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2924      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2925       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2926      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2927       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2928      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2929      &    num_conti,j1,j2
2930 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2931 #ifdef MOMENT
2932       double precision scal_el /1.0d0/
2933 #else
2934       double precision scal_el /0.5d0/
2935 #endif
2936 C 12/13/98
2937 C 13-go grudnia roku pamietnego...
2938       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2939      &                   0.0d0,1.0d0,0.0d0,
2940      &                   0.0d0,0.0d0,1.0d0/
2941 c          time00=MPI_Wtime()
2942 cd      write (iout,*) "eelecij",i,j
2943 c          ind=ind+1
2944           iteli=itel(i)
2945           itelj=itel(j)
2946           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2947           aaa=app(iteli,itelj)
2948           bbb=bpp(iteli,itelj)
2949           ael6i=ael6(iteli,itelj)
2950           ael3i=ael3(iteli,itelj)
2951           dxj=dc(1,j)
2952           dyj=dc(2,j)
2953           dzj=dc(3,j)
2954           dx_normj=dc_norm(1,j)
2955           dy_normj=dc_norm(2,j)
2956           dz_normj=dc_norm(3,j)
2957           xj=c(1,j)+0.5D0*dxj-xmedi
2958           yj=c(2,j)+0.5D0*dyj-ymedi
2959           zj=c(3,j)+0.5D0*dzj-zmedi
2960           rij=xj*xj+yj*yj+zj*zj
2961           rrmij=1.0D0/rij
2962           rij=dsqrt(rij)
2963           rmij=1.0D0/rij
2964           r3ij=rrmij*rmij
2965           r6ij=r3ij*r3ij
2966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2969           fac=cosa-3.0D0*cosb*cosg
2970           ev1=aaa*r6ij*r6ij
2971 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2972           if (j.eq.i+2) ev1=scal_el*ev1
2973           ev2=bbb*r6ij
2974           fac3=ael6i*r6ij
2975           fac4=ael3i*r3ij
2976           evdwij=ev1+ev2
2977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2978           el2=fac4*fac
2979           eesij=el1+el2
2980 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2981           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2982           ees=ees+eesij
2983           evdw1=evdw1+evdwij
2984 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2985 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2986 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2987 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2988
2989           if (energy_dec) then
2990               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2991      &'evdw1',i,j,evdwij
2992      &,iteli,itelj,aaa,evdw1
2993               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2994           endif
2995
2996 C
2997 C Calculate contributions to the Cartesian gradient.
2998 C
2999 #ifdef SPLITELE
3000           facvdw=-6*rrmij*(ev1+evdwij)
3001           facel=-3*rrmij*(el1+eesij)
3002           fac1=fac
3003           erij(1)=xj*rmij
3004           erij(2)=yj*rmij
3005           erij(3)=zj*rmij
3006 *
3007 * Radial derivatives. First process both termini of the fragment (i,j)
3008 *
3009           ggg(1)=facel*xj
3010           ggg(2)=facel*yj
3011           ggg(3)=facel*zj
3012 c          do k=1,3
3013 c            ghalf=0.5D0*ggg(k)
3014 c            gelc(k,i)=gelc(k,i)+ghalf
3015 c            gelc(k,j)=gelc(k,j)+ghalf
3016 c          enddo
3017 c 9/28/08 AL Gradient compotents will be summed only at the end
3018           do k=1,3
3019             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3020             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3021           enddo
3022 *
3023 * Loop over residues i+1 thru j-1.
3024 *
3025 cgrad          do k=i+1,j-1
3026 cgrad            do l=1,3
3027 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3028 cgrad            enddo
3029 cgrad          enddo
3030           ggg(1)=facvdw*xj
3031           ggg(2)=facvdw*yj
3032           ggg(3)=facvdw*zj
3033 c          do k=1,3
3034 c            ghalf=0.5D0*ggg(k)
3035 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3036 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3037 c          enddo
3038 c 9/28/08 AL Gradient compotents will be summed only at the end
3039           do k=1,3
3040             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3041             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3042           enddo
3043 *
3044 * Loop over residues i+1 thru j-1.
3045 *
3046 cgrad          do k=i+1,j-1
3047 cgrad            do l=1,3
3048 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3049 cgrad            enddo
3050 cgrad          enddo
3051 #else
3052           facvdw=ev1+evdwij
3053           facel=el1+eesij
3054           fac1=fac
3055           fac=-3*rrmij*(facvdw+facvdw+facel)
3056           erij(1)=xj*rmij
3057           erij(2)=yj*rmij
3058           erij(3)=zj*rmij
3059 *
3060 * Radial derivatives. First process both termini of the fragment (i,j)
3061 *
3062           ggg(1)=fac*xj
3063           ggg(2)=fac*yj
3064           ggg(3)=fac*zj
3065 c          do k=1,3
3066 c            ghalf=0.5D0*ggg(k)
3067 c            gelc(k,i)=gelc(k,i)+ghalf
3068 c            gelc(k,j)=gelc(k,j)+ghalf
3069 c          enddo
3070 c 9/28/08 AL Gradient compotents will be summed only at the end
3071           do k=1,3
3072             gelc_long(k,j)=gelc(k,j)+ggg(k)
3073             gelc_long(k,i)=gelc(k,i)-ggg(k)
3074           enddo
3075 *
3076 * Loop over residues i+1 thru j-1.
3077 *
3078 cgrad          do k=i+1,j-1
3079 cgrad            do l=1,3
3080 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3081 cgrad            enddo
3082 cgrad          enddo
3083 c 9/28/08 AL Gradient compotents will be summed only at the end
3084           ggg(1)=facvdw*xj
3085           ggg(2)=facvdw*yj
3086           ggg(3)=facvdw*zj
3087           do k=1,3
3088             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3089             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3090           enddo
3091 #endif
3092 *
3093 * Angular part
3094 *
3095           ecosa=2.0D0*fac3*fac1+fac4
3096           fac4=-3.0D0*fac4
3097           fac3=-6.0D0*fac3
3098           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3099           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3100           do k=1,3
3101             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3102             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3103           enddo
3104 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3105 cd   &          (dcosg(k),k=1,3)
3106           do k=1,3
3107             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3108           enddo
3109 c          do k=1,3
3110 c            ghalf=0.5D0*ggg(k)
3111 c            gelc(k,i)=gelc(k,i)+ghalf
3112 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3113 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3114 c            gelc(k,j)=gelc(k,j)+ghalf
3115 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3116 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3117 c          enddo
3118 cgrad          do k=i+1,j-1
3119 cgrad            do l=1,3
3120 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3121 cgrad            enddo
3122 cgrad          enddo
3123           do k=1,3
3124             gelc(k,i)=gelc(k,i)
3125      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3126      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3127             gelc(k,j)=gelc(k,j)
3128      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3129      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3130             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3131             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3132           enddo
3133           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3134      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3135      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3136 C
3137 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3138 C   energy of a peptide unit is assumed in the form of a second-order
3139 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3140 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3141 C   are computed for EVERY pair of non-contiguous peptide groups.
3142 C
3143           if (j.lt.nres-1) then
3144             j1=j+1
3145             j2=j-1
3146           else
3147             j1=j-1
3148             j2=j-2
3149           endif
3150           kkk=0
3151           do k=1,2
3152             do l=1,2
3153               kkk=kkk+1
3154               muij(kkk)=mu(k,i)*mu(l,j)
3155             enddo
3156           enddo
3157 cd         write (iout,*) 'EELEC: i',i,' j',j
3158 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3159 cd          write(iout,*) 'muij',muij
3160           ury=scalar(uy(1,i),erij)
3161           urz=scalar(uz(1,i),erij)
3162           vry=scalar(uy(1,j),erij)
3163           vrz=scalar(uz(1,j),erij)
3164           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3165           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3166           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3167           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3168           fac=dsqrt(-ael6i)*r3ij
3169           a22=a22*fac
3170           a23=a23*fac
3171           a32=a32*fac
3172           a33=a33*fac
3173 cd          write (iout,'(4i5,4f10.5)')
3174 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3175 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3176 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3177 cd     &      uy(:,j),uz(:,j)
3178 cd          write (iout,'(4f10.5)')
3179 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3180 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3181 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3182 cd           write (iout,'(9f10.5/)')
3183 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3184 C Derivatives of the elements of A in virtual-bond vectors
3185           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3186           do k=1,3
3187             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3188             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3189             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3190             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3191             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3192             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3193             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3194             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3195             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3196             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3197             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3198             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3199           enddo
3200 C Compute radial contributions to the gradient
3201           facr=-3.0d0*rrmij
3202           a22der=a22*facr
3203           a23der=a23*facr
3204           a32der=a32*facr
3205           a33der=a33*facr
3206           agg(1,1)=a22der*xj
3207           agg(2,1)=a22der*yj
3208           agg(3,1)=a22der*zj
3209           agg(1,2)=a23der*xj
3210           agg(2,2)=a23der*yj
3211           agg(3,2)=a23der*zj
3212           agg(1,3)=a32der*xj
3213           agg(2,3)=a32der*yj
3214           agg(3,3)=a32der*zj
3215           agg(1,4)=a33der*xj
3216           agg(2,4)=a33der*yj
3217           agg(3,4)=a33der*zj
3218 C Add the contributions coming from er
3219           fac3=-3.0d0*fac
3220           do k=1,3
3221             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3222             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3223             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3224             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3225           enddo
3226           do k=1,3
3227 C Derivatives in DC(i)
3228 cgrad            ghalf1=0.5d0*agg(k,1)
3229 cgrad            ghalf2=0.5d0*agg(k,2)
3230 cgrad            ghalf3=0.5d0*agg(k,3)
3231 cgrad            ghalf4=0.5d0*agg(k,4)
3232             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3233      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3234             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3235      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3236             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3237      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3238             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3239      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3240 C Derivatives in DC(i+1)
3241             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3242      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3243             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3244      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3245             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3246      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3247             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3248      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3249 C Derivatives in DC(j)
3250             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3251      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3252             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3253      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3254             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3255      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3256             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3257      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3258 C Derivatives in DC(j+1) or DC(nres-1)
3259             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3260      &      -3.0d0*vryg(k,3)*ury)
3261             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3262      &      -3.0d0*vrzg(k,3)*ury)
3263             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3264      &      -3.0d0*vryg(k,3)*urz)
3265             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3266      &      -3.0d0*vrzg(k,3)*urz)
3267 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3268 cgrad              do l=1,4
3269 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3270 cgrad              enddo
3271 cgrad            endif
3272           enddo
3273           acipa(1,1)=a22
3274           acipa(1,2)=a23
3275           acipa(2,1)=a32
3276           acipa(2,2)=a33
3277           a22=-a22
3278           a23=-a23
3279           do l=1,2
3280             do k=1,3
3281               agg(k,l)=-agg(k,l)
3282               aggi(k,l)=-aggi(k,l)
3283               aggi1(k,l)=-aggi1(k,l)
3284               aggj(k,l)=-aggj(k,l)
3285               aggj1(k,l)=-aggj1(k,l)
3286             enddo
3287           enddo
3288           if (j.lt.nres-1) then
3289             a22=-a22
3290             a32=-a32
3291             do l=1,3,2
3292               do k=1,3
3293                 agg(k,l)=-agg(k,l)
3294                 aggi(k,l)=-aggi(k,l)
3295                 aggi1(k,l)=-aggi1(k,l)
3296                 aggj(k,l)=-aggj(k,l)
3297                 aggj1(k,l)=-aggj1(k,l)
3298               enddo
3299             enddo
3300           else
3301             a22=-a22
3302             a23=-a23
3303             a32=-a32
3304             a33=-a33
3305             do l=1,4
3306               do k=1,3
3307                 agg(k,l)=-agg(k,l)
3308                 aggi(k,l)=-aggi(k,l)
3309                 aggi1(k,l)=-aggi1(k,l)
3310                 aggj(k,l)=-aggj(k,l)
3311                 aggj1(k,l)=-aggj1(k,l)
3312               enddo
3313             enddo
3314           endif
3315           ENDIF ! WCORR
3316           IF (wel_loc.gt.0.0d0) THEN
3317 C Contribution to the local-electrostatic energy coming from the i-j pair
3318           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3319      &     +a33*muij(4)
3320 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3321
3322           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3323      &            'eelloc',i,j,eel_loc_ij
3324 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3325
3326           eel_loc=eel_loc+eel_loc_ij
3327 C Partial derivatives in virtual-bond dihedral angles gamma
3328           if (i.gt.1)
3329      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3330      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3331      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3332           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3333      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3334      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3336           do l=1,3
3337             ggg(l)=agg(l,1)*muij(1)+
3338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3339             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3340             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3341 cgrad            ghalf=0.5d0*ggg(l)
3342 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3343 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3344           enddo
3345 cgrad          do k=i+1,j2
3346 cgrad            do l=1,3
3347 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3348 cgrad            enddo
3349 cgrad          enddo
3350 C Remaining derivatives of eello
3351           do l=1,3
3352             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3353      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3354             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3355      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3356             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3357      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3358             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3359      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3360           enddo
3361           ENDIF
3362 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3363 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3364           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3365      &       .and. num_conti.le.maxconts) then
3366 c            write (iout,*) i,j," entered corr"
3367 C
3368 C Calculate the contact function. The ith column of the array JCONT will
3369 C contain the numbers of atoms that make contacts with the atom I (of numbers
3370 C greater than I). The arrays FACONT and GACONT will contain the values of
3371 C the contact function and its derivative.
3372 c           r0ij=1.02D0*rpp(iteli,itelj)
3373 c           r0ij=1.11D0*rpp(iteli,itelj)
3374             r0ij=2.20D0*rpp(iteli,itelj)
3375 c           r0ij=1.55D0*rpp(iteli,itelj)
3376             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3377             if (fcont.gt.0.0D0) then
3378               num_conti=num_conti+1
3379               if (num_conti.gt.maxconts) then
3380                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3381      &                         ' will skip next contacts for this conf.'
3382               else
3383                 jcont_hb(num_conti,i)=j
3384 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3385 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3386                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3387      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3388 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3389 C  terms.
3390                 d_cont(num_conti,i)=rij
3391 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3392 C     --- Electrostatic-interaction matrix ---
3393                 a_chuj(1,1,num_conti,i)=a22
3394                 a_chuj(1,2,num_conti,i)=a23
3395                 a_chuj(2,1,num_conti,i)=a32
3396                 a_chuj(2,2,num_conti,i)=a33
3397 C     --- Gradient of rij
3398                 do kkk=1,3
3399                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3400                 enddo
3401                 kkll=0
3402                 do k=1,2
3403                   do l=1,2
3404                     kkll=kkll+1
3405                     do m=1,3
3406                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3407                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3408                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3409                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3410                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3411                     enddo
3412                   enddo
3413                 enddo
3414                 ENDIF
3415                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3416 C Calculate contact energies
3417                 cosa4=4.0D0*cosa
3418                 wij=cosa-3.0D0*cosb*cosg
3419                 cosbg1=cosb+cosg
3420                 cosbg2=cosb-cosg
3421 c               fac3=dsqrt(-ael6i)/r0ij**3
3422                 fac3=dsqrt(-ael6i)*r3ij
3423 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3424                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3425                 if (ees0tmp.gt.0) then
3426                   ees0pij=dsqrt(ees0tmp)
3427                 else
3428                   ees0pij=0
3429                 endif
3430 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3431                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3432                 if (ees0tmp.gt.0) then
3433                   ees0mij=dsqrt(ees0tmp)
3434                 else
3435                   ees0mij=0
3436                 endif
3437 c               ees0mij=0.0D0
3438                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3439                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3440 C Diagnostics. Comment out or remove after debugging!
3441 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3442 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3443 c               ees0m(num_conti,i)=0.0D0
3444 C End diagnostics.
3445 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3446 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3447 C Angular derivatives of the contact function
3448                 ees0pij1=fac3/ees0pij
3449                 ees0mij1=fac3/ees0mij
3450                 fac3p=-3.0D0*fac3*rrmij
3451                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3452                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3453 c               ees0mij1=0.0D0
3454                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3455                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3456                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3457                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3458                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3459                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3460                 ecosap=ecosa1+ecosa2
3461                 ecosbp=ecosb1+ecosb2
3462                 ecosgp=ecosg1+ecosg2
3463                 ecosam=ecosa1-ecosa2
3464                 ecosbm=ecosb1-ecosb2
3465                 ecosgm=ecosg1-ecosg2
3466 C Diagnostics
3467 c               ecosap=ecosa1
3468 c               ecosbp=ecosb1
3469 c               ecosgp=ecosg1
3470 c               ecosam=0.0D0
3471 c               ecosbm=0.0D0
3472 c               ecosgm=0.0D0
3473 C End diagnostics
3474                 facont_hb(num_conti,i)=fcont
3475                 fprimcont=fprimcont/rij
3476 cd              facont_hb(num_conti,i)=1.0D0
3477 C Following line is for diagnostics.
3478 cd              fprimcont=0.0D0
3479                 do k=1,3
3480                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3481                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3482                 enddo
3483                 do k=1,3
3484                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3485                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3486                 enddo
3487                 gggp(1)=gggp(1)+ees0pijp*xj
3488                 gggp(2)=gggp(2)+ees0pijp*yj
3489                 gggp(3)=gggp(3)+ees0pijp*zj
3490                 gggm(1)=gggm(1)+ees0mijp*xj
3491                 gggm(2)=gggm(2)+ees0mijp*yj
3492                 gggm(3)=gggm(3)+ees0mijp*zj
3493 C Derivatives due to the contact function
3494                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3495                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3496                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3497                 do k=1,3
3498 c
3499 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3500 c          following the change of gradient-summation algorithm.
3501 c
3502 cgrad                  ghalfp=0.5D0*gggp(k)
3503 cgrad                  ghalfm=0.5D0*gggm(k)
3504                   gacontp_hb1(k,num_conti,i)=!ghalfp
3505      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3506      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3507                   gacontp_hb2(k,num_conti,i)=!ghalfp
3508      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3509      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3510                   gacontp_hb3(k,num_conti,i)=gggp(k)
3511                   gacontm_hb1(k,num_conti,i)=!ghalfm
3512      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3513      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3514                   gacontm_hb2(k,num_conti,i)=!ghalfm
3515      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3516      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3517                   gacontm_hb3(k,num_conti,i)=gggm(k)
3518                 enddo
3519 C Diagnostics. Comment out or remove after debugging!
3520 cdiag           do k=1,3
3521 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3522 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3523 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3524 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3525 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3526 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3527 cdiag           enddo
3528               ENDIF ! wcorr
3529               endif  ! num_conti.le.maxconts
3530             endif  ! fcont.gt.0
3531           endif    ! j.gt.i+1
3532           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3533             do k=1,4
3534               do l=1,3
3535                 ghalf=0.5d0*agg(l,k)
3536                 aggi(l,k)=aggi(l,k)+ghalf
3537                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3538                 aggj(l,k)=aggj(l,k)+ghalf
3539               enddo
3540             enddo
3541             if (j.eq.nres-1 .and. i.lt.j-2) then
3542               do k=1,4
3543                 do l=1,3
3544                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3545                 enddo
3546               enddo
3547             endif
3548           endif
3549 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3550       return
3551       end
3552 C-----------------------------------------------------------------------------
3553       subroutine eturn3(i,eello_turn3)
3554 C Third- and fourth-order contributions from turns
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'COMMON.IOUNITS'
3558       include 'COMMON.GEO'
3559       include 'COMMON.VAR'
3560       include 'COMMON.LOCAL'
3561       include 'COMMON.CHAIN'
3562       include 'COMMON.DERIV'
3563       include 'COMMON.INTERACT'
3564       include 'COMMON.CONTACTS'
3565       include 'COMMON.TORSION'
3566       include 'COMMON.VECTORS'
3567       include 'COMMON.FFIELD'
3568       include 'COMMON.CONTROL'
3569       dimension ggg(3)
3570       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3571      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3572      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3573       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3574      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3575       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3576      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3577      &    num_conti,j1,j2
3578       j=i+2
3579 c      write (iout,*) "eturn3",i,j,j1,j2
3580       a_temp(1,1)=a22
3581       a_temp(1,2)=a23
3582       a_temp(2,1)=a32
3583       a_temp(2,2)=a33
3584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3585 C
3586 C               Third-order contributions
3587 C
3588 C                 (i+2)o----(i+3)
3589 C                      | |
3590 C                      | |
3591 C                 (i+1)o----i
3592 C
3593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3594 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3595         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3596         call transpose2(auxmat(1,1),auxmat1(1,1))
3597         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3598         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3600      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3601 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3602 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3603 cd     &    ' eello_turn3_num',4*eello_turn3_num
3604 C Derivatives in gamma(i)
3605         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3606         call transpose2(auxmat2(1,1),auxmat3(1,1))
3607         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3608         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3609 C Derivatives in gamma(i+1)
3610         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3611         call transpose2(auxmat2(1,1),auxmat3(1,1))
3612         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3613         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3614      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3615 C Cartesian derivatives
3616         do l=1,3
3617 c            ghalf1=0.5d0*agg(l,1)
3618 c            ghalf2=0.5d0*agg(l,2)
3619 c            ghalf3=0.5d0*agg(l,3)
3620 c            ghalf4=0.5d0*agg(l,4)
3621           a_temp(1,1)=aggi(l,1)!+ghalf1
3622           a_temp(1,2)=aggi(l,2)!+ghalf2
3623           a_temp(2,1)=aggi(l,3)!+ghalf3
3624           a_temp(2,2)=aggi(l,4)!+ghalf4
3625           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3626           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3627      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3628           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3629           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3630           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3631           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3632           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3633           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3634      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3635           a_temp(1,1)=aggj(l,1)!+ghalf1
3636           a_temp(1,2)=aggj(l,2)!+ghalf2
3637           a_temp(2,1)=aggj(l,3)!+ghalf3
3638           a_temp(2,2)=aggj(l,4)!+ghalf4
3639           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3640           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3641      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3642           a_temp(1,1)=aggj1(l,1)
3643           a_temp(1,2)=aggj1(l,2)
3644           a_temp(2,1)=aggj1(l,3)
3645           a_temp(2,2)=aggj1(l,4)
3646           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3647           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3648      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3649         enddo
3650       return
3651       end
3652 C-------------------------------------------------------------------------------
3653       subroutine eturn4(i,eello_turn4)
3654 C Third- and fourth-order contributions from turns
3655       implicit real*8 (a-h,o-z)
3656       include 'DIMENSIONS'
3657       include 'COMMON.IOUNITS'
3658       include 'COMMON.GEO'
3659       include 'COMMON.VAR'
3660       include 'COMMON.LOCAL'
3661       include 'COMMON.CHAIN'
3662       include 'COMMON.DERIV'
3663       include 'COMMON.INTERACT'
3664       include 'COMMON.CONTACTS'
3665       include 'COMMON.TORSION'
3666       include 'COMMON.VECTORS'
3667       include 'COMMON.FFIELD'
3668       include 'COMMON.CONTROL'
3669       dimension ggg(3)
3670       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3671      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3672      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3673       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3674      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3675       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3676      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3677      &    num_conti,j1,j2
3678       j=i+3
3679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3680 C
3681 C               Fourth-order contributions
3682 C
3683 C                 (i+3)o----(i+4)
3684 C                     /  |
3685 C               (i+2)o   |
3686 C                     \  |
3687 C                 (i+1)o----i
3688 C
3689 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3690 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3691 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3692         a_temp(1,1)=a22
3693         a_temp(1,2)=a23
3694         a_temp(2,1)=a32
3695         a_temp(2,2)=a33
3696         iti1=itortyp(itype(i+1))
3697         iti2=itortyp(itype(i+2))
3698         iti3=itortyp(itype(i+3))
3699 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3700         call transpose2(EUg(1,1,i+1),e1t(1,1))
3701         call transpose2(Eug(1,1,i+2),e2t(1,1))
3702         call transpose2(Eug(1,1,i+3),e3t(1,1))
3703         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3704         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3705         s1=scalar2(b1(1,iti2),auxvec(1))
3706         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3707         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3708         s2=scalar2(b1(1,iti1),auxvec(1))
3709         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3710         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3711         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3712         eello_turn4=eello_turn4-(s1+s2+s3)
3713         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3714      &      'eturn4',i,j,-(s1+s2+s3)
3715 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3716 cd     &    ' eello_turn4_num',8*eello_turn4_num
3717 C Derivatives in gamma(i)
3718         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3719         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3720         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,iti2),auxvec(1))
3722         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3723         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3725 C Derivatives in gamma(i+1)
3726         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3727         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3728         s2=scalar2(b1(1,iti1),auxvec(1))
3729         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3730         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3731         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3732         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3733 C Derivatives in gamma(i+2)
3734         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3735         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3736         s1=scalar2(b1(1,iti2),auxvec(1))
3737         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3738         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3739         s2=scalar2(b1(1,iti1),auxvec(1))
3740         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3741         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3742         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3744 C Cartesian derivatives
3745 C Derivatives of this turn contributions in DC(i+2)
3746         if (j.lt.nres-1) then
3747           do l=1,3
3748             a_temp(1,1)=agg(l,1)
3749             a_temp(1,2)=agg(l,2)
3750             a_temp(2,1)=agg(l,3)
3751             a_temp(2,2)=agg(l,4)
3752             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3753             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3754             s1=scalar2(b1(1,iti2),auxvec(1))
3755             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3756             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3757             s2=scalar2(b1(1,iti1),auxvec(1))
3758             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3759             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3761             ggg(l)=-(s1+s2+s3)
3762             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3763           enddo
3764         endif
3765 C Remaining derivatives of this turn contribution
3766         do l=1,3
3767           a_temp(1,1)=aggi(l,1)
3768           a_temp(1,2)=aggi(l,2)
3769           a_temp(2,1)=aggi(l,3)
3770           a_temp(2,2)=aggi(l,4)
3771           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3772           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3773           s1=scalar2(b1(1,iti2),auxvec(1))
3774           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3775           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3776           s2=scalar2(b1(1,iti1),auxvec(1))
3777           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3778           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3779           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3780           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3781           a_temp(1,1)=aggi1(l,1)
3782           a_temp(1,2)=aggi1(l,2)
3783           a_temp(2,1)=aggi1(l,3)
3784           a_temp(2,2)=aggi1(l,4)
3785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3787           s1=scalar2(b1(1,iti2),auxvec(1))
3788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3790           s2=scalar2(b1(1,iti1),auxvec(1))
3791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3794           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3795           a_temp(1,1)=aggj(l,1)
3796           a_temp(1,2)=aggj(l,2)
3797           a_temp(2,1)=aggj(l,3)
3798           a_temp(2,2)=aggj(l,4)
3799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3801           s1=scalar2(b1(1,iti2),auxvec(1))
3802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3804           s2=scalar2(b1(1,iti1),auxvec(1))
3805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3809           a_temp(1,1)=aggj1(l,1)
3810           a_temp(1,2)=aggj1(l,2)
3811           a_temp(2,1)=aggj1(l,3)
3812           a_temp(2,2)=aggj1(l,4)
3813           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3814           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3815           s1=scalar2(b1(1,iti2),auxvec(1))
3816           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3817           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3818           s2=scalar2(b1(1,iti1),auxvec(1))
3819           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3820           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3821           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3823           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3824         enddo
3825       return
3826       end
3827 C-----------------------------------------------------------------------------
3828       subroutine vecpr(u,v,w)
3829       implicit real*8(a-h,o-z)
3830       dimension u(3),v(3),w(3)
3831       w(1)=u(2)*v(3)-u(3)*v(2)
3832       w(2)=-u(1)*v(3)+u(3)*v(1)
3833       w(3)=u(1)*v(2)-u(2)*v(1)
3834       return
3835       end
3836 C-----------------------------------------------------------------------------
3837       subroutine unormderiv(u,ugrad,unorm,ungrad)
3838 C This subroutine computes the derivatives of a normalized vector u, given
3839 C the derivatives computed without normalization conditions, ugrad. Returns
3840 C ungrad.
3841       implicit none
3842       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3843       double precision vec(3)
3844       double precision scalar
3845       integer i,j
3846 c      write (2,*) 'ugrad',ugrad
3847 c      write (2,*) 'u',u
3848       do i=1,3
3849         vec(i)=scalar(ugrad(1,i),u(1))
3850       enddo
3851 c      write (2,*) 'vec',vec
3852       do i=1,3
3853         do j=1,3
3854           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3855         enddo
3856       enddo
3857 c      write (2,*) 'ungrad',ungrad
3858       return
3859       end
3860 C-----------------------------------------------------------------------------
3861       subroutine escp_soft_sphere(evdw2,evdw2_14)
3862 C
3863 C This subroutine calculates the excluded-volume interaction energy between
3864 C peptide-group centers and side chains and its gradient in virtual-bond and
3865 C side-chain vectors.
3866 C
3867       implicit real*8 (a-h,o-z)
3868       include 'DIMENSIONS'
3869       include 'COMMON.GEO'
3870       include 'COMMON.VAR'
3871       include 'COMMON.LOCAL'
3872       include 'COMMON.CHAIN'
3873       include 'COMMON.DERIV'
3874       include 'COMMON.INTERACT'
3875       include 'COMMON.FFIELD'
3876       include 'COMMON.IOUNITS'
3877       include 'COMMON.CONTROL'
3878       dimension ggg(3)
3879       evdw2=0.0D0
3880       evdw2_14=0.0d0
3881       r0_scp=4.5d0
3882 cd    print '(a)','Enter ESCP'
3883 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3884       do i=iatscp_s,iatscp_e
3885         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3886         iteli=itel(i)
3887         xi=0.5D0*(c(1,i)+c(1,i+1))
3888         yi=0.5D0*(c(2,i)+c(2,i+1))
3889         zi=0.5D0*(c(3,i)+c(3,i+1))
3890
3891         do iint=1,nscp_gr(i)
3892
3893         do j=iscpstart(i,iint),iscpend(i,iint)
3894           if (itype(j).eq.ntyp1) cycle
3895           itypj=iabs(itype(j))
3896 C Uncomment following three lines for SC-p interactions
3897 c         xj=c(1,nres+j)-xi
3898 c         yj=c(2,nres+j)-yi
3899 c         zj=c(3,nres+j)-zi
3900 C Uncomment following three lines for Ca-p interactions
3901           xj=c(1,j)-xi
3902           yj=c(2,j)-yi
3903           zj=c(3,j)-zi
3904           rij=xj*xj+yj*yj+zj*zj
3905           r0ij=r0_scp
3906           r0ijsq=r0ij*r0ij
3907           if (rij.lt.r0ijsq) then
3908             evdwij=0.25d0*(rij-r0ijsq)**2
3909             fac=rij-r0ijsq
3910           else
3911             evdwij=0.0d0
3912             fac=0.0d0
3913           endif
3914           evdw2=evdw2+evdwij
3915 C
3916 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3917 C
3918           ggg(1)=xj*fac
3919           ggg(2)=yj*fac
3920           ggg(3)=zj*fac
3921 cgrad          if (j.lt.i) then
3922 cd          write (iout,*) 'j<i'
3923 C Uncomment following three lines for SC-p interactions
3924 c           do k=1,3
3925 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3926 c           enddo
3927 cgrad          else
3928 cd          write (iout,*) 'j>i'
3929 cgrad            do k=1,3
3930 cgrad              ggg(k)=-ggg(k)
3931 C Uncomment following line for SC-p interactions
3932 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3933 cgrad            enddo
3934 cgrad          endif
3935 cgrad          do k=1,3
3936 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3937 cgrad          enddo
3938 cgrad          kstart=min0(i+1,j)
3939 cgrad          kend=max0(i-1,j-1)
3940 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3941 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3942 cgrad          do k=kstart,kend
3943 cgrad            do l=1,3
3944 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3945 cgrad            enddo
3946 cgrad          enddo
3947           do k=1,3
3948             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3949             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3950           enddo
3951         enddo
3952
3953         enddo ! iint
3954       enddo ! i
3955       return
3956       end
3957 C-----------------------------------------------------------------------------
3958       subroutine escp(evdw2,evdw2_14)
3959 C
3960 C This subroutine calculates the excluded-volume interaction energy between
3961 C peptide-group centers and side chains and its gradient in virtual-bond and
3962 C side-chain vectors.
3963 C
3964       implicit real*8 (a-h,o-z)
3965       include 'DIMENSIONS'
3966       include 'COMMON.GEO'
3967       include 'COMMON.VAR'
3968       include 'COMMON.LOCAL'
3969       include 'COMMON.CHAIN'
3970       include 'COMMON.DERIV'
3971       include 'COMMON.INTERACT'
3972       include 'COMMON.FFIELD'
3973       include 'COMMON.IOUNITS'
3974       include 'COMMON.CONTROL'
3975       dimension ggg(3)
3976       evdw2=0.0D0
3977       evdw2_14=0.0d0
3978 cd    print '(a)','Enter ESCP'
3979 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3980       do i=iatscp_s,iatscp_e
3981         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3982         iteli=itel(i)
3983         xi=0.5D0*(c(1,i)+c(1,i+1))
3984         yi=0.5D0*(c(2,i)+c(2,i+1))
3985         zi=0.5D0*(c(3,i)+c(3,i+1))
3986
3987         do iint=1,nscp_gr(i)
3988
3989         do j=iscpstart(i,iint),iscpend(i,iint)
3990           itypj=iabs(itype(j))
3991           if (itypj.eq.ntyp1) cycle
3992 C Uncomment following three lines for SC-p interactions
3993 c         xj=c(1,nres+j)-xi
3994 c         yj=c(2,nres+j)-yi
3995 c         zj=c(3,nres+j)-zi
3996 C Uncomment following three lines for Ca-p interactions
3997           xj=c(1,j)-xi
3998           yj=c(2,j)-yi
3999           zj=c(3,j)-zi
4000           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4001           fac=rrij**expon2
4002           e1=fac*fac*aad(itypj,iteli)
4003           e2=fac*bad(itypj,iteli)
4004           if (iabs(j-i) .le. 2) then
4005             e1=scal14*e1
4006             e2=scal14*e2
4007             evdw2_14=evdw2_14+e1+e2
4008           endif
4009           evdwij=e1+e2
4010           evdw2=evdw2+evdwij
4011           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4012      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4013      &       bad(itypj,iteli)
4014 C
4015 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4016 C
4017           fac=-(evdwij+e1)*rrij
4018           ggg(1)=xj*fac
4019           ggg(2)=yj*fac
4020           ggg(3)=zj*fac
4021 cgrad          if (j.lt.i) then
4022 cd          write (iout,*) 'j<i'
4023 C Uncomment following three lines for SC-p interactions
4024 c           do k=1,3
4025 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4026 c           enddo
4027 cgrad          else
4028 cd          write (iout,*) 'j>i'
4029 cgrad            do k=1,3
4030 cgrad              ggg(k)=-ggg(k)
4031 C Uncomment following line for SC-p interactions
4032 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4033 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4034 cgrad            enddo
4035 cgrad          endif
4036 cgrad          do k=1,3
4037 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4038 cgrad          enddo
4039 cgrad          kstart=min0(i+1,j)
4040 cgrad          kend=max0(i-1,j-1)
4041 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4042 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4043 cgrad          do k=kstart,kend
4044 cgrad            do l=1,3
4045 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4046 cgrad            enddo
4047 cgrad          enddo
4048           do k=1,3
4049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4051           enddo
4052         enddo
4053
4054         enddo ! iint
4055       enddo ! i
4056       do i=1,nct
4057         do j=1,3
4058           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4059           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4060           gradx_scp(j,i)=expon*gradx_scp(j,i)
4061         enddo
4062       enddo
4063 C******************************************************************************
4064 C
4065 C                              N O T E !!!
4066 C
4067 C To save time the factor EXPON has been extracted from ALL components
4068 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4069 C use!
4070 C
4071 C******************************************************************************
4072       return
4073       end
4074 C--------------------------------------------------------------------------
4075       subroutine edis(ehpb)
4076 C
4077 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4078 C
4079       implicit real*8 (a-h,o-z)
4080       include 'DIMENSIONS'
4081       include 'COMMON.SBRIDGE'
4082       include 'COMMON.CHAIN'
4083       include 'COMMON.DERIV'
4084       include 'COMMON.VAR'
4085       include 'COMMON.INTERACT'
4086       include 'COMMON.IOUNITS'
4087       include 'COMMON.CONTROL'
4088       dimension ggg(3)
4089       ehpb=0.0D0
4090       do i=1,3
4091        ggg(i)=0.0d0
4092       enddo
4093 C      write (iout,*) ,"link_end",link_end,constr_dist
4094 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4095 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4096       if (link_end.eq.0) return
4097       do i=link_start,link_end
4098 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4099 C CA-CA distance used in regularization of structure.
4100         ii=ihpb(i)
4101         jj=jhpb(i)
4102 C iii and jjj point to the residues for which the distance is assigned.
4103         if (ii.gt.nres) then
4104           iii=ii-nres
4105           jjj=jj-nres
4106         else
4107           iii=ii
4108           jjj=jj
4109         endif
4110 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4111 c     &    dhpb(i),dhpb1(i),forcon(i)
4112 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4113 C    distance and angle dependent SS bond potential.
4114 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4115 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4116         if (.not.dyn_ss .and. i.le.nss) then
4117 C 15/02/13 CC dynamic SSbond - additional check
4118          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4119      & iabs(itype(jjj)).eq.1) then
4120           call ssbond_ene(iii,jjj,eij)
4121           ehpb=ehpb+2*eij
4122          endif
4123 cd          write (iout,*) "eij",eij
4124 cd   &   ' waga=',waga,' fac=',fac
4125         else if (ii.gt.nres .and. jj.gt.nres) then
4126 c Restraints from contact prediction
4127           dd=dist(ii,jj)
4128           if (constr_dist.eq.11) then
4129             ehpb=ehpb+fordepth(i)**4.0d0
4130      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4131             fac=fordepth(i)**4.0d0
4132      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4133           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4134      &    ehpb,fordepth(i),dd
4135            else
4136           if (dhpb1(i).gt.0.0d0) then
4137             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4138             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4139 c            write (iout,*) "beta nmr",
4140 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4141           else
4142             dd=dist(ii,jj)
4143             rdis=dd-dhpb(i)
4144 C Get the force constant corresponding to this distance.
4145             waga=forcon(i)
4146 C Calculate the contribution to energy.
4147             ehpb=ehpb+waga*rdis*rdis
4148 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4149 C
4150 C Evaluate gradient.
4151 C
4152             fac=waga*rdis/dd
4153           endif
4154           endif
4155           do j=1,3
4156             ggg(j)=fac*(c(j,jj)-c(j,ii))
4157           enddo
4158           do j=1,3
4159             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4160             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4161           enddo
4162           do k=1,3
4163             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4164             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4165           enddo
4166         else
4167 C Calculate the distance between the two points and its difference from the
4168 C target distance.
4169           dd=dist(ii,jj)
4170           if (constr_dist.eq.11) then
4171             ehpb=ehpb+fordepth(i)**4.0d0
4172      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4173             fac=fordepth(i)**4.0d0
4174      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4175           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4176      &    ehpb,fordepth(i),dd
4177            else
4178           if (dhpb1(i).gt.0.0d0) then
4179             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4180             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4181 c            write (iout,*) "alph nmr",
4182 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4183           else
4184             rdis=dd-dhpb(i)
4185 C Get the force constant corresponding to this distance.
4186             waga=forcon(i)
4187 C Calculate the contribution to energy.
4188             ehpb=ehpb+waga*rdis*rdis
4189 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4190 C
4191 C Evaluate gradient.
4192 C
4193             fac=waga*rdis/dd
4194           endif
4195           endif
4196             do j=1,3
4197               ggg(j)=fac*(c(j,jj)-c(j,ii))
4198             enddo
4199 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4200 C If this is a SC-SC distance, we need to calculate the contributions to the
4201 C Cartesian gradient in the SC vectors (ghpbx).
4202           if (iii.lt.ii) then
4203           do j=1,3
4204             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4205             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4206           enddo
4207           endif
4208 cgrad        do j=iii,jjj-1
4209 cgrad          do k=1,3
4210 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4211 cgrad          enddo
4212 cgrad        enddo
4213           do k=1,3
4214             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4215             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4216           enddo
4217         endif
4218       enddo
4219       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4220       return
4221       end
4222 C--------------------------------------------------------------------------
4223       subroutine ssbond_ene(i,j,eij)
4224 C
4225 C Calculate the distance and angle dependent SS-bond potential energy
4226 C using a free-energy function derived based on RHF/6-31G** ab initio
4227 C calculations of diethyl disulfide.
4228 C
4229 C A. Liwo and U. Kozlowska, 11/24/03
4230 C
4231       implicit real*8 (a-h,o-z)
4232       include 'DIMENSIONS'
4233       include 'COMMON.SBRIDGE'
4234       include 'COMMON.CHAIN'
4235       include 'COMMON.DERIV'
4236       include 'COMMON.LOCAL'
4237       include 'COMMON.INTERACT'
4238       include 'COMMON.VAR'
4239       include 'COMMON.IOUNITS'
4240       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4241       itypi=iabs(itype(i))
4242       xi=c(1,nres+i)
4243       yi=c(2,nres+i)
4244       zi=c(3,nres+i)
4245       dxi=dc_norm(1,nres+i)
4246       dyi=dc_norm(2,nres+i)
4247       dzi=dc_norm(3,nres+i)
4248 c      dsci_inv=dsc_inv(itypi)
4249       dsci_inv=vbld_inv(nres+i)
4250       itypj=iabs(itype(j))
4251 c      dscj_inv=dsc_inv(itypj)
4252       dscj_inv=vbld_inv(nres+j)
4253       xj=c(1,nres+j)-xi
4254       yj=c(2,nres+j)-yi
4255       zj=c(3,nres+j)-zi
4256       dxj=dc_norm(1,nres+j)
4257       dyj=dc_norm(2,nres+j)
4258       dzj=dc_norm(3,nres+j)
4259       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4260       rij=dsqrt(rrij)
4261       erij(1)=xj*rij
4262       erij(2)=yj*rij
4263       erij(3)=zj*rij
4264       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4265       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4266       om12=dxi*dxj+dyi*dyj+dzi*dzj
4267       do k=1,3
4268         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4269         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4270       enddo
4271       rij=1.0d0/rij
4272       deltad=rij-d0cm
4273       deltat1=1.0d0-om1
4274       deltat2=1.0d0+om2
4275       deltat12=om2-om1+2.0d0
4276       cosphi=om12-om1*om2
4277       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4278      &  +akct*deltad*deltat12
4279      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4280 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4281 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4282 c     &  " deltat12",deltat12," eij",eij
4283       ed=2*akcm*deltad+akct*deltat12
4284       pom1=akct*deltad
4285       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4286       eom1=-2*akth*deltat1-pom1-om2*pom2
4287       eom2= 2*akth*deltat2+pom1-om1*pom2
4288       eom12=pom2
4289       do k=1,3
4290         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4291         ghpbx(k,i)=ghpbx(k,i)-ggk
4292      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4293      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4294         ghpbx(k,j)=ghpbx(k,j)+ggk
4295      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4296      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4297         ghpbc(k,i)=ghpbc(k,i)-ggk
4298         ghpbc(k,j)=ghpbc(k,j)+ggk
4299       enddo
4300 C
4301 C Calculate the components of the gradient in DC and X
4302 C
4303 cgrad      do k=i,j-1
4304 cgrad        do l=1,3
4305 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4306 cgrad        enddo
4307 cgrad      enddo
4308       return
4309       end
4310 C--------------------------------------------------------------------------
4311       subroutine ebond(estr)
4312 c
4313 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4314 c
4315       implicit real*8 (a-h,o-z)
4316       include 'DIMENSIONS'
4317       include 'COMMON.LOCAL'
4318       include 'COMMON.GEO'
4319       include 'COMMON.INTERACT'
4320       include 'COMMON.DERIV'
4321       include 'COMMON.VAR'
4322       include 'COMMON.CHAIN'
4323       include 'COMMON.IOUNITS'
4324       include 'COMMON.NAMES'
4325       include 'COMMON.FFIELD'
4326       include 'COMMON.CONTROL'
4327       include 'COMMON.SETUP'
4328       double precision u(3),ud(3)
4329       estr=0.0d0
4330       estr1=0.0d0
4331       do i=ibondp_start,ibondp_end
4332         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4333           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4334           do j=1,3
4335           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4336      &      *dc(j,i-1)/vbld(i)
4337           enddo
4338           if (energy_dec) write(iout,*)
4339      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4340         else
4341         diff = vbld(i)-vbldp0
4342         if (energy_dec) write (iout,*)
4343      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4344         estr=estr+diff*diff
4345         do j=1,3
4346           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4347         enddo
4348 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4349         endif
4350       enddo
4351       estr=0.5d0*AKP*estr+estr1
4352 c
4353 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4354 c
4355       do i=ibond_start,ibond_end
4356         iti=iabs(itype(i))
4357         if (iti.ne.10 .and. iti.ne.ntyp1) then
4358           nbi=nbondterm(iti)
4359           if (nbi.eq.1) then
4360             diff=vbld(i+nres)-vbldsc0(1,iti)
4361             if (energy_dec) write (iout,*)
4362      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4363      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4364             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4365             do j=1,3
4366               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4367             enddo
4368           else
4369             do j=1,nbi
4370               diff=vbld(i+nres)-vbldsc0(j,iti)
4371               ud(j)=aksc(j,iti)*diff
4372               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4373             enddo
4374             uprod=u(1)
4375             do j=2,nbi
4376               uprod=uprod*u(j)
4377             enddo
4378             usum=0.0d0
4379             usumsqder=0.0d0
4380             do j=1,nbi
4381               uprod1=1.0d0
4382               uprod2=1.0d0
4383               do k=1,nbi
4384                 if (k.ne.j) then
4385                   uprod1=uprod1*u(k)
4386                   uprod2=uprod2*u(k)*u(k)
4387                 endif
4388               enddo
4389               usum=usum+uprod1
4390               usumsqder=usumsqder+ud(j)*uprod2
4391             enddo
4392             estr=estr+uprod/usum
4393             do j=1,3
4394              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4395             enddo
4396           endif
4397         endif
4398       enddo
4399       return
4400       end
4401 #ifdef CRYST_THETA
4402 C--------------------------------------------------------------------------
4403       subroutine ebend(etheta)
4404 C
4405 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4406 C angles gamma and its derivatives in consecutive thetas and gammas.
4407 C
4408       implicit real*8 (a-h,o-z)
4409       include 'DIMENSIONS'
4410       include 'COMMON.LOCAL'
4411       include 'COMMON.GEO'
4412       include 'COMMON.INTERACT'
4413       include 'COMMON.DERIV'
4414       include 'COMMON.VAR'
4415       include 'COMMON.CHAIN'
4416       include 'COMMON.IOUNITS'
4417       include 'COMMON.NAMES'
4418       include 'COMMON.FFIELD'
4419       include 'COMMON.CONTROL'
4420       common /calcthet/ term1,term2,termm,diffak,ratak,
4421      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4422      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4423       double precision y(2),z(2)
4424       delta=0.02d0*pi
4425 c      time11=dexp(-2*time)
4426 c      time12=1.0d0
4427       etheta=0.0D0
4428 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4429       do i=ithet_start,ithet_end
4430         if (itype(i-1).eq.ntyp1) cycle
4431 C Zero the energy function and its derivative at 0 or pi.
4432         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4433         it=itype(i-1)
4434         ichir1=isign(1,itype(i-2))
4435         ichir2=isign(1,itype(i))
4436          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4437          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4438          if (itype(i-1).eq.10) then
4439           itype1=isign(10,itype(i-2))
4440           ichir11=isign(1,itype(i-2))
4441           ichir12=isign(1,itype(i-2))
4442           itype2=isign(10,itype(i))
4443           ichir21=isign(1,itype(i))
4444           ichir22=isign(1,itype(i))
4445          endif
4446
4447         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4448 #ifdef OSF
4449           phii=phi(i)
4450           if (phii.ne.phii) phii=150.0
4451 #else
4452           phii=phi(i)
4453 #endif
4454           y(1)=dcos(phii)
4455           y(2)=dsin(phii)
4456         else
4457           y(1)=0.0D0
4458           y(2)=0.0D0
4459         endif
4460         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4461 #ifdef OSF
4462           phii1=phi(i+1)
4463           if (phii1.ne.phii1) phii1=150.0
4464           phii1=pinorm(phii1)
4465           z(1)=cos(phii1)
4466 #else
4467           phii1=phi(i+1)
4468           z(1)=dcos(phii1)
4469 #endif
4470           z(2)=dsin(phii1)
4471         else
4472           z(1)=0.0D0
4473           z(2)=0.0D0
4474         endif
4475 C Calculate the "mean" value of theta from the part of the distribution
4476 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4477 C In following comments this theta will be referred to as t_c.
4478         thet_pred_mean=0.0d0
4479         do k=1,2
4480             athetk=athet(k,it,ichir1,ichir2)
4481             bthetk=bthet(k,it,ichir1,ichir2)
4482           if (it.eq.10) then
4483              athetk=athet(k,itype1,ichir11,ichir12)
4484              bthetk=bthet(k,itype2,ichir21,ichir22)
4485           endif
4486          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4487         enddo
4488         dthett=thet_pred_mean*ssd
4489         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4490 C Derivatives of the "mean" values in gamma1 and gamma2.
4491         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4492      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4493          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4494      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4495          if (it.eq.10) then
4496       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4497      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4498         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4499      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4500          endif
4501         if (theta(i).gt.pi-delta) then
4502           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4503      &         E_tc0)
4504           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4505           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4506           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4507      &        E_theta)
4508           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4509      &        E_tc)
4510         else if (theta(i).lt.delta) then
4511           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4512           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4513           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4514      &        E_theta)
4515           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4516           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4517      &        E_tc)
4518         else
4519           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4520      &        E_theta,E_tc)
4521         endif
4522         etheta=etheta+ethetai
4523         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4524      &      'ebend',i,ethetai
4525         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4526         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4527         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4528       enddo
4529 C Ufff.... We've done all this!!!
4530       return
4531       end
4532 C---------------------------------------------------------------------------
4533       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4534      &     E_tc)
4535       implicit real*8 (a-h,o-z)
4536       include 'DIMENSIONS'
4537       include 'COMMON.LOCAL'
4538       include 'COMMON.IOUNITS'
4539       common /calcthet/ term1,term2,termm,diffak,ratak,
4540      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4541      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4542 C Calculate the contributions to both Gaussian lobes.
4543 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4544 C The "polynomial part" of the "standard deviation" of this part of
4545 C the distribution.
4546         sig=polthet(3,it)
4547         do j=2,0,-1
4548           sig=sig*thet_pred_mean+polthet(j,it)
4549         enddo
4550 C Derivative of the "interior part" of the "standard deviation of the"
4551 C gamma-dependent Gaussian lobe in t_c.
4552         sigtc=3*polthet(3,it)
4553         do j=2,1,-1
4554           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4555         enddo
4556         sigtc=sig*sigtc
4557 C Set the parameters of both Gaussian lobes of the distribution.
4558 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4559         fac=sig*sig+sigc0(it)
4560         sigcsq=fac+fac
4561         sigc=1.0D0/sigcsq
4562 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4563         sigsqtc=-4.0D0*sigcsq*sigtc
4564 c       print *,i,sig,sigtc,sigsqtc
4565 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4566         sigtc=-sigtc/(fac*fac)
4567 C Following variable is sigma(t_c)**(-2)
4568         sigcsq=sigcsq*sigcsq
4569         sig0i=sig0(it)
4570         sig0inv=1.0D0/sig0i**2
4571         delthec=thetai-thet_pred_mean
4572         delthe0=thetai-theta0i
4573         term1=-0.5D0*sigcsq*delthec*delthec
4574         term2=-0.5D0*sig0inv*delthe0*delthe0
4575 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4576 C NaNs in taking the logarithm. We extract the largest exponent which is added
4577 C to the energy (this being the log of the distribution) at the end of energy
4578 C term evaluation for this virtual-bond angle.
4579         if (term1.gt.term2) then
4580           termm=term1
4581           term2=dexp(term2-termm)
4582           term1=1.0d0
4583         else
4584           termm=term2
4585           term1=dexp(term1-termm)
4586           term2=1.0d0
4587         endif
4588 C The ratio between the gamma-independent and gamma-dependent lobes of
4589 C the distribution is a Gaussian function of thet_pred_mean too.
4590         diffak=gthet(2,it)-thet_pred_mean
4591         ratak=diffak/gthet(3,it)**2
4592         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4593 C Let's differentiate it in thet_pred_mean NOW.
4594         aktc=ak*ratak
4595 C Now put together the distribution terms to make complete distribution.
4596         termexp=term1+ak*term2
4597         termpre=sigc+ak*sig0i
4598 C Contribution of the bending energy from this theta is just the -log of
4599 C the sum of the contributions from the two lobes and the pre-exponential
4600 C factor. Simple enough, isn't it?
4601         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4602 C NOW the derivatives!!!
4603 C 6/6/97 Take into account the deformation.
4604         E_theta=(delthec*sigcsq*term1
4605      &       +ak*delthe0*sig0inv*term2)/termexp
4606         E_tc=((sigtc+aktc*sig0i)/termpre
4607      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4608      &       aktc*term2)/termexp)
4609       return
4610       end
4611 c-----------------------------------------------------------------------------
4612       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4613       implicit real*8 (a-h,o-z)
4614       include 'DIMENSIONS'
4615       include 'COMMON.LOCAL'
4616       include 'COMMON.IOUNITS'
4617       common /calcthet/ term1,term2,termm,diffak,ratak,
4618      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4619      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4620       delthec=thetai-thet_pred_mean
4621       delthe0=thetai-theta0i
4622 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4623       t3 = thetai-thet_pred_mean
4624       t6 = t3**2
4625       t9 = term1
4626       t12 = t3*sigcsq
4627       t14 = t12+t6*sigsqtc
4628       t16 = 1.0d0
4629       t21 = thetai-theta0i
4630       t23 = t21**2
4631       t26 = term2
4632       t27 = t21*t26
4633       t32 = termexp
4634       t40 = t32**2
4635       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4636      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4637      & *(-t12*t9-ak*sig0inv*t27)
4638       return
4639       end
4640 #else
4641 C--------------------------------------------------------------------------
4642       subroutine ebend(etheta)
4643 C
4644 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4645 C angles gamma and its derivatives in consecutive thetas and gammas.
4646 C ab initio-derived potentials from
4647 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4648 C
4649       implicit real*8 (a-h,o-z)
4650       include 'DIMENSIONS'
4651       include 'COMMON.LOCAL'
4652       include 'COMMON.GEO'
4653       include 'COMMON.INTERACT'
4654       include 'COMMON.DERIV'
4655       include 'COMMON.VAR'
4656       include 'COMMON.CHAIN'
4657       include 'COMMON.IOUNITS'
4658       include 'COMMON.NAMES'
4659       include 'COMMON.FFIELD'
4660       include 'COMMON.CONTROL'
4661       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4662      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4663      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4664      & sinph1ph2(maxdouble,maxdouble)
4665       logical lprn /.false./, lprn1 /.false./
4666       etheta=0.0D0
4667       do i=ithet_start,ithet_end
4668         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4669      &(itype(i).eq.ntyp1)) cycle
4670 C        print *,i,theta(i)
4671         if (iabs(itype(i+1)).eq.20) iblock=2
4672         if (iabs(itype(i+1)).ne.20) iblock=1
4673         dethetai=0.0d0
4674         dephii=0.0d0
4675         dephii1=0.0d0
4676         theti2=0.5d0*theta(i)
4677         ityp2=ithetyp((itype(i-1)))
4678         do k=1,nntheterm
4679           coskt(k)=dcos(k*theti2)
4680           sinkt(k)=dsin(k*theti2)
4681         enddo
4682 C        print *,ethetai
4683
4684         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4685 #ifdef OSF
4686           phii=phi(i)
4687           if (phii.ne.phii) phii=150.0
4688 #else
4689           phii=phi(i)
4690 #endif
4691           ityp1=ithetyp((itype(i-2)))
4692 C propagation of chirality for glycine type
4693           do k=1,nsingle
4694             cosph1(k)=dcos(k*phii)
4695             sinph1(k)=dsin(k*phii)
4696           enddo
4697         else
4698           phii=0.0d0
4699           do k=1,nsingle
4700           ityp1=ithetyp((itype(i-2)))
4701             cosph1(k)=0.0d0
4702             sinph1(k)=0.0d0
4703           enddo
4704         endif
4705         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4706 #ifdef OSF
4707           phii1=phi(i+1)
4708           if (phii1.ne.phii1) phii1=150.0
4709           phii1=pinorm(phii1)
4710 #else
4711           phii1=phi(i+1)
4712 #endif
4713           ityp3=ithetyp((itype(i)))
4714           do k=1,nsingle
4715             cosph2(k)=dcos(k*phii1)
4716             sinph2(k)=dsin(k*phii1)
4717           enddo
4718         else
4719           phii1=0.0d0
4720           ityp3=ithetyp((itype(i)))
4721           do k=1,nsingle
4722             cosph2(k)=0.0d0
4723             sinph2(k)=0.0d0
4724           enddo
4725         endif
4726         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4727         do k=1,ndouble
4728           do l=1,k-1
4729             ccl=cosph1(l)*cosph2(k-l)
4730             ssl=sinph1(l)*sinph2(k-l)
4731             scl=sinph1(l)*cosph2(k-l)
4732             csl=cosph1(l)*sinph2(k-l)
4733             cosph1ph2(l,k)=ccl-ssl
4734             cosph1ph2(k,l)=ccl+ssl
4735             sinph1ph2(l,k)=scl+csl
4736             sinph1ph2(k,l)=scl-csl
4737           enddo
4738         enddo
4739         if (lprn) then
4740         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4741      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4742         write (iout,*) "coskt and sinkt"
4743         do k=1,nntheterm
4744           write (iout,*) k,coskt(k),sinkt(k)
4745         enddo
4746         endif
4747         do k=1,ntheterm
4748           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4749           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4750      &      *coskt(k)
4751           if (lprn)
4752      &    write (iout,*) "k",k,"
4753      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4754      &     " ethetai",ethetai
4755         enddo
4756         if (lprn) then
4757         write (iout,*) "cosph and sinph"
4758         do k=1,nsingle
4759           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4760         enddo
4761         write (iout,*) "cosph1ph2 and sinph2ph2"
4762         do k=2,ndouble
4763           do l=1,k-1
4764             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4765      &         sinph1ph2(l,k),sinph1ph2(k,l)
4766           enddo
4767         enddo
4768         write(iout,*) "ethetai",ethetai
4769         endif
4770 C       print *,ethetai
4771         do m=1,ntheterm2
4772           do k=1,nsingle
4773             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4774      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4775      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4776      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4777             ethetai=ethetai+sinkt(m)*aux
4778             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4779             dephii=dephii+k*sinkt(m)*(
4780      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4781      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4782             dephii1=dephii1+k*sinkt(m)*(
4783      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4784      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4785             if (lprn)
4786      &      write (iout,*) "m",m," k",k," bbthet",
4787      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4788      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4789      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4790      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4791 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4792           enddo
4793         enddo
4794 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4795 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4796 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4797 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4798         if (lprn)
4799      &  write(iout,*) "ethetai",ethetai
4800 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4801         do m=1,ntheterm3
4802           do k=2,ndouble
4803             do l=1,k-1
4804               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4805      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4806      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4807      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4808               ethetai=ethetai+sinkt(m)*aux
4809               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4810               dephii=dephii+l*sinkt(m)*(
4811      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4812      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4813      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4814      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4815               dephii1=dephii1+(k-l)*sinkt(m)*(
4816      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4817      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4818      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4819      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4820               if (lprn) then
4821               write (iout,*) "m",m," k",k," l",l," ffthet",
4822      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4823      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4824      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4825      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4826      &            " ethetai",ethetai
4827               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4828      &            cosph1ph2(k,l)*sinkt(m),
4829      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4830               endif
4831             enddo
4832           enddo
4833         enddo
4834 10      continue
4835 c        lprn1=.true.
4836 C        print *,ethetai
4837         if (lprn1)
4838      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4839      &   i,theta(i)*rad2deg,phii*rad2deg,
4840      &   phii1*rad2deg,ethetai
4841 c        lprn1=.false.
4842         etheta=etheta+ethetai
4843         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4844         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4845         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4846       enddo
4847       return
4848       end
4849 #endif
4850 #ifdef CRYST_SC
4851 c-----------------------------------------------------------------------------
4852       subroutine esc(escloc)
4853 C Calculate the local energy of a side chain and its derivatives in the
4854 C corresponding virtual-bond valence angles THETA and the spherical angles
4855 C ALPHA and OMEGA.
4856       implicit real*8 (a-h,o-z)
4857       include 'DIMENSIONS'
4858       include 'COMMON.GEO'
4859       include 'COMMON.LOCAL'
4860       include 'COMMON.VAR'
4861       include 'COMMON.INTERACT'
4862       include 'COMMON.DERIV'
4863       include 'COMMON.CHAIN'
4864       include 'COMMON.IOUNITS'
4865       include 'COMMON.NAMES'
4866       include 'COMMON.FFIELD'
4867       include 'COMMON.CONTROL'
4868       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4869      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4870       common /sccalc/ time11,time12,time112,theti,it,nlobit
4871       delta=0.02d0*pi
4872       escloc=0.0D0
4873 c     write (iout,'(a)') 'ESC'
4874       do i=loc_start,loc_end
4875         it=itype(i)
4876         if (it.eq.ntyp1) cycle
4877         if (it.eq.10) goto 1
4878         nlobit=nlob(iabs(it))
4879 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4880 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4881         theti=theta(i+1)-pipol
4882         x(1)=dtan(theti)
4883         x(2)=alph(i)
4884         x(3)=omeg(i)
4885
4886         if (x(2).gt.pi-delta) then
4887           xtemp(1)=x(1)
4888           xtemp(2)=pi-delta
4889           xtemp(3)=x(3)
4890           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4891           xtemp(2)=pi
4892           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4893           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4894      &        escloci,dersc(2))
4895           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4896      &        ddersc0(1),dersc(1))
4897           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4898      &        ddersc0(3),dersc(3))
4899           xtemp(2)=pi-delta
4900           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4901           xtemp(2)=pi
4902           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4903           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4904      &            dersc0(2),esclocbi,dersc02)
4905           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4906      &            dersc12,dersc01)
4907           call splinthet(x(2),0.5d0*delta,ss,ssd)
4908           dersc0(1)=dersc01
4909           dersc0(2)=dersc02
4910           dersc0(3)=0.0d0
4911           do k=1,3
4912             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4913           enddo
4914           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4915 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4916 c    &             esclocbi,ss,ssd
4917           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4918 c         escloci=esclocbi
4919 c         write (iout,*) escloci
4920         else if (x(2).lt.delta) then
4921           xtemp(1)=x(1)
4922           xtemp(2)=delta
4923           xtemp(3)=x(3)
4924           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4925           xtemp(2)=0.0d0
4926           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4927           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4928      &        escloci,dersc(2))
4929           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4930      &        ddersc0(1),dersc(1))
4931           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4932      &        ddersc0(3),dersc(3))
4933           xtemp(2)=delta
4934           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4935           xtemp(2)=0.0d0
4936           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4937           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4938      &            dersc0(2),esclocbi,dersc02)
4939           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4940      &            dersc12,dersc01)
4941           dersc0(1)=dersc01
4942           dersc0(2)=dersc02
4943           dersc0(3)=0.0d0
4944           call splinthet(x(2),0.5d0*delta,ss,ssd)
4945           do k=1,3
4946             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4947           enddo
4948           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4949 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4950 c    &             esclocbi,ss,ssd
4951           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4952 c         write (iout,*) escloci
4953         else
4954           call enesc(x,escloci,dersc,ddummy,.false.)
4955         endif
4956
4957         escloc=escloc+escloci
4958         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4959      &     'escloc',i,escloci
4960 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4961
4962         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4963      &   wscloc*dersc(1)
4964         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4965         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4966     1   continue
4967       enddo
4968       return
4969       end
4970 C---------------------------------------------------------------------------
4971       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4972       implicit real*8 (a-h,o-z)
4973       include 'DIMENSIONS'
4974       include 'COMMON.GEO'
4975       include 'COMMON.LOCAL'
4976       include 'COMMON.IOUNITS'
4977       common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4979       double precision contr(maxlob,-1:1)
4980       logical mixed
4981 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4982         escloc_i=0.0D0
4983         do j=1,3
4984           dersc(j)=0.0D0
4985           if (mixed) ddersc(j)=0.0d0
4986         enddo
4987         x3=x(3)
4988
4989 C Because of periodicity of the dependence of the SC energy in omega we have
4990 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4991 C To avoid underflows, first compute & store the exponents.
4992
4993         do iii=-1,1
4994
4995           x(3)=x3+iii*dwapi
4996
4997           do j=1,nlobit
4998             do k=1,3
4999               z(k)=x(k)-censc(k,j,it)
5000             enddo
5001             do k=1,3
5002               Axk=0.0D0
5003               do l=1,3
5004                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5005               enddo
5006               Ax(k,j,iii)=Axk
5007             enddo
5008             expfac=0.0D0
5009             do k=1,3
5010               expfac=expfac+Ax(k,j,iii)*z(k)
5011             enddo
5012             contr(j,iii)=expfac
5013           enddo ! j
5014
5015         enddo ! iii
5016
5017         x(3)=x3
5018 C As in the case of ebend, we want to avoid underflows in exponentiation and
5019 C subsequent NaNs and INFs in energy calculation.
5020 C Find the largest exponent
5021         emin=contr(1,-1)
5022         do iii=-1,1
5023           do j=1,nlobit
5024             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5025           enddo
5026         enddo
5027         emin=0.5D0*emin
5028 cd      print *,'it=',it,' emin=',emin
5029
5030 C Compute the contribution to SC energy and derivatives
5031         do iii=-1,1
5032
5033           do j=1,nlobit
5034 #ifdef OSF
5035             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5036             if(adexp.ne.adexp) adexp=1.0
5037             expfac=dexp(adexp)
5038 #else
5039             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5040 #endif
5041 cd          print *,'j=',j,' expfac=',expfac
5042             escloc_i=escloc_i+expfac
5043             do k=1,3
5044               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5045             enddo
5046             if (mixed) then
5047               do k=1,3,2
5048                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5049      &            +gaussc(k,2,j,it))*expfac
5050               enddo
5051             endif
5052           enddo
5053
5054         enddo ! iii
5055
5056         dersc(1)=dersc(1)/cos(theti)**2
5057         ddersc(1)=ddersc(1)/cos(theti)**2
5058         ddersc(3)=ddersc(3)
5059
5060         escloci=-(dlog(escloc_i)-emin)
5061         do j=1,3
5062           dersc(j)=dersc(j)/escloc_i
5063         enddo
5064         if (mixed) then
5065           do j=1,3,2
5066             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5067           enddo
5068         endif
5069       return
5070       end
5071 C------------------------------------------------------------------------------
5072       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'COMMON.GEO'
5076       include 'COMMON.LOCAL'
5077       include 'COMMON.IOUNITS'
5078       common /sccalc/ time11,time12,time112,theti,it,nlobit
5079       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5080       double precision contr(maxlob)
5081       logical mixed
5082
5083       escloc_i=0.0D0
5084
5085       do j=1,3
5086         dersc(j)=0.0D0
5087       enddo
5088
5089       do j=1,nlobit
5090         do k=1,2
5091           z(k)=x(k)-censc(k,j,it)
5092         enddo
5093         z(3)=dwapi
5094         do k=1,3
5095           Axk=0.0D0
5096           do l=1,3
5097             Axk=Axk+gaussc(l,k,j,it)*z(l)
5098           enddo
5099           Ax(k,j)=Axk
5100         enddo
5101         expfac=0.0D0
5102         do k=1,3
5103           expfac=expfac+Ax(k,j)*z(k)
5104         enddo
5105         contr(j)=expfac
5106       enddo ! j
5107
5108 C As in the case of ebend, we want to avoid underflows in exponentiation and
5109 C subsequent NaNs and INFs in energy calculation.
5110 C Find the largest exponent
5111       emin=contr(1)
5112       do j=1,nlobit
5113         if (emin.gt.contr(j)) emin=contr(j)
5114       enddo
5115       emin=0.5D0*emin
5116
5117 C Compute the contribution to SC energy and derivatives
5118
5119       dersc12=0.0d0
5120       do j=1,nlobit
5121         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5122         escloc_i=escloc_i+expfac
5123         do k=1,2
5124           dersc(k)=dersc(k)+Ax(k,j)*expfac
5125         enddo
5126         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5127      &            +gaussc(1,2,j,it))*expfac
5128         dersc(3)=0.0d0
5129       enddo
5130
5131       dersc(1)=dersc(1)/cos(theti)**2
5132       dersc12=dersc12/cos(theti)**2
5133       escloci=-(dlog(escloc_i)-emin)
5134       do j=1,2
5135         dersc(j)=dersc(j)/escloc_i
5136       enddo
5137       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5138       return
5139       end
5140 #else
5141 c----------------------------------------------------------------------------------
5142       subroutine esc(escloc)
5143 C Calculate the local energy of a side chain and its derivatives in the
5144 C corresponding virtual-bond valence angles THETA and the spherical angles
5145 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5146 C added by Urszula Kozlowska. 07/11/2007
5147 C
5148       implicit real*8 (a-h,o-z)
5149       include 'DIMENSIONS'
5150       include 'COMMON.GEO'
5151       include 'COMMON.LOCAL'
5152       include 'COMMON.VAR'
5153       include 'COMMON.SCROT'
5154       include 'COMMON.INTERACT'
5155       include 'COMMON.DERIV'
5156       include 'COMMON.CHAIN'
5157       include 'COMMON.IOUNITS'
5158       include 'COMMON.NAMES'
5159       include 'COMMON.FFIELD'
5160       include 'COMMON.CONTROL'
5161       include 'COMMON.VECTORS'
5162       double precision x_prime(3),y_prime(3),z_prime(3)
5163      &    , sumene,dsc_i,dp2_i,x(65),
5164      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5165      &    de_dxx,de_dyy,de_dzz,de_dt
5166       double precision s1_t,s1_6_t,s2_t,s2_6_t
5167       double precision
5168      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5169      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5170      & dt_dCi(3),dt_dCi1(3)
5171       common /sccalc/ time11,time12,time112,theti,it,nlobit
5172       delta=0.02d0*pi
5173       escloc=0.0D0
5174       do i=loc_start,loc_end
5175         if (itype(i).eq.ntyp1) cycle
5176         costtab(i+1) =dcos(theta(i+1))
5177         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5178         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5179         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5180         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5181         cosfac=dsqrt(cosfac2)
5182         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5183         sinfac=dsqrt(sinfac2)
5184         it=iabs(itype(i))
5185         if (it.eq.10) goto 1
5186 c
5187 C  Compute the axes of tghe local cartesian coordinates system; store in
5188 c   x_prime, y_prime and z_prime
5189 c
5190         do j=1,3
5191           x_prime(j) = 0.00
5192           y_prime(j) = 0.00
5193           z_prime(j) = 0.00
5194         enddo
5195 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5196 C     &   dc_norm(3,i+nres)
5197         do j = 1,3
5198           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5199           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5200         enddo
5201         do j = 1,3
5202           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5203         enddo
5204 c       write (2,*) "i",i
5205 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5206 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5207 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5208 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5209 c      & " xy",scalar(x_prime(1),y_prime(1)),
5210 c      & " xz",scalar(x_prime(1),z_prime(1)),
5211 c      & " yy",scalar(y_prime(1),y_prime(1)),
5212 c      & " yz",scalar(y_prime(1),z_prime(1)),
5213 c      & " zz",scalar(z_prime(1),z_prime(1))
5214 c
5215 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5216 C to local coordinate system. Store in xx, yy, zz.
5217 c
5218         xx=0.0d0
5219         yy=0.0d0
5220         zz=0.0d0
5221         do j = 1,3
5222           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5223           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5224           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5225         enddo
5226
5227         xxtab(i)=xx
5228         yytab(i)=yy
5229         zztab(i)=zz
5230 C
5231 C Compute the energy of the ith side cbain
5232 C
5233 c        write (2,*) "xx",xx," yy",yy," zz",zz
5234         it=iabs(itype(i))
5235         do j = 1,65
5236           x(j) = sc_parmin(j,it)
5237         enddo
5238 #ifdef CHECK_COORD
5239 Cc diagnostics - remove later
5240         xx1 = dcos(alph(2))
5241         yy1 = dsin(alph(2))*dcos(omeg(2))
5242         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5243         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5244      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5245      &    xx1,yy1,zz1
5246 C,"  --- ", xx_w,yy_w,zz_w
5247 c end diagnostics
5248 #endif
5249         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5250      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5251      &   + x(10)*yy*zz
5252         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5253      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5254      & + x(20)*yy*zz
5255         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5256      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5257      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5258      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5259      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5260      &  +x(40)*xx*yy*zz
5261         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5262      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5263      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5264      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5265      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5266      &  +x(60)*xx*yy*zz
5267         dsc_i   = 0.743d0+x(61)
5268         dp2_i   = 1.9d0+x(62)
5269         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5270      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5271         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5272      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5273         s1=(1+x(63))/(0.1d0 + dscp1)
5274         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5275         s2=(1+x(65))/(0.1d0 + dscp2)
5276         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5277         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5278      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5279 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5280 c     &   sumene4,
5281 c     &   dscp1,dscp2,sumene
5282 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5283         escloc = escloc + sumene
5284 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5285 c     & ,zz,xx,yy
5286 c#define DEBUG
5287 #ifdef DEBUG
5288 C
5289 C This section to check the numerical derivatives of the energy of ith side
5290 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5291 C #define DEBUG in the code to turn it on.
5292 C
5293         write (2,*) "sumene               =",sumene
5294         aincr=1.0d-7
5295         xxsave=xx
5296         xx=xx+aincr
5297         write (2,*) xx,yy,zz
5298         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5299         de_dxx_num=(sumenep-sumene)/aincr
5300         xx=xxsave
5301         write (2,*) "xx+ sumene from enesc=",sumenep
5302         yysave=yy
5303         yy=yy+aincr
5304         write (2,*) xx,yy,zz
5305         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5306         de_dyy_num=(sumenep-sumene)/aincr
5307         yy=yysave
5308         write (2,*) "yy+ sumene from enesc=",sumenep
5309         zzsave=zz
5310         zz=zz+aincr
5311         write (2,*) xx,yy,zz
5312         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5313         de_dzz_num=(sumenep-sumene)/aincr
5314         zz=zzsave
5315         write (2,*) "zz+ sumene from enesc=",sumenep
5316         costsave=cost2tab(i+1)
5317         sintsave=sint2tab(i+1)
5318         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5319         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5320         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5321         de_dt_num=(sumenep-sumene)/aincr
5322         write (2,*) " t+ sumene from enesc=",sumenep
5323         cost2tab(i+1)=costsave
5324         sint2tab(i+1)=sintsave
5325 C End of diagnostics section.
5326 #endif
5327 C
5328 C Compute the gradient of esc
5329 C
5330 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5331         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5332         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5333         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5334         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5335         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5336         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5337         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5338         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5339         pom1=(sumene3*sint2tab(i+1)+sumene1)
5340      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5341         pom2=(sumene4*cost2tab(i+1)+sumene2)
5342      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5343         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5344         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5345      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5346      &  +x(40)*yy*zz
5347         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5348         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5349      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5350      &  +x(60)*yy*zz
5351         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5352      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5353      &        +(pom1+pom2)*pom_dx
5354 #ifdef DEBUG
5355         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5356 #endif
5357 C
5358         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5359         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5360      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5361      &  +x(40)*xx*zz
5362         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5363         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5364      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5365      &  +x(59)*zz**2 +x(60)*xx*zz
5366         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5367      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5368      &        +(pom1-pom2)*pom_dy
5369 #ifdef DEBUG
5370         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5371 #endif
5372 C
5373         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5374      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5375      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5376      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5377      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5378      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5379      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5380      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5381 #ifdef DEBUG
5382         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5383 #endif
5384 C
5385         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5386      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5387      &  +pom1*pom_dt1+pom2*pom_dt2
5388 #ifdef DEBUG
5389         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5390 #endif
5391 c#undef DEBUG
5392 c
5393 C
5394        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5395        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5396        cosfac2xx=cosfac2*xx
5397        sinfac2yy=sinfac2*yy
5398        do k = 1,3
5399          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5400      &      vbld_inv(i+1)
5401          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5402      &      vbld_inv(i)
5403          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5404          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5405 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5406 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5407 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5408 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5409          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5410          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5411          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5412          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5413          dZZ_Ci1(k)=0.0d0
5414          dZZ_Ci(k)=0.0d0
5415          do j=1,3
5416            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5417      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5418            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5419      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5420          enddo
5421
5422          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5423          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5424          dZZ_XYZ(k)=vbld_inv(i+nres)*
5425      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5426 c
5427          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5428          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5429        enddo
5430
5431        do k=1,3
5432          dXX_Ctab(k,i)=dXX_Ci(k)
5433          dXX_C1tab(k,i)=dXX_Ci1(k)
5434          dYY_Ctab(k,i)=dYY_Ci(k)
5435          dYY_C1tab(k,i)=dYY_Ci1(k)
5436          dZZ_Ctab(k,i)=dZZ_Ci(k)
5437          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5438          dXX_XYZtab(k,i)=dXX_XYZ(k)
5439          dYY_XYZtab(k,i)=dYY_XYZ(k)
5440          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5441        enddo
5442
5443        do k = 1,3
5444 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5445 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5446 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5447 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5448 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5449 c     &    dt_dci(k)
5450 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5451 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5452          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5453      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5454          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5455      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5456          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5457      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5458        enddo
5459 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5460 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5461
5462 C to check gradient call subroutine check_grad
5463
5464     1 continue
5465       enddo
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5470       implicit none
5471       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5472      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5473       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5474      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5475      &   + x(10)*yy*zz
5476       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5477      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5478      & + x(20)*yy*zz
5479       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5480      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5481      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5482      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5483      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5484      &  +x(40)*xx*yy*zz
5485       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5486      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5487      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5488      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5489      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5490      &  +x(60)*xx*yy*zz
5491       dsc_i   = 0.743d0+x(61)
5492       dp2_i   = 1.9d0+x(62)
5493       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5494      &          *(xx*cost2+yy*sint2))
5495       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5496      &          *(xx*cost2-yy*sint2))
5497       s1=(1+x(63))/(0.1d0 + dscp1)
5498       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5499       s2=(1+x(65))/(0.1d0 + dscp2)
5500       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5501       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5502      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5503       enesc=sumene
5504       return
5505       end
5506 #endif
5507 c------------------------------------------------------------------------------
5508       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5509 C
5510 C This procedure calculates two-body contact function g(rij) and its derivative:
5511 C
5512 C           eps0ij                                     !       x < -1
5513 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5514 C            0                                         !       x > 1
5515 C
5516 C where x=(rij-r0ij)/delta
5517 C
5518 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5519 C
5520       implicit none
5521       double precision rij,r0ij,eps0ij,fcont,fprimcont
5522       double precision x,x2,x4,delta
5523 c     delta=0.02D0*r0ij
5524 c      delta=0.2D0*r0ij
5525       x=(rij-r0ij)/delta
5526       if (x.lt.-1.0D0) then
5527         fcont=eps0ij
5528         fprimcont=0.0D0
5529       else if (x.le.1.0D0) then
5530         x2=x*x
5531         x4=x2*x2
5532         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5533         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5534       else
5535         fcont=0.0D0
5536         fprimcont=0.0D0
5537       endif
5538       return
5539       end
5540 c------------------------------------------------------------------------------
5541       subroutine splinthet(theti,delta,ss,ssder)
5542       implicit real*8 (a-h,o-z)
5543       include 'DIMENSIONS'
5544       include 'COMMON.VAR'
5545       include 'COMMON.GEO'
5546       thetup=pi-delta
5547       thetlow=delta
5548       if (theti.gt.pipol) then
5549         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5550       else
5551         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5552         ssder=-ssder
5553       endif
5554       return
5555       end
5556 c------------------------------------------------------------------------------
5557       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5558       implicit none
5559       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5560       double precision ksi,ksi2,ksi3,a1,a2,a3
5561       a1=fprim0*delta/(f1-f0)
5562       a2=3.0d0-2.0d0*a1
5563       a3=a1-2.0d0
5564       ksi=(x-x0)/delta
5565       ksi2=ksi*ksi
5566       ksi3=ksi2*ksi
5567       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5568       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5573       implicit none
5574       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5575       double precision ksi,ksi2,ksi3,a1,a2,a3
5576       ksi=(x-x0)/delta
5577       ksi2=ksi*ksi
5578       ksi3=ksi2*ksi
5579       a1=fprim0x*delta
5580       a2=3*(f1x-f0x)-2*fprim0x*delta
5581       a3=fprim0x*delta-2*(f1x-f0x)
5582       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5583       return
5584       end
5585 C-----------------------------------------------------------------------------
5586 #ifdef CRYST_TOR
5587 C-----------------------------------------------------------------------------
5588       subroutine etor(etors,edihcnstr)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.VAR'
5592       include 'COMMON.GEO'
5593       include 'COMMON.LOCAL'
5594       include 'COMMON.TORSION'
5595       include 'COMMON.INTERACT'
5596       include 'COMMON.DERIV'
5597       include 'COMMON.CHAIN'
5598       include 'COMMON.NAMES'
5599       include 'COMMON.IOUNITS'
5600       include 'COMMON.FFIELD'
5601       include 'COMMON.TORCNSTR'
5602       include 'COMMON.CONTROL'
5603       logical lprn
5604 C Set lprn=.true. for debugging
5605       lprn=.false.
5606 c      lprn=.true.
5607       etors=0.0D0
5608       do i=iphi_start,iphi_end
5609       etors_ii=0.0D0
5610         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5611      &      .or. itype(i).eq.ntyp1) cycle
5612         itori=itortyp(itype(i-2))
5613         itori1=itortyp(itype(i-1))
5614         phii=phi(i)
5615         gloci=0.0D0
5616 C Proline-Proline pair is a special case...
5617         if (itori.eq.3 .and. itori1.eq.3) then
5618           if (phii.gt.-dwapi3) then
5619             cosphi=dcos(3*phii)
5620             fac=1.0D0/(1.0D0-cosphi)
5621             etorsi=v1(1,3,3)*fac
5622             etorsi=etorsi+etorsi
5623             etors=etors+etorsi-v1(1,3,3)
5624             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5625             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5626           endif
5627           do j=1,3
5628             v1ij=v1(j+1,itori,itori1)
5629             v2ij=v2(j+1,itori,itori1)
5630             cosphi=dcos(j*phii)
5631             sinphi=dsin(j*phii)
5632             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5633             if (energy_dec) etors_ii=etors_ii+
5634      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5635             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5636           enddo
5637         else
5638           do j=1,nterm_old
5639             v1ij=v1(j,itori,itori1)
5640             v2ij=v2(j,itori,itori1)
5641             cosphi=dcos(j*phii)
5642             sinphi=dsin(j*phii)
5643             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5644             if (energy_dec) etors_ii=etors_ii+
5645      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5646             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5647           enddo
5648         endif
5649         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5650              'etor',i,etors_ii
5651         if (lprn)
5652      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5653      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5654      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5655         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5656 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5657       enddo
5658 ! 6/20/98 - dihedral angle constraints
5659       edihcnstr=0.0d0
5660       do i=1,ndih_constr
5661         itori=idih_constr(i)
5662         phii=phi(itori)
5663         difi=phii-phi0(i)
5664         if (difi.gt.drange(i)) then
5665           difi=difi-drange(i)
5666           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5667           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5668         else if (difi.lt.-drange(i)) then
5669           difi=difi+drange(i)
5670           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5671           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5672         endif
5673 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5674 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5675       enddo
5676 !      write (iout,*) 'edihcnstr',edihcnstr
5677       return
5678       end
5679 c------------------------------------------------------------------------------
5680       subroutine etor_d(etors_d)
5681       etors_d=0.0d0
5682       return
5683       end
5684 c----------------------------------------------------------------------------
5685 #else
5686       subroutine etor(etors,edihcnstr)
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'COMMON.VAR'
5690       include 'COMMON.GEO'
5691       include 'COMMON.LOCAL'
5692       include 'COMMON.TORSION'
5693       include 'COMMON.INTERACT'
5694       include 'COMMON.DERIV'
5695       include 'COMMON.CHAIN'
5696       include 'COMMON.NAMES'
5697       include 'COMMON.IOUNITS'
5698       include 'COMMON.FFIELD'
5699       include 'COMMON.TORCNSTR'
5700       include 'COMMON.CONTROL'
5701       logical lprn
5702 C Set lprn=.true. for debugging
5703       lprn=.false.
5704 c     lprn=.true.
5705       etors=0.0D0
5706       do i=iphi_start,iphi_end
5707         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5708      &       .or. itype(i).eq.ntyp1) cycle
5709         etors_ii=0.0D0
5710          if (iabs(itype(i)).eq.20) then
5711          iblock=2
5712          else
5713          iblock=1
5714          endif
5715         itori=itortyp(itype(i-2))
5716         itori1=itortyp(itype(i-1))
5717         phii=phi(i)
5718         gloci=0.0D0
5719 C Regular cosine and sine terms
5720         do j=1,nterm(itori,itori1,iblock)
5721           v1ij=v1(j,itori,itori1,iblock)
5722           v2ij=v2(j,itori,itori1,iblock)
5723           cosphi=dcos(j*phii)
5724           sinphi=dsin(j*phii)
5725           etors=etors+v1ij*cosphi+v2ij*sinphi
5726           if (energy_dec) etors_ii=etors_ii+
5727      &                v1ij*cosphi+v2ij*sinphi
5728           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5729         enddo
5730 C Lorentz terms
5731 C                         v1
5732 C  E = SUM ----------------------------------- - v1
5733 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5734 C
5735         cosphi=dcos(0.5d0*phii)
5736         sinphi=dsin(0.5d0*phii)
5737         do j=1,nlor(itori,itori1,iblock)
5738           vl1ij=vlor1(j,itori,itori1)
5739           vl2ij=vlor2(j,itori,itori1)
5740           vl3ij=vlor3(j,itori,itori1)
5741           pom=vl2ij*cosphi+vl3ij*sinphi
5742           pom1=1.0d0/(pom*pom+1.0d0)
5743           etors=etors+vl1ij*pom1
5744           if (energy_dec) etors_ii=etors_ii+
5745      &                vl1ij*pom1
5746           pom=-pom*pom1*pom1
5747           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5748         enddo
5749 C Subtract the constant term
5750         etors=etors-v0(itori,itori1,iblock)
5751           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5752      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5753         if (lprn)
5754      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5755      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5756      &  (v1(j,itori,itori1,iblock),j=1,6),
5757      &  (v2(j,itori,itori1,iblock),j=1,6)
5758         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5759 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5760       enddo
5761 ! 6/20/98 - dihedral angle constraints
5762       edihcnstr=0.0d0
5763 c      do i=1,ndih_constr
5764       do i=idihconstr_start,idihconstr_end
5765         itori=idih_constr(i)
5766         phii=phi(itori)
5767         difi=pinorm(phii-phi0(i))
5768         if (difi.gt.drange(i)) then
5769           difi=difi-drange(i)
5770           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5771           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5772         else if (difi.lt.-drange(i)) then
5773           difi=difi+drange(i)
5774           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5775           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5776         else
5777           difi=0.0
5778         endif
5779        if (energy_dec) then
5780         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
5781      &    i,itori,rad2deg*phii,
5782      &    rad2deg*phi0(i),  rad2deg*drange(i),
5783      &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5784         endif
5785       enddo
5786 cd       write (iout,*) 'edihcnstr',edihcnstr
5787       return
5788       end
5789 c----------------------------------------------------------------------------
5790       subroutine etor_d(etors_d)
5791 C 6/23/01 Compute double torsional energy
5792       implicit real*8 (a-h,o-z)
5793       include 'DIMENSIONS'
5794       include 'COMMON.VAR'
5795       include 'COMMON.GEO'
5796       include 'COMMON.LOCAL'
5797       include 'COMMON.TORSION'
5798       include 'COMMON.INTERACT'
5799       include 'COMMON.DERIV'
5800       include 'COMMON.CHAIN'
5801       include 'COMMON.NAMES'
5802       include 'COMMON.IOUNITS'
5803       include 'COMMON.FFIELD'
5804       include 'COMMON.TORCNSTR'
5805       logical lprn
5806 C Set lprn=.true. for debugging
5807       lprn=.false.
5808 c     lprn=.true.
5809       etors_d=0.0D0
5810 c      write(iout,*) "a tu??"
5811       do i=iphid_start,iphid_end
5812         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5813      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5814         itori=itortyp(itype(i-2))
5815         itori1=itortyp(itype(i-1))
5816         itori2=itortyp(itype(i))
5817         phii=phi(i)
5818         phii1=phi(i+1)
5819         gloci1=0.0D0
5820         gloci2=0.0D0
5821         iblock=1
5822         if (iabs(itype(i+1)).eq.20) iblock=2
5823
5824 C Regular cosine and sine terms
5825         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5826           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5827           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5828           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5829           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5830           cosphi1=dcos(j*phii)
5831           sinphi1=dsin(j*phii)
5832           cosphi2=dcos(j*phii1)
5833           sinphi2=dsin(j*phii1)
5834           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5835      &     v2cij*cosphi2+v2sij*sinphi2
5836           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5837           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5838         enddo
5839         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5840           do l=1,k-1
5841             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5842             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5843             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5844             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5845             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5846             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5847             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5848             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5849             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5850      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5851             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5852      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5853             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5854      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5855           enddo
5856         enddo
5857         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5858         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5859       enddo
5860       return
5861       end
5862 #endif
5863 c------------------------------------------------------------------------------
5864       subroutine eback_sc_corr(esccor)
5865 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5866 c        conformational states; temporarily implemented as differences
5867 c        between UNRES torsional potentials (dependent on three types of
5868 c        residues) and the torsional potentials dependent on all 20 types
5869 c        of residues computed from AM1  energy surfaces of terminally-blocked
5870 c        amino-acid residues.
5871       implicit real*8 (a-h,o-z)
5872       include 'DIMENSIONS'
5873       include 'COMMON.VAR'
5874       include 'COMMON.GEO'
5875       include 'COMMON.LOCAL'
5876       include 'COMMON.TORSION'
5877       include 'COMMON.SCCOR'
5878       include 'COMMON.INTERACT'
5879       include 'COMMON.DERIV'
5880       include 'COMMON.CHAIN'
5881       include 'COMMON.NAMES'
5882       include 'COMMON.IOUNITS'
5883       include 'COMMON.FFIELD'
5884       include 'COMMON.CONTROL'
5885       logical lprn
5886 C Set lprn=.true. for debugging
5887       lprn=.false.
5888 c      lprn=.true.
5889 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5890       esccor=0.0D0
5891       do i=itau_start,itau_end
5892         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5893         esccor_ii=0.0D0
5894         isccori=isccortyp(itype(i-2))
5895         isccori1=isccortyp(itype(i-1))
5896 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5897         phii=phi(i)
5898         do intertyp=1,3 !intertyp
5899 cc Added 09 May 2012 (Adasko)
5900 cc  Intertyp means interaction type of backbone mainchain correlation:
5901 c   1 = SC...Ca...Ca...Ca
5902 c   2 = Ca...Ca...Ca...SC
5903 c   3 = SC...Ca...Ca...SCi
5904         gloci=0.0D0
5905         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5906      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5907      &      (itype(i-1).eq.ntyp1)))
5908      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5909      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5910      &     .or.(itype(i).eq.ntyp1)))
5911      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5912      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5913      &      (itype(i-3).eq.ntyp1)))) cycle
5914         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5915         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5916      & cycle
5917        do j=1,nterm_sccor(isccori,isccori1)
5918           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5919           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5920           cosphi=dcos(j*tauangle(intertyp,i))
5921           sinphi=dsin(j*tauangle(intertyp,i))
5922           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5923           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5924         enddo
5925 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5926         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5927         if (lprn)
5928      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5929      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5930      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5931      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5932         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5933        enddo !intertyp
5934       enddo
5935
5936       return
5937       end
5938 c----------------------------------------------------------------------------
5939       subroutine multibody(ecorr)
5940 C This subroutine calculates multi-body contributions to energy following
5941 C the idea of Skolnick et al. If side chains I and J make a contact and
5942 C at the same time side chains I+1 and J+1 make a contact, an extra
5943 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'COMMON.IOUNITS'
5947       include 'COMMON.DERIV'
5948       include 'COMMON.INTERACT'
5949       include 'COMMON.CONTACTS'
5950       double precision gx(3),gx1(3)
5951       logical lprn
5952
5953 C Set lprn=.true. for debugging
5954       lprn=.false.
5955
5956       if (lprn) then
5957         write (iout,'(a)') 'Contact function values:'
5958         do i=nnt,nct-2
5959           write (iout,'(i2,20(1x,i2,f10.5))')
5960      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5961         enddo
5962       endif
5963       ecorr=0.0D0
5964       do i=nnt,nct
5965         do j=1,3
5966           gradcorr(j,i)=0.0D0
5967           gradxorr(j,i)=0.0D0
5968         enddo
5969       enddo
5970       do i=nnt,nct-2
5971
5972         DO ISHIFT = 3,4
5973
5974         i1=i+ishift
5975         num_conti=num_cont(i)
5976         num_conti1=num_cont(i1)
5977         do jj=1,num_conti
5978           j=jcont(jj,i)
5979           do kk=1,num_conti1
5980             j1=jcont(kk,i1)
5981             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5982 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5983 cd   &                   ' ishift=',ishift
5984 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5985 C The system gains extra energy.
5986               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5987             endif   ! j1==j+-ishift
5988           enddo     ! kk
5989         enddo       ! jj
5990
5991         ENDDO ! ISHIFT
5992
5993       enddo         ! i
5994       return
5995       end
5996 c------------------------------------------------------------------------------
5997       double precision function esccorr(i,j,k,l,jj,kk)
5998       implicit real*8 (a-h,o-z)
5999       include 'DIMENSIONS'
6000       include 'COMMON.IOUNITS'
6001       include 'COMMON.DERIV'
6002       include 'COMMON.INTERACT'
6003       include 'COMMON.CONTACTS'
6004       double precision gx(3),gx1(3)
6005       logical lprn
6006       lprn=.false.
6007       eij=facont(jj,i)
6008       ekl=facont(kk,k)
6009 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6010 C Calculate the multi-body contribution to energy.
6011 C Calculate multi-body contributions to the gradient.
6012 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6013 cd   & k,l,(gacont(m,kk,k),m=1,3)
6014       do m=1,3
6015         gx(m) =ekl*gacont(m,jj,i)
6016         gx1(m)=eij*gacont(m,kk,k)
6017         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6018         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6019         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6020         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6021       enddo
6022       do m=i,j-1
6023         do ll=1,3
6024           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6025         enddo
6026       enddo
6027       do m=k,l-1
6028         do ll=1,3
6029           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6030         enddo
6031       enddo
6032       esccorr=-eij*ekl
6033       return
6034       end
6035 c------------------------------------------------------------------------------
6036       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6037 C This subroutine calculates multi-body contributions to hydrogen-bonding
6038       implicit real*8 (a-h,o-z)
6039       include 'DIMENSIONS'
6040       include 'COMMON.IOUNITS'
6041 #ifdef MPI
6042       include "mpif.h"
6043       parameter (max_cont=maxconts)
6044       parameter (max_dim=26)
6045       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6046       double precision zapas(max_dim,maxconts,max_fg_procs),
6047      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6048       common /przechowalnia/ zapas
6049       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6050      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6051 #endif
6052       include 'COMMON.SETUP'
6053       include 'COMMON.FFIELD'
6054       include 'COMMON.DERIV'
6055       include 'COMMON.INTERACT'
6056       include 'COMMON.CONTACTS'
6057       include 'COMMON.CONTROL'
6058       include 'COMMON.LOCAL'
6059       double precision gx(3),gx1(3),time00
6060       logical lprn,ldone
6061
6062 C Set lprn=.true. for debugging
6063       lprn=.false.
6064 #ifdef MPI
6065       n_corr=0
6066       n_corr1=0
6067       if (nfgtasks.le.1) goto 30
6068       if (lprn) then
6069         write (iout,'(a)') 'Contact function values before RECEIVE:'
6070         do i=nnt,nct-2
6071           write (iout,'(2i3,50(1x,i2,f5.2))')
6072      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6073      &    j=1,num_cont_hb(i))
6074         enddo
6075       endif
6076       call flush(iout)
6077       do i=1,ntask_cont_from
6078         ncont_recv(i)=0
6079       enddo
6080       do i=1,ntask_cont_to
6081         ncont_sent(i)=0
6082       enddo
6083 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6084 c     & ntask_cont_to
6085 C Make the list of contacts to send to send to other procesors
6086 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6087 c      call flush(iout)
6088       do i=iturn3_start,iturn3_end
6089 c        write (iout,*) "make contact list turn3",i," num_cont",
6090 c     &    num_cont_hb(i)
6091         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6092       enddo
6093       do i=iturn4_start,iturn4_end
6094 c        write (iout,*) "make contact list turn4",i," num_cont",
6095 c     &   num_cont_hb(i)
6096         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6097       enddo
6098       do ii=1,nat_sent
6099         i=iat_sent(ii)
6100 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6101 c     &    num_cont_hb(i)
6102         do j=1,num_cont_hb(i)
6103         do k=1,4
6104           jjc=jcont_hb(j,i)
6105           iproc=iint_sent_local(k,jjc,ii)
6106 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6107           if (iproc.gt.0) then
6108             ncont_sent(iproc)=ncont_sent(iproc)+1
6109             nn=ncont_sent(iproc)
6110             zapas(1,nn,iproc)=i
6111             zapas(2,nn,iproc)=jjc
6112             zapas(3,nn,iproc)=facont_hb(j,i)
6113             zapas(4,nn,iproc)=ees0p(j,i)
6114             zapas(5,nn,iproc)=ees0m(j,i)
6115             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6116             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6117             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6118             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6119             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6120             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6121             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6122             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6123             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6124             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6125             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6126             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6127             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6128             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6129             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6130             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6131             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6132             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6133             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6134             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6135             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6136           endif
6137         enddo
6138         enddo
6139       enddo
6140       if (lprn) then
6141       write (iout,*)
6142      &  "Numbers of contacts to be sent to other processors",
6143      &  (ncont_sent(i),i=1,ntask_cont_to)
6144       write (iout,*) "Contacts sent"
6145       do ii=1,ntask_cont_to
6146         nn=ncont_sent(ii)
6147         iproc=itask_cont_to(ii)
6148         write (iout,*) nn," contacts to processor",iproc,
6149      &   " of CONT_TO_COMM group"
6150         do i=1,nn
6151           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6152         enddo
6153       enddo
6154       call flush(iout)
6155       endif
6156       CorrelType=477
6157       CorrelID=fg_rank+1
6158       CorrelType1=478
6159       CorrelID1=nfgtasks+fg_rank+1
6160       ireq=0
6161 C Receive the numbers of needed contacts from other processors
6162       do ii=1,ntask_cont_from
6163         iproc=itask_cont_from(ii)
6164         ireq=ireq+1
6165         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6166      &    FG_COMM,req(ireq),IERR)
6167       enddo
6168 c      write (iout,*) "IRECV ended"
6169 c      call flush(iout)
6170 C Send the number of contacts needed by other processors
6171       do ii=1,ntask_cont_to
6172         iproc=itask_cont_to(ii)
6173         ireq=ireq+1
6174         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6175      &    FG_COMM,req(ireq),IERR)
6176       enddo
6177 c      write (iout,*) "ISEND ended"
6178 c      write (iout,*) "number of requests (nn)",ireq
6179       call flush(iout)
6180       if (ireq.gt.0)
6181      &  call MPI_Waitall(ireq,req,status_array,ierr)
6182 c      write (iout,*)
6183 c     &  "Numbers of contacts to be received from other processors",
6184 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6185 c      call flush(iout)
6186 C Receive contacts
6187       ireq=0
6188       do ii=1,ntask_cont_from
6189         iproc=itask_cont_from(ii)
6190         nn=ncont_recv(ii)
6191 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6192 c     &   " of CONT_TO_COMM group"
6193         call flush(iout)
6194         if (nn.gt.0) then
6195           ireq=ireq+1
6196           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6197      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6198 c          write (iout,*) "ireq,req",ireq,req(ireq)
6199         endif
6200       enddo
6201 C Send the contacts to processors that need them
6202       do ii=1,ntask_cont_to
6203         iproc=itask_cont_to(ii)
6204         nn=ncont_sent(ii)
6205 c        write (iout,*) nn," contacts to processor",iproc,
6206 c     &   " of CONT_TO_COMM group"
6207         if (nn.gt.0) then
6208           ireq=ireq+1
6209           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6210      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6211 c          write (iout,*) "ireq,req",ireq,req(ireq)
6212 c          do i=1,nn
6213 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6214 c          enddo
6215         endif
6216       enddo
6217 c      write (iout,*) "number of requests (contacts)",ireq
6218 c      write (iout,*) "req",(req(i),i=1,4)
6219 c      call flush(iout)
6220       if (ireq.gt.0)
6221      & call MPI_Waitall(ireq,req,status_array,ierr)
6222       do iii=1,ntask_cont_from
6223         iproc=itask_cont_from(iii)
6224         nn=ncont_recv(iii)
6225         if (lprn) then
6226         write (iout,*) "Received",nn," contacts from processor",iproc,
6227      &   " of CONT_FROM_COMM group"
6228         call flush(iout)
6229         do i=1,nn
6230           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6231         enddo
6232         call flush(iout)
6233         endif
6234         do i=1,nn
6235           ii=zapas_recv(1,i,iii)
6236 c Flag the received contacts to prevent double-counting
6237           jj=-zapas_recv(2,i,iii)
6238 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6239 c          call flush(iout)
6240           nnn=num_cont_hb(ii)+1
6241           num_cont_hb(ii)=nnn
6242           jcont_hb(nnn,ii)=jj
6243           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6244           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6245           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6246           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6247           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6248           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6249           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6250           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6251           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6252           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6253           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6254           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6255           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6256           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6257           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6258           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6259           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6260           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6261           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6262           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6263           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6264           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6265           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6266           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6267         enddo
6268       enddo
6269       call flush(iout)
6270       if (lprn) then
6271         write (iout,'(a)') 'Contact function values after receive:'
6272         do i=nnt,nct-2
6273           write (iout,'(2i3,50(1x,i3,f5.2))')
6274      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6275      &    j=1,num_cont_hb(i))
6276         enddo
6277         call flush(iout)
6278       endif
6279    30 continue
6280 #endif
6281       if (lprn) then
6282         write (iout,'(a)') 'Contact function values:'
6283         do i=nnt,nct-2
6284           write (iout,'(2i3,50(1x,i3,f5.2))')
6285      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6286      &    j=1,num_cont_hb(i))
6287         enddo
6288       endif
6289       ecorr=0.0D0
6290 C Remove the loop below after debugging !!!
6291       do i=nnt,nct
6292         do j=1,3
6293           gradcorr(j,i)=0.0D0
6294           gradxorr(j,i)=0.0D0
6295         enddo
6296       enddo
6297 C Calculate the local-electrostatic correlation terms
6298       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6299         i1=i+1
6300         num_conti=num_cont_hb(i)
6301         num_conti1=num_cont_hb(i+1)
6302         do jj=1,num_conti
6303           j=jcont_hb(jj,i)
6304           jp=iabs(j)
6305           do kk=1,num_conti1
6306             j1=jcont_hb(kk,i1)
6307             jp1=iabs(j1)
6308 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6309 c     &         ' jj=',jj,' kk=',kk
6310             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6311      &          .or. j.lt.0 .and. j1.gt.0) .and.
6312      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6313 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6314 C The system gains extra energy.
6315               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6316               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6317      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6318               n_corr=n_corr+1
6319             else if (j1.eq.j) then
6320 C Contacts I-J and I-(J+1) occur simultaneously.
6321 C The system loses extra energy.
6322 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6323             endif
6324           enddo ! kk
6325           do kk=1,num_conti
6326             j1=jcont_hb(kk,i)
6327 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6328 c    &         ' jj=',jj,' kk=',kk
6329             if (j1.eq.j+1) then
6330 C Contacts I-J and (I+1)-J occur simultaneously.
6331 C The system loses extra energy.
6332 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6333             endif ! j1==j+1
6334           enddo ! kk
6335         enddo ! jj
6336       enddo ! i
6337       return
6338       end
6339 c------------------------------------------------------------------------------
6340       subroutine add_hb_contact(ii,jj,itask)
6341       implicit real*8 (a-h,o-z)
6342       include "DIMENSIONS"
6343       include "COMMON.IOUNITS"
6344       integer max_cont
6345       integer max_dim
6346       parameter (max_cont=maxconts)
6347       parameter (max_dim=26)
6348       include "COMMON.CONTACTS"
6349       double precision zapas(max_dim,maxconts,max_fg_procs),
6350      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6351       common /przechowalnia/ zapas
6352       integer i,j,ii,jj,iproc,itask(4),nn
6353 c      write (iout,*) "itask",itask
6354       do i=1,2
6355         iproc=itask(i)
6356         if (iproc.gt.0) then
6357           do j=1,num_cont_hb(ii)
6358             jjc=jcont_hb(j,ii)
6359 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6360             if (jjc.eq.jj) then
6361               ncont_sent(iproc)=ncont_sent(iproc)+1
6362               nn=ncont_sent(iproc)
6363               zapas(1,nn,iproc)=ii
6364               zapas(2,nn,iproc)=jjc
6365               zapas(3,nn,iproc)=facont_hb(j,ii)
6366               zapas(4,nn,iproc)=ees0p(j,ii)
6367               zapas(5,nn,iproc)=ees0m(j,ii)
6368               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6369               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6370               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6371               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6372               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6373               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6374               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6375               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6376               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6377               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6378               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6379               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6380               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6381               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6382               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6383               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6384               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6385               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6386               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6387               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6388               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6389               exit
6390             endif
6391           enddo
6392         endif
6393       enddo
6394       return
6395       end
6396 c------------------------------------------------------------------------------
6397       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6398      &  n_corr1)
6399 C This subroutine calculates multi-body contributions to hydrogen-bonding
6400       implicit real*8 (a-h,o-z)
6401       include 'DIMENSIONS'
6402       include 'COMMON.IOUNITS'
6403 #ifdef MPI
6404       include "mpif.h"
6405       parameter (max_cont=maxconts)
6406       parameter (max_dim=70)
6407       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6408       double precision zapas(max_dim,maxconts,max_fg_procs),
6409      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6410       common /przechowalnia/ zapas
6411       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6412      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6413 #endif
6414       include 'COMMON.SETUP'
6415       include 'COMMON.FFIELD'
6416       include 'COMMON.DERIV'
6417       include 'COMMON.LOCAL'
6418       include 'COMMON.INTERACT'
6419       include 'COMMON.CONTACTS'
6420       include 'COMMON.CHAIN'
6421       include 'COMMON.CONTROL'
6422       double precision gx(3),gx1(3)
6423       integer num_cont_hb_old(maxres)
6424       logical lprn,ldone
6425       double precision eello4,eello5,eelo6,eello_turn6
6426       external eello4,eello5,eello6,eello_turn6
6427 C Set lprn=.true. for debugging
6428       lprn=.false.
6429       eturn6=0.0d0
6430 #ifdef MPI
6431       do i=1,nres
6432         num_cont_hb_old(i)=num_cont_hb(i)
6433       enddo
6434       n_corr=0
6435       n_corr1=0
6436       if (nfgtasks.le.1) goto 30
6437       if (lprn) then
6438         write (iout,'(a)') 'Contact function values before RECEIVE:'
6439         do i=nnt,nct-2
6440           write (iout,'(2i3,50(1x,i2,f5.2))')
6441      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6442      &    j=1,num_cont_hb(i))
6443         enddo
6444       endif
6445       call flush(iout)
6446       do i=1,ntask_cont_from
6447         ncont_recv(i)=0
6448       enddo
6449       do i=1,ntask_cont_to
6450         ncont_sent(i)=0
6451       enddo
6452 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6453 c     & ntask_cont_to
6454 C Make the list of contacts to send to send to other procesors
6455       do i=iturn3_start,iturn3_end
6456 c        write (iout,*) "make contact list turn3",i," num_cont",
6457 c     &    num_cont_hb(i)
6458         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6459       enddo
6460       do i=iturn4_start,iturn4_end
6461 c        write (iout,*) "make contact list turn4",i," num_cont",
6462 c     &   num_cont_hb(i)
6463         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6464       enddo
6465       do ii=1,nat_sent
6466         i=iat_sent(ii)
6467 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6468 c     &    num_cont_hb(i)
6469         do j=1,num_cont_hb(i)
6470         do k=1,4
6471           jjc=jcont_hb(j,i)
6472           iproc=iint_sent_local(k,jjc,ii)
6473 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6474           if (iproc.ne.0) then
6475             ncont_sent(iproc)=ncont_sent(iproc)+1
6476             nn=ncont_sent(iproc)
6477             zapas(1,nn,iproc)=i
6478             zapas(2,nn,iproc)=jjc
6479             zapas(3,nn,iproc)=d_cont(j,i)
6480             ind=3
6481             do kk=1,3
6482               ind=ind+1
6483               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6484             enddo
6485             do kk=1,2
6486               do ll=1,2
6487                 ind=ind+1
6488                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6489               enddo
6490             enddo
6491             do jj=1,5
6492               do kk=1,3
6493                 do ll=1,2
6494                   do mm=1,2
6495                     ind=ind+1
6496                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6497                   enddo
6498                 enddo
6499               enddo
6500             enddo
6501           endif
6502         enddo
6503         enddo
6504       enddo
6505       if (lprn) then
6506       write (iout,*)
6507      &  "Numbers of contacts to be sent to other processors",
6508      &  (ncont_sent(i),i=1,ntask_cont_to)
6509       write (iout,*) "Contacts sent"
6510       do ii=1,ntask_cont_to
6511         nn=ncont_sent(ii)
6512         iproc=itask_cont_to(ii)
6513         write (iout,*) nn," contacts to processor",iproc,
6514      &   " of CONT_TO_COMM group"
6515         do i=1,nn
6516           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6517         enddo
6518       enddo
6519       call flush(iout)
6520       endif
6521       CorrelType=477
6522       CorrelID=fg_rank+1
6523       CorrelType1=478
6524       CorrelID1=nfgtasks+fg_rank+1
6525       ireq=0
6526 C Receive the numbers of needed contacts from other processors
6527       do ii=1,ntask_cont_from
6528         iproc=itask_cont_from(ii)
6529         ireq=ireq+1
6530         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6531      &    FG_COMM,req(ireq),IERR)
6532       enddo
6533 c      write (iout,*) "IRECV ended"
6534 c      call flush(iout)
6535 C Send the number of contacts needed by other processors
6536       do ii=1,ntask_cont_to
6537         iproc=itask_cont_to(ii)
6538         ireq=ireq+1
6539         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6540      &    FG_COMM,req(ireq),IERR)
6541       enddo
6542 c      write (iout,*) "ISEND ended"
6543 c      write (iout,*) "number of requests (nn)",ireq
6544       call flush(iout)
6545       if (ireq.gt.0)
6546      &  call MPI_Waitall(ireq,req,status_array,ierr)
6547 c      write (iout,*)
6548 c     &  "Numbers of contacts to be received from other processors",
6549 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6550 c      call flush(iout)
6551 C Receive contacts
6552       ireq=0
6553       do ii=1,ntask_cont_from
6554         iproc=itask_cont_from(ii)
6555         nn=ncont_recv(ii)
6556 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6557 c     &   " of CONT_TO_COMM group"
6558         call flush(iout)
6559         if (nn.gt.0) then
6560           ireq=ireq+1
6561           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6562      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6563 c          write (iout,*) "ireq,req",ireq,req(ireq)
6564         endif
6565       enddo
6566 C Send the contacts to processors that need them
6567       do ii=1,ntask_cont_to
6568         iproc=itask_cont_to(ii)
6569         nn=ncont_sent(ii)
6570 c        write (iout,*) nn," contacts to processor",iproc,
6571 c     &   " of CONT_TO_COMM group"
6572         if (nn.gt.0) then
6573           ireq=ireq+1
6574           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6575      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6576 c          write (iout,*) "ireq,req",ireq,req(ireq)
6577 c          do i=1,nn
6578 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6579 c          enddo
6580         endif
6581       enddo
6582 c      write (iout,*) "number of requests (contacts)",ireq
6583 c      write (iout,*) "req",(req(i),i=1,4)
6584 c      call flush(iout)
6585       if (ireq.gt.0)
6586      & call MPI_Waitall(ireq,req,status_array,ierr)
6587       do iii=1,ntask_cont_from
6588         iproc=itask_cont_from(iii)
6589         nn=ncont_recv(iii)
6590         if (lprn) then
6591         write (iout,*) "Received",nn," contacts from processor",iproc,
6592      &   " of CONT_FROM_COMM group"
6593         call flush(iout)
6594         do i=1,nn
6595           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6596         enddo
6597         call flush(iout)
6598         endif
6599         do i=1,nn
6600           ii=zapas_recv(1,i,iii)
6601 c Flag the received contacts to prevent double-counting
6602           jj=-zapas_recv(2,i,iii)
6603 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6604 c          call flush(iout)
6605           nnn=num_cont_hb(ii)+1
6606           num_cont_hb(ii)=nnn
6607           jcont_hb(nnn,ii)=jj
6608           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6609           ind=3
6610           do kk=1,3
6611             ind=ind+1
6612             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6613           enddo
6614           do kk=1,2
6615             do ll=1,2
6616               ind=ind+1
6617               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6618             enddo
6619           enddo
6620           do jj=1,5
6621             do kk=1,3
6622               do ll=1,2
6623                 do mm=1,2
6624                   ind=ind+1
6625                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6626                 enddo
6627               enddo
6628             enddo
6629           enddo
6630         enddo
6631       enddo
6632       call flush(iout)
6633       if (lprn) then
6634         write (iout,'(a)') 'Contact function values after receive:'
6635         do i=nnt,nct-2
6636           write (iout,'(2i3,50(1x,i3,5f6.3))')
6637      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6638      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6639         enddo
6640         call flush(iout)
6641       endif
6642    30 continue
6643 #endif
6644       if (lprn) then
6645         write (iout,'(a)') 'Contact function values:'
6646         do i=nnt,nct-2
6647           write (iout,'(2i3,50(1x,i2,5f6.3))')
6648      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6649      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6650         enddo
6651       endif
6652       ecorr=0.0D0
6653       ecorr5=0.0d0
6654       ecorr6=0.0d0
6655 C Remove the loop below after debugging !!!
6656       do i=nnt,nct
6657         do j=1,3
6658           gradcorr(j,i)=0.0D0
6659           gradxorr(j,i)=0.0D0
6660         enddo
6661       enddo
6662 C Calculate the dipole-dipole interaction energies
6663       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6664       do i=iatel_s,iatel_e+1
6665         num_conti=num_cont_hb(i)
6666         do jj=1,num_conti
6667           j=jcont_hb(jj,i)
6668 #ifdef MOMENT
6669           call dipole(i,j,jj)
6670 #endif
6671         enddo
6672       enddo
6673       endif
6674 C Calculate the local-electrostatic correlation terms
6675 c                write (iout,*) "gradcorr5 in eello5 before loop"
6676 c                do iii=1,nres
6677 c                  write (iout,'(i5,3f10.5)')
6678 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6679 c                enddo
6680       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6681 c        write (iout,*) "corr loop i",i
6682         i1=i+1
6683         num_conti=num_cont_hb(i)
6684         num_conti1=num_cont_hb(i+1)
6685         do jj=1,num_conti
6686           j=jcont_hb(jj,i)
6687           jp=iabs(j)
6688           do kk=1,num_conti1
6689             j1=jcont_hb(kk,i1)
6690             jp1=iabs(j1)
6691 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6692 c     &         ' jj=',jj,' kk=',kk
6693 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6694             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6695      &          .or. j.lt.0 .and. j1.gt.0) .and.
6696      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6697 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6698 C The system gains extra energy.
6699               n_corr=n_corr+1
6700               sqd1=dsqrt(d_cont(jj,i))
6701               sqd2=dsqrt(d_cont(kk,i1))
6702               sred_geom = sqd1*sqd2
6703               IF (sred_geom.lt.cutoff_corr) THEN
6704                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6705      &            ekont,fprimcont)
6706 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6707 cd     &         ' jj=',jj,' kk=',kk
6708                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6709                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6710                 do l=1,3
6711                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6712                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6713                 enddo
6714                 n_corr1=n_corr1+1
6715 cd               write (iout,*) 'sred_geom=',sred_geom,
6716 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6717 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6718 cd               write (iout,*) "g_contij",g_contij
6719 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6720 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6721                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6722                 if (wcorr4.gt.0.0d0)
6723      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6724                   if (energy_dec.and.wcorr4.gt.0.0d0)
6725      1                 write (iout,'(a6,4i5,0pf7.3)')
6726      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6727 c                write (iout,*) "gradcorr5 before eello5"
6728 c                do iii=1,nres
6729 c                  write (iout,'(i5,3f10.5)')
6730 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6731 c                enddo
6732                 if (wcorr5.gt.0.0d0)
6733      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6734 c                write (iout,*) "gradcorr5 after eello5"
6735 c                do iii=1,nres
6736 c                  write (iout,'(i5,3f10.5)')
6737 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6738 c                enddo
6739                   if (energy_dec.and.wcorr5.gt.0.0d0)
6740      1                 write (iout,'(a6,4i5,0pf7.3)')
6741      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6742 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6743 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6744                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6745      &               .or. wturn6.eq.0.0d0))then
6746 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6747                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6748                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6749      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6750 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6751 cd     &            'ecorr6=',ecorr6
6752 cd                write (iout,'(4e15.5)') sred_geom,
6753 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6754 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6755 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6756                 else if (wturn6.gt.0.0d0
6757      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6758 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6759                   eturn6=eturn6+eello_turn6(i,jj,kk)
6760                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6761      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6762 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6763                 endif
6764               ENDIF
6765 1111          continue
6766             endif
6767           enddo ! kk
6768         enddo ! jj
6769       enddo ! i
6770       do i=1,nres
6771         num_cont_hb(i)=num_cont_hb_old(i)
6772       enddo
6773 c                write (iout,*) "gradcorr5 in eello5"
6774 c                do iii=1,nres
6775 c                  write (iout,'(i5,3f10.5)')
6776 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6777 c                enddo
6778       return
6779       end
6780 c------------------------------------------------------------------------------
6781       subroutine add_hb_contact_eello(ii,jj,itask)
6782       implicit real*8 (a-h,o-z)
6783       include "DIMENSIONS"
6784       include "COMMON.IOUNITS"
6785       integer max_cont
6786       integer max_dim
6787       parameter (max_cont=maxconts)
6788       parameter (max_dim=70)
6789       include "COMMON.CONTACTS"
6790       double precision zapas(max_dim,maxconts,max_fg_procs),
6791      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6792       common /przechowalnia/ zapas
6793       integer i,j,ii,jj,iproc,itask(4),nn
6794 c      write (iout,*) "itask",itask
6795       do i=1,2
6796         iproc=itask(i)
6797         if (iproc.gt.0) then
6798           do j=1,num_cont_hb(ii)
6799             jjc=jcont_hb(j,ii)
6800 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6801             if (jjc.eq.jj) then
6802               ncont_sent(iproc)=ncont_sent(iproc)+1
6803               nn=ncont_sent(iproc)
6804               zapas(1,nn,iproc)=ii
6805               zapas(2,nn,iproc)=jjc
6806               zapas(3,nn,iproc)=d_cont(j,ii)
6807               ind=3
6808               do kk=1,3
6809                 ind=ind+1
6810                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6811               enddo
6812               do kk=1,2
6813                 do ll=1,2
6814                   ind=ind+1
6815                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6816                 enddo
6817               enddo
6818               do jj=1,5
6819                 do kk=1,3
6820                   do ll=1,2
6821                     do mm=1,2
6822                       ind=ind+1
6823                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6824                     enddo
6825                   enddo
6826                 enddo
6827               enddo
6828               exit
6829             endif
6830           enddo
6831         endif
6832       enddo
6833       return
6834       end
6835 c------------------------------------------------------------------------------
6836       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6837       implicit real*8 (a-h,o-z)
6838       include 'DIMENSIONS'
6839       include 'COMMON.IOUNITS'
6840       include 'COMMON.DERIV'
6841       include 'COMMON.INTERACT'
6842       include 'COMMON.CONTACTS'
6843       double precision gx(3),gx1(3)
6844       logical lprn
6845       lprn=.false.
6846       eij=facont_hb(jj,i)
6847       ekl=facont_hb(kk,k)
6848       ees0pij=ees0p(jj,i)
6849       ees0pkl=ees0p(kk,k)
6850       ees0mij=ees0m(jj,i)
6851       ees0mkl=ees0m(kk,k)
6852       ekont=eij*ekl
6853       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6854 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6855 C Following 4 lines for diagnostics.
6856 cd    ees0pkl=0.0D0
6857 cd    ees0pij=1.0D0
6858 cd    ees0mkl=0.0D0
6859 cd    ees0mij=1.0D0
6860 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6861 c     & 'Contacts ',i,j,
6862 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6863 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6864 c     & 'gradcorr_long'
6865 C Calculate the multi-body contribution to energy.
6866 c      ecorr=ecorr+ekont*ees
6867 C Calculate multi-body contributions to the gradient.
6868       coeffpees0pij=coeffp*ees0pij
6869       coeffmees0mij=coeffm*ees0mij
6870       coeffpees0pkl=coeffp*ees0pkl
6871       coeffmees0mkl=coeffm*ees0mkl
6872       do ll=1,3
6873 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6874         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6875      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6876      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6877         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6878      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6879      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6880 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6881         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6882      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6883      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6884         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6885      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6886      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6887         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6888      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6889      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6890         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6891         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6892         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6893      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6894      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6895         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6896         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6897 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6898       enddo
6899 c      write (iout,*)
6900 cgrad      do m=i+1,j-1
6901 cgrad        do ll=1,3
6902 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6903 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6904 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6905 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6906 cgrad        enddo
6907 cgrad      enddo
6908 cgrad      do m=k+1,l-1
6909 cgrad        do ll=1,3
6910 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6911 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6912 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6913 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6914 cgrad        enddo
6915 cgrad      enddo
6916 c      write (iout,*) "ehbcorr",ekont*ees
6917       ehbcorr=ekont*ees
6918       return
6919       end
6920 #ifdef MOMENT
6921 C---------------------------------------------------------------------------
6922       subroutine dipole(i,j,jj)
6923       implicit real*8 (a-h,o-z)
6924       include 'DIMENSIONS'
6925       include 'COMMON.IOUNITS'
6926       include 'COMMON.CHAIN'
6927       include 'COMMON.FFIELD'
6928       include 'COMMON.DERIV'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.CONTACTS'
6931       include 'COMMON.TORSION'
6932       include 'COMMON.VAR'
6933       include 'COMMON.GEO'
6934       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6935      &  auxmat(2,2)
6936       iti1 = itortyp(itype(i+1))
6937       if (j.lt.nres-1) then
6938         itj1 = itortyp(itype(j+1))
6939       else
6940         itj1=ntortyp+1
6941       endif
6942       do iii=1,2
6943         dipi(iii,1)=Ub2(iii,i)
6944         dipderi(iii)=Ub2der(iii,i)
6945         dipi(iii,2)=b1(iii,iti1)
6946         dipj(iii,1)=Ub2(iii,j)
6947         dipderj(iii)=Ub2der(iii,j)
6948         dipj(iii,2)=b1(iii,itj1)
6949       enddo
6950       kkk=0
6951       do iii=1,2
6952         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6953         do jjj=1,2
6954           kkk=kkk+1
6955           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6956         enddo
6957       enddo
6958       do kkk=1,5
6959         do lll=1,3
6960           mmm=0
6961           do iii=1,2
6962             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6963      &        auxvec(1))
6964             do jjj=1,2
6965               mmm=mmm+1
6966               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6967             enddo
6968           enddo
6969         enddo
6970       enddo
6971       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6972       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6973       do iii=1,2
6974         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6975       enddo
6976       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6977       do iii=1,2
6978         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6979       enddo
6980       return
6981       end
6982 #endif
6983 C---------------------------------------------------------------------------
6984       subroutine calc_eello(i,j,k,l,jj,kk)
6985 C
6986 C This subroutine computes matrices and vectors needed to calculate
6987 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6988 C
6989       implicit real*8 (a-h,o-z)
6990       include 'DIMENSIONS'
6991       include 'COMMON.IOUNITS'
6992       include 'COMMON.CHAIN'
6993       include 'COMMON.DERIV'
6994       include 'COMMON.INTERACT'
6995       include 'COMMON.CONTACTS'
6996       include 'COMMON.TORSION'
6997       include 'COMMON.VAR'
6998       include 'COMMON.GEO'
6999       include 'COMMON.FFIELD'
7000       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7001      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7002       logical lprn
7003       common /kutas/ lprn
7004 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7005 cd     & ' jj=',jj,' kk=',kk
7006 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7007 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7008 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7009       do iii=1,2
7010         do jjj=1,2
7011           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7012           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7013         enddo
7014       enddo
7015       call transpose2(aa1(1,1),aa1t(1,1))
7016       call transpose2(aa2(1,1),aa2t(1,1))
7017       do kkk=1,5
7018         do lll=1,3
7019           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7020      &      aa1tder(1,1,lll,kkk))
7021           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7022      &      aa2tder(1,1,lll,kkk))
7023         enddo
7024       enddo
7025       if (l.eq.j+1) then
7026 C parallel orientation of the two CA-CA-CA frames.
7027         if (i.gt.1) then
7028           iti=itortyp(itype(i))
7029         else
7030           iti=ntortyp+1
7031         endif
7032         itk1=itortyp(itype(k+1))
7033         itj=itortyp(itype(j))
7034         if (l.lt.nres-1) then
7035           itl1=itortyp(itype(l+1))
7036         else
7037           itl1=ntortyp+1
7038         endif
7039 C A1 kernel(j+1) A2T
7040 cd        do iii=1,2
7041 cd          write (iout,'(3f10.5,5x,3f10.5)')
7042 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7043 cd        enddo
7044         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7045      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7046      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7047 C Following matrices are needed only for 6-th order cumulants
7048         IF (wcorr6.gt.0.0d0) THEN
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7051      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7052         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7053      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7054      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7055      &   ADtEAderx(1,1,1,1,1,1))
7056         lprn=.false.
7057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7058      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7059      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7060      &   ADtEA1derx(1,1,1,1,1,1))
7061         ENDIF
7062 C End 6-th order cumulants
7063 cd        lprn=.false.
7064 cd        if (lprn) then
7065 cd        write (2,*) 'In calc_eello6'
7066 cd        do iii=1,2
7067 cd          write (2,*) 'iii=',iii
7068 cd          do kkk=1,5
7069 cd            write (2,*) 'kkk=',kkk
7070 cd            do jjj=1,2
7071 cd              write (2,'(3(2f10.5),5x)')
7072 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7073 cd            enddo
7074 cd          enddo
7075 cd        enddo
7076 cd        endif
7077         call transpose2(EUgder(1,1,k),auxmat(1,1))
7078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7079         call transpose2(EUg(1,1,k),auxmat(1,1))
7080         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7081         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7082         do iii=1,2
7083           do kkk=1,5
7084             do lll=1,3
7085               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7086      &          EAEAderx(1,1,lll,kkk,iii,1))
7087             enddo
7088           enddo
7089         enddo
7090 C A1T kernel(i+1) A2
7091         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7092      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7093      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7094 C Following matrices are needed only for 6-th order cumulants
7095         IF (wcorr6.gt.0.0d0) THEN
7096         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7097      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7098      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7099         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7100      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7101      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7102      &   ADtEAderx(1,1,1,1,1,2))
7103         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7104      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7105      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7106      &   ADtEA1derx(1,1,1,1,1,2))
7107         ENDIF
7108 C End 6-th order cumulants
7109         call transpose2(EUgder(1,1,l),auxmat(1,1))
7110         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7111         call transpose2(EUg(1,1,l),auxmat(1,1))
7112         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7113         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7114         do iii=1,2
7115           do kkk=1,5
7116             do lll=1,3
7117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7118      &          EAEAderx(1,1,lll,kkk,iii,2))
7119             enddo
7120           enddo
7121         enddo
7122 C AEAb1 and AEAb2
7123 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7124 C They are needed only when the fifth- or the sixth-order cumulants are
7125 C indluded.
7126         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7127         call transpose2(AEA(1,1,1),auxmat(1,1))
7128         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7130         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7131         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7132         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7134         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7135         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7136         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7137         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7138         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7139         call transpose2(AEA(1,1,2),auxmat(1,1))
7140         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7141         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7142         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7143         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7144         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7145         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7146         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7147         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7148         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7149         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7150         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7151 C Calculate the Cartesian derivatives of the vectors.
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7156               call matvec2(auxmat(1,1),b1(1,iti),
7157      &          AEAb1derx(1,lll,kkk,iii,1,1))
7158               call matvec2(auxmat(1,1),Ub2(1,i),
7159      &          AEAb2derx(1,lll,kkk,iii,1,1))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7161      &          AEAb1derx(1,lll,kkk,iii,2,1))
7162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7163      &          AEAb2derx(1,lll,kkk,iii,2,1))
7164               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7165               call matvec2(auxmat(1,1),b1(1,itj),
7166      &          AEAb1derx(1,lll,kkk,iii,1,2))
7167               call matvec2(auxmat(1,1),Ub2(1,j),
7168      &          AEAb2derx(1,lll,kkk,iii,1,2))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7170      &          AEAb1derx(1,lll,kkk,iii,2,2))
7171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7172      &          AEAb2derx(1,lll,kkk,iii,2,2))
7173             enddo
7174           enddo
7175         enddo
7176         ENDIF
7177 C End vectors
7178       else
7179 C Antiparallel orientation of the two CA-CA-CA frames.
7180         if (i.gt.1) then
7181           iti=itortyp(itype(i))
7182         else
7183           iti=ntortyp+1
7184         endif
7185         itk1=itortyp(itype(k+1))
7186         itl=itortyp(itype(l))
7187         itj=itortyp(itype(j))
7188         if (j.lt.nres-1) then
7189           itj1=itortyp(itype(j+1))
7190         else
7191           itj1=ntortyp+1
7192         endif
7193 C A2 kernel(j-1)T A1T
7194         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7195      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7196      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7197 C Following matrices are needed only for 6-th order cumulants
7198         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7199      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7200         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7201      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7202      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7203         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7204      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7205      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7206      &   ADtEAderx(1,1,1,1,1,1))
7207         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7208      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7209      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7210      &   ADtEA1derx(1,1,1,1,1,1))
7211         ENDIF
7212 C End 6-th order cumulants
7213         call transpose2(EUgder(1,1,k),auxmat(1,1))
7214         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7215         call transpose2(EUg(1,1,k),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7217         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7218         do iii=1,2
7219           do kkk=1,5
7220             do lll=1,3
7221               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7222      &          EAEAderx(1,1,lll,kkk,iii,1))
7223             enddo
7224           enddo
7225         enddo
7226 C A2T kernel(i+1)T A1
7227         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7228      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7229      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7230 C Following matrices are needed only for 6-th order cumulants
7231         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7232      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7233         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7234      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7235      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7236         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7237      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7238      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7239      &   ADtEAderx(1,1,1,1,1,2))
7240         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7241      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7242      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7243      &   ADtEA1derx(1,1,1,1,1,2))
7244         ENDIF
7245 C End 6-th order cumulants
7246         call transpose2(EUgder(1,1,j),auxmat(1,1))
7247         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7248         call transpose2(EUg(1,1,j),auxmat(1,1))
7249         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7250         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7251         do iii=1,2
7252           do kkk=1,5
7253             do lll=1,3
7254               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7255      &          EAEAderx(1,1,lll,kkk,iii,2))
7256             enddo
7257           enddo
7258         enddo
7259 C AEAb1 and AEAb2
7260 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7261 C They are needed only when the fifth- or the sixth-order cumulants are
7262 C indluded.
7263         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7264      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7265         call transpose2(AEA(1,1,1),auxmat(1,1))
7266         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7267         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7268         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7269         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7270         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7271         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7272         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7273         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7274         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7275         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7276         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7277         call transpose2(AEA(1,1,2),auxmat(1,1))
7278         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7279         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7280         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7281         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7282         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7283         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7284         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7285         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7286         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7287         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7288         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7289 C Calculate the Cartesian derivatives of the vectors.
7290         do iii=1,2
7291           do kkk=1,5
7292             do lll=1,3
7293               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7294               call matvec2(auxmat(1,1),b1(1,iti),
7295      &          AEAb1derx(1,lll,kkk,iii,1,1))
7296               call matvec2(auxmat(1,1),Ub2(1,i),
7297      &          AEAb2derx(1,lll,kkk,iii,1,1))
7298               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7299      &          AEAb1derx(1,lll,kkk,iii,2,1))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7301      &          AEAb2derx(1,lll,kkk,iii,2,1))
7302               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7303               call matvec2(auxmat(1,1),b1(1,itl),
7304      &          AEAb1derx(1,lll,kkk,iii,1,2))
7305               call matvec2(auxmat(1,1),Ub2(1,l),
7306      &          AEAb2derx(1,lll,kkk,iii,1,2))
7307               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7308      &          AEAb1derx(1,lll,kkk,iii,2,2))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7310      &          AEAb2derx(1,lll,kkk,iii,2,2))
7311             enddo
7312           enddo
7313         enddo
7314         ENDIF
7315 C End vectors
7316       endif
7317       return
7318       end
7319 C---------------------------------------------------------------------------
7320       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7321      &  KK,KKderg,AKA,AKAderg,AKAderx)
7322       implicit none
7323       integer nderg
7324       logical transp
7325       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7326      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7327      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7328       integer iii,kkk,lll
7329       integer jjj,mmm
7330       logical lprn
7331       common /kutas/ lprn
7332       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7333       do iii=1,nderg
7334         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7335      &    AKAderg(1,1,iii))
7336       enddo
7337 cd      if (lprn) write (2,*) 'In kernel'
7338       do kkk=1,5
7339 cd        if (lprn) write (2,*) 'kkk=',kkk
7340         do lll=1,3
7341           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7342      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7343 cd          if (lprn) then
7344 cd            write (2,*) 'lll=',lll
7345 cd            write (2,*) 'iii=1'
7346 cd            do jjj=1,2
7347 cd              write (2,'(3(2f10.5),5x)')
7348 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7349 cd            enddo
7350 cd          endif
7351           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7352      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7353 cd          if (lprn) then
7354 cd            write (2,*) 'lll=',lll
7355 cd            write (2,*) 'iii=2'
7356 cd            do jjj=1,2
7357 cd              write (2,'(3(2f10.5),5x)')
7358 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7359 cd            enddo
7360 cd          endif
7361         enddo
7362       enddo
7363       return
7364       end
7365 C---------------------------------------------------------------------------
7366       double precision function eello4(i,j,k,l,jj,kk)
7367       implicit real*8 (a-h,o-z)
7368       include 'DIMENSIONS'
7369       include 'COMMON.IOUNITS'
7370       include 'COMMON.CHAIN'
7371       include 'COMMON.DERIV'
7372       include 'COMMON.INTERACT'
7373       include 'COMMON.CONTACTS'
7374       include 'COMMON.TORSION'
7375       include 'COMMON.VAR'
7376       include 'COMMON.GEO'
7377       double precision pizda(2,2),ggg1(3),ggg2(3)
7378 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7379 cd        eello4=0.0d0
7380 cd        return
7381 cd      endif
7382 cd      print *,'eello4:',i,j,k,l,jj,kk
7383 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7384 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7385 cold      eij=facont_hb(jj,i)
7386 cold      ekl=facont_hb(kk,k)
7387 cold      ekont=eij*ekl
7388       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7389 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7390       gcorr_loc(k-1)=gcorr_loc(k-1)
7391      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7392       if (l.eq.j+1) then
7393         gcorr_loc(l-1)=gcorr_loc(l-1)
7394      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7395       else
7396         gcorr_loc(j-1)=gcorr_loc(j-1)
7397      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7398       endif
7399       do iii=1,2
7400         do kkk=1,5
7401           do lll=1,3
7402             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7403      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7404 cd            derx(lll,kkk,iii)=0.0d0
7405           enddo
7406         enddo
7407       enddo
7408 cd      gcorr_loc(l-1)=0.0d0
7409 cd      gcorr_loc(j-1)=0.0d0
7410 cd      gcorr_loc(k-1)=0.0d0
7411 cd      eel4=1.0d0
7412 cd      write (iout,*)'Contacts have occurred for peptide groups',
7413 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7414 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7415       if (j.lt.nres-1) then
7416         j1=j+1
7417         j2=j-1
7418       else
7419         j1=j-1
7420         j2=j-2
7421       endif
7422       if (l.lt.nres-1) then
7423         l1=l+1
7424         l2=l-1
7425       else
7426         l1=l-1
7427         l2=l-2
7428       endif
7429       do ll=1,3
7430 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7431 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7432         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7433         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7434 cgrad        ghalf=0.5d0*ggg1(ll)
7435         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7436         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7437         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7438         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7439         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7440         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7441 cgrad        ghalf=0.5d0*ggg2(ll)
7442         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7443         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7444         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7445         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7446         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7447         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7448       enddo
7449 cgrad      do m=i+1,j-1
7450 cgrad        do ll=1,3
7451 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7452 cgrad        enddo
7453 cgrad      enddo
7454 cgrad      do m=k+1,l-1
7455 cgrad        do ll=1,3
7456 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7457 cgrad        enddo
7458 cgrad      enddo
7459 cgrad      do m=i+2,j2
7460 cgrad        do ll=1,3
7461 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7462 cgrad        enddo
7463 cgrad      enddo
7464 cgrad      do m=k+2,l2
7465 cgrad        do ll=1,3
7466 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7467 cgrad        enddo
7468 cgrad      enddo
7469 cd      do iii=1,nres-3
7470 cd        write (2,*) iii,gcorr_loc(iii)
7471 cd      enddo
7472       eello4=ekont*eel4
7473 cd      write (2,*) 'ekont',ekont
7474 cd      write (iout,*) 'eello4',ekont*eel4
7475       return
7476       end
7477 C---------------------------------------------------------------------------
7478       double precision function eello5(i,j,k,l,jj,kk)
7479       implicit real*8 (a-h,o-z)
7480       include 'DIMENSIONS'
7481       include 'COMMON.IOUNITS'
7482       include 'COMMON.CHAIN'
7483       include 'COMMON.DERIV'
7484       include 'COMMON.INTERACT'
7485       include 'COMMON.CONTACTS'
7486       include 'COMMON.TORSION'
7487       include 'COMMON.VAR'
7488       include 'COMMON.GEO'
7489       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7490       double precision ggg1(3),ggg2(3)
7491 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7492 C                                                                              C
7493 C                            Parallel chains                                   C
7494 C                                                                              C
7495 C          o             o                   o             o                   C
7496 C         /l\           / \             \   / \           / \   /              C
7497 C        /   \         /   \             \ /   \         /   \ /               C
7498 C       j| o |l1       | o |              o| o |         | o |o                C
7499 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7500 C      \i/   \         /   \ /             /   \         /   \                 C
7501 C       o    k1             o                                                  C
7502 C         (I)          (II)                (III)          (IV)                 C
7503 C                                                                              C
7504 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7505 C                                                                              C
7506 C                            Antiparallel chains                               C
7507 C                                                                              C
7508 C          o             o                   o             o                   C
7509 C         /j\           / \             \   / \           / \   /              C
7510 C        /   \         /   \             \ /   \         /   \ /               C
7511 C      j1| o |l        | o |              o| o |         | o |o                C
7512 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7513 C      \i/   \         /   \ /             /   \         /   \                 C
7514 C       o     k1            o                                                  C
7515 C         (I)          (II)                (III)          (IV)                 C
7516 C                                                                              C
7517 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7518 C                                                                              C
7519 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7520 C                                                                              C
7521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7522 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7523 cd        eello5=0.0d0
7524 cd        return
7525 cd      endif
7526 cd      write (iout,*)
7527 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7528 cd     &   ' and',k,l
7529       itk=itortyp(itype(k))
7530       itl=itortyp(itype(l))
7531       itj=itortyp(itype(j))
7532       eello5_1=0.0d0
7533       eello5_2=0.0d0
7534       eello5_3=0.0d0
7535       eello5_4=0.0d0
7536 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7537 cd     &   eel5_3_num,eel5_4_num)
7538       do iii=1,2
7539         do kkk=1,5
7540           do lll=1,3
7541             derx(lll,kkk,iii)=0.0d0
7542           enddo
7543         enddo
7544       enddo
7545 cd      eij=facont_hb(jj,i)
7546 cd      ekl=facont_hb(kk,k)
7547 cd      ekont=eij*ekl
7548 cd      write (iout,*)'Contacts have occurred for peptide groups',
7549 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7550 cd      goto 1111
7551 C Contribution from the graph I.
7552 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7553 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7554       call transpose2(EUg(1,1,k),auxmat(1,1))
7555       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7556       vv(1)=pizda(1,1)-pizda(2,2)
7557       vv(2)=pizda(1,2)+pizda(2,1)
7558       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7559      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7560 C Explicit gradient in virtual-dihedral angles.
7561       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7562      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7563      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7564       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7565       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7566       vv(1)=pizda(1,1)-pizda(2,2)
7567       vv(2)=pizda(1,2)+pizda(2,1)
7568       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7569      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7570      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7571       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7572       vv(1)=pizda(1,1)-pizda(2,2)
7573       vv(2)=pizda(1,2)+pizda(2,1)
7574       if (l.eq.j+1) then
7575         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7576      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7577      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7578       else
7579         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7580      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7581      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7582       endif
7583 C Cartesian gradient
7584       do iii=1,2
7585         do kkk=1,5
7586           do lll=1,3
7587             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7588      &        pizda(1,1))
7589             vv(1)=pizda(1,1)-pizda(2,2)
7590             vv(2)=pizda(1,2)+pizda(2,1)
7591             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7592      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7593      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7594           enddo
7595         enddo
7596       enddo
7597 c      goto 1112
7598 c1111  continue
7599 C Contribution from graph II
7600       call transpose2(EE(1,1,itk),auxmat(1,1))
7601       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7602       vv(1)=pizda(1,1)+pizda(2,2)
7603       vv(2)=pizda(2,1)-pizda(1,2)
7604       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7605      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7606 C Explicit gradient in virtual-dihedral angles.
7607       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7608      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7609       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7610       vv(1)=pizda(1,1)+pizda(2,2)
7611       vv(2)=pizda(2,1)-pizda(1,2)
7612       if (l.eq.j+1) then
7613         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7614      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7615      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7616       else
7617         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7618      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7619      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7620       endif
7621 C Cartesian gradient
7622       do iii=1,2
7623         do kkk=1,5
7624           do lll=1,3
7625             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7626      &        pizda(1,1))
7627             vv(1)=pizda(1,1)+pizda(2,2)
7628             vv(2)=pizda(2,1)-pizda(1,2)
7629             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7630      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7631      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7632           enddo
7633         enddo
7634       enddo
7635 cd      goto 1112
7636 cd1111  continue
7637       if (l.eq.j+1) then
7638 cd        goto 1110
7639 C Parallel orientation
7640 C Contribution from graph III
7641         call transpose2(EUg(1,1,l),auxmat(1,1))
7642         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7643         vv(1)=pizda(1,1)-pizda(2,2)
7644         vv(2)=pizda(1,2)+pizda(2,1)
7645         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7646      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7647 C Explicit gradient in virtual-dihedral angles.
7648         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7649      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7651         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7652         vv(1)=pizda(1,1)-pizda(2,2)
7653         vv(2)=pizda(1,2)+pizda(2,1)
7654         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7655      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7656      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7657         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7658         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7659         vv(1)=pizda(1,1)-pizda(2,2)
7660         vv(2)=pizda(1,2)+pizda(2,1)
7661         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7662      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7664 C Cartesian gradient
7665         do iii=1,2
7666           do kkk=1,5
7667             do lll=1,3
7668               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7669      &          pizda(1,1))
7670               vv(1)=pizda(1,1)-pizda(2,2)
7671               vv(2)=pizda(1,2)+pizda(2,1)
7672               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7673      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7674      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7675             enddo
7676           enddo
7677         enddo
7678 cd        goto 1112
7679 C Contribution from graph IV
7680 cd1110    continue
7681         call transpose2(EE(1,1,itl),auxmat(1,1))
7682         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7683         vv(1)=pizda(1,1)+pizda(2,2)
7684         vv(2)=pizda(2,1)-pizda(1,2)
7685         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7686      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7687 C Explicit gradient in virtual-dihedral angles.
7688         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7689      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7690         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7691         vv(1)=pizda(1,1)+pizda(2,2)
7692         vv(2)=pizda(2,1)-pizda(1,2)
7693         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7694      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7695      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7696 C Cartesian gradient
7697         do iii=1,2
7698           do kkk=1,5
7699             do lll=1,3
7700               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7701      &          pizda(1,1))
7702               vv(1)=pizda(1,1)+pizda(2,2)
7703               vv(2)=pizda(2,1)-pizda(1,2)
7704               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7705      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7706      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7707             enddo
7708           enddo
7709         enddo
7710       else
7711 C Antiparallel orientation
7712 C Contribution from graph III
7713 c        goto 1110
7714         call transpose2(EUg(1,1,j),auxmat(1,1))
7715         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7716         vv(1)=pizda(1,1)-pizda(2,2)
7717         vv(2)=pizda(1,2)+pizda(2,1)
7718         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7720 C Explicit gradient in virtual-dihedral angles.
7721         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7722      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7723      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7724         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7725         vv(1)=pizda(1,1)-pizda(2,2)
7726         vv(2)=pizda(1,2)+pizda(2,1)
7727         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7728      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7730         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7731         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7732         vv(1)=pizda(1,1)-pizda(2,2)
7733         vv(2)=pizda(1,2)+pizda(2,1)
7734         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7735      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7736      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7737 C Cartesian gradient
7738         do iii=1,2
7739           do kkk=1,5
7740             do lll=1,3
7741               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7742      &          pizda(1,1))
7743               vv(1)=pizda(1,1)-pizda(2,2)
7744               vv(2)=pizda(1,2)+pizda(2,1)
7745               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7746      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7747      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7748             enddo
7749           enddo
7750         enddo
7751 cd        goto 1112
7752 C Contribution from graph IV
7753 1110    continue
7754         call transpose2(EE(1,1,itj),auxmat(1,1))
7755         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7756         vv(1)=pizda(1,1)+pizda(2,2)
7757         vv(2)=pizda(2,1)-pizda(1,2)
7758         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7759      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7760 C Explicit gradient in virtual-dihedral angles.
7761         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7762      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7763         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7764         vv(1)=pizda(1,1)+pizda(2,2)
7765         vv(2)=pizda(2,1)-pizda(1,2)
7766         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7767      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7768      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7769 C Cartesian gradient
7770         do iii=1,2
7771           do kkk=1,5
7772             do lll=1,3
7773               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7774      &          pizda(1,1))
7775               vv(1)=pizda(1,1)+pizda(2,2)
7776               vv(2)=pizda(2,1)-pizda(1,2)
7777               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7778      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7779      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7780             enddo
7781           enddo
7782         enddo
7783       endif
7784 1112  continue
7785       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7786 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7787 cd        write (2,*) 'ijkl',i,j,k,l
7788 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7789 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7790 cd      endif
7791 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7792 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7793 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7794 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7795       if (j.lt.nres-1) then
7796         j1=j+1
7797         j2=j-1
7798       else
7799         j1=j-1
7800         j2=j-2
7801       endif
7802       if (l.lt.nres-1) then
7803         l1=l+1
7804         l2=l-1
7805       else
7806         l1=l-1
7807         l2=l-2
7808       endif
7809 cd      eij=1.0d0
7810 cd      ekl=1.0d0
7811 cd      ekont=1.0d0
7812 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7813 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7814 C        summed up outside the subrouine as for the other subroutines
7815 C        handling long-range interactions. The old code is commented out
7816 C        with "cgrad" to keep track of changes.
7817       do ll=1,3
7818 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7819 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7820         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7821         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7822 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7823 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7824 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7825 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7826 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7827 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7828 c     &   gradcorr5ij,
7829 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7830 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7831 cgrad        ghalf=0.5d0*ggg1(ll)
7832 cd        ghalf=0.0d0
7833         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7834         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7835         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7836         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7837         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7838         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7839 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7840 cgrad        ghalf=0.5d0*ggg2(ll)
7841 cd        ghalf=0.0d0
7842         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7843         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7844         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7845         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7846         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7847         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7848       enddo
7849 cd      goto 1112
7850 cgrad      do m=i+1,j-1
7851 cgrad        do ll=1,3
7852 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7853 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7854 cgrad        enddo
7855 cgrad      enddo
7856 cgrad      do m=k+1,l-1
7857 cgrad        do ll=1,3
7858 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7859 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7860 cgrad        enddo
7861 cgrad      enddo
7862 c1112  continue
7863 cgrad      do m=i+2,j2
7864 cgrad        do ll=1,3
7865 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7866 cgrad        enddo
7867 cgrad      enddo
7868 cgrad      do m=k+2,l2
7869 cgrad        do ll=1,3
7870 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7871 cgrad        enddo
7872 cgrad      enddo
7873 cd      do iii=1,nres-3
7874 cd        write (2,*) iii,g_corr5_loc(iii)
7875 cd      enddo
7876       eello5=ekont*eel5
7877 cd      write (2,*) 'ekont',ekont
7878 cd      write (iout,*) 'eello5',ekont*eel5
7879       return
7880       end
7881 c--------------------------------------------------------------------------
7882       double precision function eello6(i,j,k,l,jj,kk)
7883       implicit real*8 (a-h,o-z)
7884       include 'DIMENSIONS'
7885       include 'COMMON.IOUNITS'
7886       include 'COMMON.CHAIN'
7887       include 'COMMON.DERIV'
7888       include 'COMMON.INTERACT'
7889       include 'COMMON.CONTACTS'
7890       include 'COMMON.TORSION'
7891       include 'COMMON.VAR'
7892       include 'COMMON.GEO'
7893       include 'COMMON.FFIELD'
7894       double precision ggg1(3),ggg2(3)
7895 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7896 cd        eello6=0.0d0
7897 cd        return
7898 cd      endif
7899 cd      write (iout,*)
7900 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7901 cd     &   ' and',k,l
7902       eello6_1=0.0d0
7903       eello6_2=0.0d0
7904       eello6_3=0.0d0
7905       eello6_4=0.0d0
7906       eello6_5=0.0d0
7907       eello6_6=0.0d0
7908 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7909 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7910       do iii=1,2
7911         do kkk=1,5
7912           do lll=1,3
7913             derx(lll,kkk,iii)=0.0d0
7914           enddo
7915         enddo
7916       enddo
7917 cd      eij=facont_hb(jj,i)
7918 cd      ekl=facont_hb(kk,k)
7919 cd      ekont=eij*ekl
7920 cd      eij=1.0d0
7921 cd      ekl=1.0d0
7922 cd      ekont=1.0d0
7923       if (l.eq.j+1) then
7924         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7925         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7926         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7927         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7928         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7929         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7930       else
7931         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7932         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7933         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7934         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7935         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7936           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7937         else
7938           eello6_5=0.0d0
7939         endif
7940         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7941       endif
7942 C If turn contributions are considered, they will be handled separately.
7943       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7944 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7945 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7946 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7947 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7948 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7949 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7950 cd      goto 1112
7951       if (j.lt.nres-1) then
7952         j1=j+1
7953         j2=j-1
7954       else
7955         j1=j-1
7956         j2=j-2
7957       endif
7958       if (l.lt.nres-1) then
7959         l1=l+1
7960         l2=l-1
7961       else
7962         l1=l-1
7963         l2=l-2
7964       endif
7965       do ll=1,3
7966 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7967 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7968 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7969 cgrad        ghalf=0.5d0*ggg1(ll)
7970 cd        ghalf=0.0d0
7971         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7972         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7973         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7974         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7975         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7976         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7977         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7978         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7979 cgrad        ghalf=0.5d0*ggg2(ll)
7980 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7981 cd        ghalf=0.0d0
7982         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7983         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7984         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7985         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7986         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7987         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7988       enddo
7989 cd      goto 1112
7990 cgrad      do m=i+1,j-1
7991 cgrad        do ll=1,3
7992 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7993 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7994 cgrad        enddo
7995 cgrad      enddo
7996 cgrad      do m=k+1,l-1
7997 cgrad        do ll=1,3
7998 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7999 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8000 cgrad        enddo
8001 cgrad      enddo
8002 cgrad1112  continue
8003 cgrad      do m=i+2,j2
8004 cgrad        do ll=1,3
8005 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8006 cgrad        enddo
8007 cgrad      enddo
8008 cgrad      do m=k+2,l2
8009 cgrad        do ll=1,3
8010 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cd      do iii=1,nres-3
8014 cd        write (2,*) iii,g_corr6_loc(iii)
8015 cd      enddo
8016       eello6=ekont*eel6
8017 cd      write (2,*) 'ekont',ekont
8018 cd      write (iout,*) 'eello6',ekont*eel6
8019       return
8020       end
8021 c--------------------------------------------------------------------------
8022       double precision function eello6_graph1(i,j,k,l,imat,swap)
8023       implicit real*8 (a-h,o-z)
8024       include 'DIMENSIONS'
8025       include 'COMMON.IOUNITS'
8026       include 'COMMON.CHAIN'
8027       include 'COMMON.DERIV'
8028       include 'COMMON.INTERACT'
8029       include 'COMMON.CONTACTS'
8030       include 'COMMON.TORSION'
8031       include 'COMMON.VAR'
8032       include 'COMMON.GEO'
8033       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8034       logical swap
8035       logical lprn
8036       common /kutas/ lprn
8037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038 C                                                                              C
8039 C      Parallel       Antiparallel                                             C
8040 C                                                                              C
8041 C          o             o                                                     C
8042 C         /l\           /j\                                                    C
8043 C        /   \         /   \                                                   C
8044 C       /| o |         | o |\                                                  C
8045 C     \ j|/k\|  /   \  |/k\|l /                                                C
8046 C      \ /   \ /     \ /   \ /                                                 C
8047 C       o     o       o     o                                                  C
8048 C       i             i                                                        C
8049 C                                                                              C
8050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8051       itk=itortyp(itype(k))
8052       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8053       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8054       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8055       call transpose2(EUgC(1,1,k),auxmat(1,1))
8056       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8057       vv1(1)=pizda1(1,1)-pizda1(2,2)
8058       vv1(2)=pizda1(1,2)+pizda1(2,1)
8059       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8060       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8061       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8062       s5=scalar2(vv(1),Dtobr2(1,i))
8063 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8064       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8065       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8066      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8067      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8068      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8069      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8070      & +scalar2(vv(1),Dtobr2der(1,i)))
8071       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8072       vv1(1)=pizda1(1,1)-pizda1(2,2)
8073       vv1(2)=pizda1(1,2)+pizda1(2,1)
8074       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8075       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8076       if (l.eq.j+1) then
8077         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8078      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8079      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8080      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8081      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8082       else
8083         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8084      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8085      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8086      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8087      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8088       endif
8089       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8090       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8091       vv1(1)=pizda1(1,1)-pizda1(2,2)
8092       vv1(2)=pizda1(1,2)+pizda1(2,1)
8093       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8094      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8095      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8096      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8097       do iii=1,2
8098         if (swap) then
8099           ind=3-iii
8100         else
8101           ind=iii
8102         endif
8103         do kkk=1,5
8104           do lll=1,3
8105             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8106             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8107             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8108             call transpose2(EUgC(1,1,k),auxmat(1,1))
8109             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8110      &        pizda1(1,1))
8111             vv1(1)=pizda1(1,1)-pizda1(2,2)
8112             vv1(2)=pizda1(1,2)+pizda1(2,1)
8113             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8114             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8115      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8116             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8117      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8118             s5=scalar2(vv(1),Dtobr2(1,i))
8119             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8120           enddo
8121         enddo
8122       enddo
8123       return
8124       end
8125 c----------------------------------------------------------------------------
8126       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8127       implicit real*8 (a-h,o-z)
8128       include 'DIMENSIONS'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.TORSION'
8135       include 'COMMON.VAR'
8136       include 'COMMON.GEO'
8137       logical swap
8138       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8139      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8140       logical lprn
8141       common /kutas/ lprn
8142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8143 C                                                                              C
8144 C      Parallel       Antiparallel                                             C
8145 C                                                                              C
8146 C          o             o                                                     C
8147 C     \   /l\           /j\   /                                                C
8148 C      \ /   \         /   \ /                                                 C
8149 C       o| o |         | o |o                                                  C
8150 C     \ j|/k\|      \  |/k\|l                                                  C
8151 C      \ /   \       \ /   \                                                   C
8152 C       o             o                                                        C
8153 C       i             i                                                        C
8154 C                                                                              C
8155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8156 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8157 C AL 7/4/01 s1 would occur in the sixth-order moment,
8158 C           but not in a cluster cumulant
8159 #ifdef MOMENT
8160       s1=dip(1,jj,i)*dip(1,kk,k)
8161 #endif
8162       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8163       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8164       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8165       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8166       call transpose2(EUg(1,1,k),auxmat(1,1))
8167       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8168       vv(1)=pizda(1,1)-pizda(2,2)
8169       vv(2)=pizda(1,2)+pizda(2,1)
8170       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8171 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8172 #ifdef MOMENT
8173       eello6_graph2=-(s1+s2+s3+s4)
8174 #else
8175       eello6_graph2=-(s2+s3+s4)
8176 #endif
8177 c      eello6_graph2=-s3
8178 C Derivatives in gamma(i-1)
8179       if (i.gt.1) then
8180 #ifdef MOMENT
8181         s1=dipderg(1,jj,i)*dip(1,kk,k)
8182 #endif
8183         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8184         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8185         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8186         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8187 #ifdef MOMENT
8188         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8189 #else
8190         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8191 #endif
8192 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8193       endif
8194 C Derivatives in gamma(k-1)
8195 #ifdef MOMENT
8196       s1=dip(1,jj,i)*dipderg(1,kk,k)
8197 #endif
8198       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8199       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8200       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8201       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8202       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8203       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8204       vv(1)=pizda(1,1)-pizda(2,2)
8205       vv(2)=pizda(1,2)+pizda(2,1)
8206       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8207 #ifdef MOMENT
8208       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8209 #else
8210       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8211 #endif
8212 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8213 C Derivatives in gamma(j-1) or gamma(l-1)
8214       if (j.gt.1) then
8215 #ifdef MOMENT
8216         s1=dipderg(3,jj,i)*dip(1,kk,k)
8217 #endif
8218         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8219         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8220         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8221         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8222         vv(1)=pizda(1,1)-pizda(2,2)
8223         vv(2)=pizda(1,2)+pizda(2,1)
8224         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8225 #ifdef MOMENT
8226         if (swap) then
8227           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8228         else
8229           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8230         endif
8231 #endif
8232         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8233 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8234       endif
8235 C Derivatives in gamma(l-1) or gamma(j-1)
8236       if (l.gt.1) then
8237 #ifdef MOMENT
8238         s1=dip(1,jj,i)*dipderg(3,kk,k)
8239 #endif
8240         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8241         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8242         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8243         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8244         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8245         vv(1)=pizda(1,1)-pizda(2,2)
8246         vv(2)=pizda(1,2)+pizda(2,1)
8247         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8248 #ifdef MOMENT
8249         if (swap) then
8250           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8251         else
8252           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8253         endif
8254 #endif
8255         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8256 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8257       endif
8258 C Cartesian derivatives.
8259       if (lprn) then
8260         write (2,*) 'In eello6_graph2'
8261         do iii=1,2
8262           write (2,*) 'iii=',iii
8263           do kkk=1,5
8264             write (2,*) 'kkk=',kkk
8265             do jjj=1,2
8266               write (2,'(3(2f10.5),5x)')
8267      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8268             enddo
8269           enddo
8270         enddo
8271       endif
8272       do iii=1,2
8273         do kkk=1,5
8274           do lll=1,3
8275 #ifdef MOMENT
8276             if (iii.eq.1) then
8277               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8278             else
8279               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8280             endif
8281 #endif
8282             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8283      &        auxvec(1))
8284             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8285             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8286      &        auxvec(1))
8287             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8288             call transpose2(EUg(1,1,k),auxmat(1,1))
8289             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8290      &        pizda(1,1))
8291             vv(1)=pizda(1,1)-pizda(2,2)
8292             vv(2)=pizda(1,2)+pizda(2,1)
8293             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8294 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8295 #ifdef MOMENT
8296             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8297 #else
8298             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8299 #endif
8300             if (swap) then
8301               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8302             else
8303               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8304             endif
8305           enddo
8306         enddo
8307       enddo
8308       return
8309       end
8310 c----------------------------------------------------------------------------
8311       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8312       implicit real*8 (a-h,o-z)
8313       include 'DIMENSIONS'
8314       include 'COMMON.IOUNITS'
8315       include 'COMMON.CHAIN'
8316       include 'COMMON.DERIV'
8317       include 'COMMON.INTERACT'
8318       include 'COMMON.CONTACTS'
8319       include 'COMMON.TORSION'
8320       include 'COMMON.VAR'
8321       include 'COMMON.GEO'
8322       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8323       logical swap
8324 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8325 C                                                                              C
8326 C      Parallel       Antiparallel                                             C
8327 C                                                                              C
8328 C          o             o                                                     C
8329 C         /l\   /   \   /j\                                                    C
8330 C        /   \ /     \ /   \                                                   C
8331 C       /| o |o       o| o |\                                                  C
8332 C       j|/k\|  /      |/k\|l /                                                C
8333 C        /   \ /       /   \ /                                                 C
8334 C       /     o       /     o                                                  C
8335 C       i             i                                                        C
8336 C                                                                              C
8337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8338 C
8339 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8340 C           energy moment and not to the cluster cumulant.
8341       iti=itortyp(itype(i))
8342       if (j.lt.nres-1) then
8343         itj1=itortyp(itype(j+1))
8344       else
8345         itj1=ntortyp+1
8346       endif
8347       itk=itortyp(itype(k))
8348       itk1=itortyp(itype(k+1))
8349       if (l.lt.nres-1) then
8350         itl1=itortyp(itype(l+1))
8351       else
8352         itl1=ntortyp+1
8353       endif
8354 #ifdef MOMENT
8355       s1=dip(4,jj,i)*dip(4,kk,k)
8356 #endif
8357       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8358       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8359       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8360       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8361       call transpose2(EE(1,1,itk),auxmat(1,1))
8362       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8363       vv(1)=pizda(1,1)+pizda(2,2)
8364       vv(2)=pizda(2,1)-pizda(1,2)
8365       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8366 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8367 cd     & "sum",-(s2+s3+s4)
8368 #ifdef MOMENT
8369       eello6_graph3=-(s1+s2+s3+s4)
8370 #else
8371       eello6_graph3=-(s2+s3+s4)
8372 #endif
8373 c      eello6_graph3=-s4
8374 C Derivatives in gamma(k-1)
8375       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8376       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8377       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8378       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8379 C Derivatives in gamma(l-1)
8380       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8381       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8382       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8383       vv(1)=pizda(1,1)+pizda(2,2)
8384       vv(2)=pizda(2,1)-pizda(1,2)
8385       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8386       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8387 C Cartesian derivatives.
8388       do iii=1,2
8389         do kkk=1,5
8390           do lll=1,3
8391 #ifdef MOMENT
8392             if (iii.eq.1) then
8393               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8394             else
8395               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8396             endif
8397 #endif
8398             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8399      &        auxvec(1))
8400             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8401             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8402      &        auxvec(1))
8403             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8404             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8405      &        pizda(1,1))
8406             vv(1)=pizda(1,1)+pizda(2,2)
8407             vv(2)=pizda(2,1)-pizda(1,2)
8408             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8409 #ifdef MOMENT
8410             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8411 #else
8412             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8413 #endif
8414             if (swap) then
8415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8416             else
8417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8418             endif
8419 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8420           enddo
8421         enddo
8422       enddo
8423       return
8424       end
8425 c----------------------------------------------------------------------------
8426       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8427       implicit real*8 (a-h,o-z)
8428       include 'DIMENSIONS'
8429       include 'COMMON.IOUNITS'
8430       include 'COMMON.CHAIN'
8431       include 'COMMON.DERIV'
8432       include 'COMMON.INTERACT'
8433       include 'COMMON.CONTACTS'
8434       include 'COMMON.TORSION'
8435       include 'COMMON.VAR'
8436       include 'COMMON.GEO'
8437       include 'COMMON.FFIELD'
8438       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8439      & auxvec1(2),auxmat1(2,2)
8440       logical swap
8441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8442 C                                                                              C
8443 C      Parallel       Antiparallel                                             C
8444 C                                                                              C
8445 C          o             o                                                     C
8446 C         /l\   /   \   /j\                                                    C
8447 C        /   \ /     \ /   \                                                   C
8448 C       /| o |o       o| o |\                                                  C
8449 C     \ j|/k\|      \  |/k\|l                                                  C
8450 C      \ /   \       \ /   \                                                   C
8451 C       o     \       o     \                                                  C
8452 C       i             i                                                        C
8453 C                                                                              C
8454 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8455 C
8456 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8457 C           energy moment and not to the cluster cumulant.
8458 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8459       iti=itortyp(itype(i))
8460       itj=itortyp(itype(j))
8461       if (j.lt.nres-1) then
8462         itj1=itortyp(itype(j+1))
8463       else
8464         itj1=ntortyp+1
8465       endif
8466       itk=itortyp(itype(k))
8467       if (k.lt.nres-1) then
8468         itk1=itortyp(itype(k+1))
8469       else
8470         itk1=ntortyp+1
8471       endif
8472       itl=itortyp(itype(l))
8473       if (l.lt.nres-1) then
8474         itl1=itortyp(itype(l+1))
8475       else
8476         itl1=ntortyp+1
8477       endif
8478 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8479 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8480 cd     & ' itl',itl,' itl1',itl1
8481 #ifdef MOMENT
8482       if (imat.eq.1) then
8483         s1=dip(3,jj,i)*dip(3,kk,k)
8484       else
8485         s1=dip(2,jj,j)*dip(2,kk,l)
8486       endif
8487 #endif
8488       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8489       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8490       if (j.eq.l+1) then
8491         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8492         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8493       else
8494         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8495         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8496       endif
8497       call transpose2(EUg(1,1,k),auxmat(1,1))
8498       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8499       vv(1)=pizda(1,1)-pizda(2,2)
8500       vv(2)=pizda(2,1)+pizda(1,2)
8501       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8502 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8503 #ifdef MOMENT
8504       eello6_graph4=-(s1+s2+s3+s4)
8505 #else
8506       eello6_graph4=-(s2+s3+s4)
8507 #endif
8508 C Derivatives in gamma(i-1)
8509       if (i.gt.1) then
8510 #ifdef MOMENT
8511         if (imat.eq.1) then
8512           s1=dipderg(2,jj,i)*dip(3,kk,k)
8513         else
8514           s1=dipderg(4,jj,j)*dip(2,kk,l)
8515         endif
8516 #endif
8517         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8518         if (j.eq.l+1) then
8519           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8520           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8521         else
8522           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8523           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8524         endif
8525         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8526         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8527 cd          write (2,*) 'turn6 derivatives'
8528 #ifdef MOMENT
8529           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8530 #else
8531           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8532 #endif
8533         else
8534 #ifdef MOMENT
8535           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8536 #else
8537           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8538 #endif
8539         endif
8540       endif
8541 C Derivatives in gamma(k-1)
8542 #ifdef MOMENT
8543       if (imat.eq.1) then
8544         s1=dip(3,jj,i)*dipderg(2,kk,k)
8545       else
8546         s1=dip(2,jj,j)*dipderg(4,kk,l)
8547       endif
8548 #endif
8549       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8550       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8551       if (j.eq.l+1) then
8552         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8553         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8554       else
8555         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8556         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8557       endif
8558       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8559       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8560       vv(1)=pizda(1,1)-pizda(2,2)
8561       vv(2)=pizda(2,1)+pizda(1,2)
8562       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8563       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8564 #ifdef MOMENT
8565         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8566 #else
8567         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8568 #endif
8569       else
8570 #ifdef MOMENT
8571         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8572 #else
8573         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8574 #endif
8575       endif
8576 C Derivatives in gamma(j-1) or gamma(l-1)
8577       if (l.eq.j+1 .and. l.gt.1) then
8578         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8579         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8580         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8581         vv(1)=pizda(1,1)-pizda(2,2)
8582         vv(2)=pizda(2,1)+pizda(1,2)
8583         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8584         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8585       else if (j.gt.1) then
8586         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8587         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8588         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8589         vv(1)=pizda(1,1)-pizda(2,2)
8590         vv(2)=pizda(2,1)+pizda(1,2)
8591         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8592         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8593           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8594         else
8595           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8596         endif
8597       endif
8598 C Cartesian derivatives.
8599       do iii=1,2
8600         do kkk=1,5
8601           do lll=1,3
8602 #ifdef MOMENT
8603             if (iii.eq.1) then
8604               if (imat.eq.1) then
8605                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8606               else
8607                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8608               endif
8609             else
8610               if (imat.eq.1) then
8611                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8612               else
8613                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8614               endif
8615             endif
8616 #endif
8617             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8618      &        auxvec(1))
8619             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8620             if (j.eq.l+1) then
8621               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8622      &          b1(1,itj1),auxvec(1))
8623               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8624             else
8625               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8626      &          b1(1,itl1),auxvec(1))
8627               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8628             endif
8629             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8630      &        pizda(1,1))
8631             vv(1)=pizda(1,1)-pizda(2,2)
8632             vv(2)=pizda(2,1)+pizda(1,2)
8633             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8634             if (swap) then
8635               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8636 #ifdef MOMENT
8637                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8638      &             -(s1+s2+s4)
8639 #else
8640                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8641      &             -(s2+s4)
8642 #endif
8643                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8644               else
8645 #ifdef MOMENT
8646                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8647 #else
8648                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8649 #endif
8650                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8651               endif
8652             else
8653 #ifdef MOMENT
8654               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8655 #else
8656               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8657 #endif
8658               if (l.eq.j+1) then
8659                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8660               else
8661                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8662               endif
8663             endif
8664           enddo
8665         enddo
8666       enddo
8667       return
8668       end
8669 c----------------------------------------------------------------------------
8670       double precision function eello_turn6(i,jj,kk)
8671       implicit real*8 (a-h,o-z)
8672       include 'DIMENSIONS'
8673       include 'COMMON.IOUNITS'
8674       include 'COMMON.CHAIN'
8675       include 'COMMON.DERIV'
8676       include 'COMMON.INTERACT'
8677       include 'COMMON.CONTACTS'
8678       include 'COMMON.TORSION'
8679       include 'COMMON.VAR'
8680       include 'COMMON.GEO'
8681       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8682      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8683      &  ggg1(3),ggg2(3)
8684       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8685      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8686 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8687 C           the respective energy moment and not to the cluster cumulant.
8688       s1=0.0d0
8689       s8=0.0d0
8690       s13=0.0d0
8691 c
8692       eello_turn6=0.0d0
8693       j=i+4
8694       k=i+1
8695       l=i+3
8696       iti=itortyp(itype(i))
8697       itk=itortyp(itype(k))
8698       itk1=itortyp(itype(k+1))
8699       itl=itortyp(itype(l))
8700       itj=itortyp(itype(j))
8701 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8702 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8703 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8704 cd        eello6=0.0d0
8705 cd        return
8706 cd      endif
8707 cd      write (iout,*)
8708 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8709 cd     &   ' and',k,l
8710 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8711       do iii=1,2
8712         do kkk=1,5
8713           do lll=1,3
8714             derx_turn(lll,kkk,iii)=0.0d0
8715           enddo
8716         enddo
8717       enddo
8718 cd      eij=1.0d0
8719 cd      ekl=1.0d0
8720 cd      ekont=1.0d0
8721       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8722 cd      eello6_5=0.0d0
8723 cd      write (2,*) 'eello6_5',eello6_5
8724 #ifdef MOMENT
8725       call transpose2(AEA(1,1,1),auxmat(1,1))
8726       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8727       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8728       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8729 #endif
8730       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8731       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8732       s2 = scalar2(b1(1,itk),vtemp1(1))
8733 #ifdef MOMENT
8734       call transpose2(AEA(1,1,2),atemp(1,1))
8735       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8736       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8737       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8738 #endif
8739       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8740       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8741       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8742 #ifdef MOMENT
8743       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8744       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8745       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8746       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8747       ss13 = scalar2(b1(1,itk),vtemp4(1))
8748       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8749 #endif
8750 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8751 c      s1=0.0d0
8752 c      s2=0.0d0
8753 c      s8=0.0d0
8754 c      s12=0.0d0
8755 c      s13=0.0d0
8756       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8757 C Derivatives in gamma(i+2)
8758       s1d =0.0d0
8759       s8d =0.0d0
8760 #ifdef MOMENT
8761       call transpose2(AEA(1,1,1),auxmatd(1,1))
8762       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8763       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8764       call transpose2(AEAderg(1,1,2),atempd(1,1))
8765       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8766       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8767 #endif
8768       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8769       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8770       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8771 c      s1d=0.0d0
8772 c      s2d=0.0d0
8773 c      s8d=0.0d0
8774 c      s12d=0.0d0
8775 c      s13d=0.0d0
8776       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8777 C Derivatives in gamma(i+3)
8778 #ifdef MOMENT
8779       call transpose2(AEA(1,1,1),auxmatd(1,1))
8780       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8781       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8782       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8783 #endif
8784       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8785       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8786       s2d = scalar2(b1(1,itk),vtemp1d(1))
8787 #ifdef MOMENT
8788       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8789       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8790 #endif
8791       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8792 #ifdef MOMENT
8793       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8794       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8795       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8796 #endif
8797 c      s1d=0.0d0
8798 c      s2d=0.0d0
8799 c      s8d=0.0d0
8800 c      s12d=0.0d0
8801 c      s13d=0.0d0
8802 #ifdef MOMENT
8803       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8804      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8805 #else
8806       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8807      &               -0.5d0*ekont*(s2d+s12d)
8808 #endif
8809 C Derivatives in gamma(i+4)
8810       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8811       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8812       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8813 #ifdef MOMENT
8814       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8815       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8816       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8817 #endif
8818 c      s1d=0.0d0
8819 c      s2d=0.0d0
8820 c      s8d=0.0d0
8821 C      s12d=0.0d0
8822 c      s13d=0.0d0
8823 #ifdef MOMENT
8824       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8825 #else
8826       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8827 #endif
8828 C Derivatives in gamma(i+5)
8829 #ifdef MOMENT
8830       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8831       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8832       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8833 #endif
8834       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8835       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8836       s2d = scalar2(b1(1,itk),vtemp1d(1))
8837 #ifdef MOMENT
8838       call transpose2(AEA(1,1,2),atempd(1,1))
8839       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8840       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8841 #endif
8842       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8843       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8844 #ifdef MOMENT
8845       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8846       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8847       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8848 #endif
8849 c      s1d=0.0d0
8850 c      s2d=0.0d0
8851 c      s8d=0.0d0
8852 c      s12d=0.0d0
8853 c      s13d=0.0d0
8854 #ifdef MOMENT
8855       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8856      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8857 #else
8858       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8859      &               -0.5d0*ekont*(s2d+s12d)
8860 #endif
8861 C Cartesian derivatives
8862       do iii=1,2
8863         do kkk=1,5
8864           do lll=1,3
8865 #ifdef MOMENT
8866             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8867             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8868             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8869 #endif
8870             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8871             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8872      &          vtemp1d(1))
8873             s2d = scalar2(b1(1,itk),vtemp1d(1))
8874 #ifdef MOMENT
8875             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8876             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8877             s8d = -(atempd(1,1)+atempd(2,2))*
8878      &           scalar2(cc(1,1,itl),vtemp2(1))
8879 #endif
8880             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8881      &           auxmatd(1,1))
8882             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8883             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8884 c      s1d=0.0d0
8885 c      s2d=0.0d0
8886 c      s8d=0.0d0
8887 c      s12d=0.0d0
8888 c      s13d=0.0d0
8889 #ifdef MOMENT
8890             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8891      &        - 0.5d0*(s1d+s2d)
8892 #else
8893             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8894      &        - 0.5d0*s2d
8895 #endif
8896 #ifdef MOMENT
8897             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8898      &        - 0.5d0*(s8d+s12d)
8899 #else
8900             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8901      &        - 0.5d0*s12d
8902 #endif
8903           enddo
8904         enddo
8905       enddo
8906 #ifdef MOMENT
8907       do kkk=1,5
8908         do lll=1,3
8909           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8910      &      achuj_tempd(1,1))
8911           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8912           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8913           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8914           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8915           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8916      &      vtemp4d(1))
8917           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8918           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8919           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8920         enddo
8921       enddo
8922 #endif
8923 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8924 cd     &  16*eel_turn6_num
8925 cd      goto 1112
8926       if (j.lt.nres-1) then
8927         j1=j+1
8928         j2=j-1
8929       else
8930         j1=j-1
8931         j2=j-2
8932       endif
8933       if (l.lt.nres-1) then
8934         l1=l+1
8935         l2=l-1
8936       else
8937         l1=l-1
8938         l2=l-2
8939       endif
8940       do ll=1,3
8941 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8942 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8943 cgrad        ghalf=0.5d0*ggg1(ll)
8944 cd        ghalf=0.0d0
8945         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8946         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8947         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8948      &    +ekont*derx_turn(ll,2,1)
8949         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8950         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8951      &    +ekont*derx_turn(ll,4,1)
8952         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8953         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8954         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8955 cgrad        ghalf=0.5d0*ggg2(ll)
8956 cd        ghalf=0.0d0
8957         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8958      &    +ekont*derx_turn(ll,2,2)
8959         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8960         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8961      &    +ekont*derx_turn(ll,4,2)
8962         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8963         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8964         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8965       enddo
8966 cd      goto 1112
8967 cgrad      do m=i+1,j-1
8968 cgrad        do ll=1,3
8969 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8970 cgrad        enddo
8971 cgrad      enddo
8972 cgrad      do m=k+1,l-1
8973 cgrad        do ll=1,3
8974 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8975 cgrad        enddo
8976 cgrad      enddo
8977 cgrad1112  continue
8978 cgrad      do m=i+2,j2
8979 cgrad        do ll=1,3
8980 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8981 cgrad        enddo
8982 cgrad      enddo
8983 cgrad      do m=k+2,l2
8984 cgrad        do ll=1,3
8985 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8986 cgrad        enddo
8987 cgrad      enddo
8988 cd      do iii=1,nres-3
8989 cd        write (2,*) iii,g_corr6_loc(iii)
8990 cd      enddo
8991       eello_turn6=ekont*eel_turn6
8992 cd      write (2,*) 'ekont',ekont
8993 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8994       return
8995       end
8996
8997 C-----------------------------------------------------------------------------
8998       double precision function scalar(u,v)
8999 !DIR$ INLINEALWAYS scalar
9000 #ifndef OSF
9001 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9002 #endif
9003       implicit none
9004       double precision u(3),v(3)
9005 cd      double precision sc
9006 cd      integer i
9007 cd      sc=0.0d0
9008 cd      do i=1,3
9009 cd        sc=sc+u(i)*v(i)
9010 cd      enddo
9011 cd      scalar=sc
9012
9013       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9014       return
9015       end
9016 crc-------------------------------------------------
9017       SUBROUTINE MATVEC2(A1,V1,V2)
9018 !DIR$ INLINEALWAYS MATVEC2
9019 #ifndef OSF
9020 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9021 #endif
9022       implicit real*8 (a-h,o-z)
9023       include 'DIMENSIONS'
9024       DIMENSION A1(2,2),V1(2),V2(2)
9025 c      DO 1 I=1,2
9026 c        VI=0.0
9027 c        DO 3 K=1,2
9028 c    3     VI=VI+A1(I,K)*V1(K)
9029 c        Vaux(I)=VI
9030 c    1 CONTINUE
9031
9032       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9033       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9034
9035       v2(1)=vaux1
9036       v2(2)=vaux2
9037       END
9038 C---------------------------------------
9039       SUBROUTINE MATMAT2(A1,A2,A3)
9040 #ifndef OSF
9041 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9042 #endif
9043       implicit real*8 (a-h,o-z)
9044       include 'DIMENSIONS'
9045       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9046 c      DIMENSION AI3(2,2)
9047 c        DO  J=1,2
9048 c          A3IJ=0.0
9049 c          DO K=1,2
9050 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9051 c          enddo
9052 c          A3(I,J)=A3IJ
9053 c       enddo
9054 c      enddo
9055
9056       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9057       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9058       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9059       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9060
9061       A3(1,1)=AI3_11
9062       A3(2,1)=AI3_21
9063       A3(1,2)=AI3_12
9064       A3(2,2)=AI3_22
9065       END
9066
9067 c-------------------------------------------------------------------------
9068       double precision function scalar2(u,v)
9069 !DIR$ INLINEALWAYS scalar2
9070       implicit none
9071       double precision u(2),v(2)
9072       double precision sc
9073       integer i
9074       scalar2=u(1)*v(1)+u(2)*v(2)
9075       return
9076       end
9077
9078 C-----------------------------------------------------------------------------
9079
9080       subroutine transpose2(a,at)
9081 !DIR$ INLINEALWAYS transpose2
9082 #ifndef OSF
9083 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9084 #endif
9085       implicit none
9086       double precision a(2,2),at(2,2)
9087       at(1,1)=a(1,1)
9088       at(1,2)=a(2,1)
9089       at(2,1)=a(1,2)
9090       at(2,2)=a(2,2)
9091       return
9092       end
9093 c--------------------------------------------------------------------------
9094       subroutine transpose(n,a,at)
9095       implicit none
9096       integer n,i,j
9097       double precision a(n,n),at(n,n)
9098       do i=1,n
9099         do j=1,n
9100           at(j,i)=a(i,j)
9101         enddo
9102       enddo
9103       return
9104       end
9105 C---------------------------------------------------------------------------
9106       subroutine prodmat3(a1,a2,kk,transp,prod)
9107 !DIR$ INLINEALWAYS prodmat3
9108 #ifndef OSF
9109 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9110 #endif
9111       implicit none
9112       integer i,j
9113       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9114       logical transp
9115 crc      double precision auxmat(2,2),prod_(2,2)
9116
9117       if (transp) then
9118 crc        call transpose2(kk(1,1),auxmat(1,1))
9119 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9120 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9121
9122            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9123      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9124            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9125      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9126            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9127      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9128            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9129      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9130
9131       else
9132 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9133 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9134
9135            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9136      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9137            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9138      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9139            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9140      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9141            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9142      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9143
9144       endif
9145 c      call transpose2(a2(1,1),a2t(1,1))
9146
9147 crc      print *,transp
9148 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9149 crc      print *,((prod(i,j),i=1,2),j=1,2)
9150
9151       return
9152       end
9153