source/unres/src_MD-M/initialize_p.F

   1       block data
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.MCM'
   5       include 'COMMON.MD'
   6       data MovTypID
   7      &  /'pool','chain regrow','multi-bond','phi','theta','side chain',
   8      &   'total'/
   9 c Conversion from poises to molecular unit and the gas constant
  10       data cPoise /2.9361d0/, Rb /0.001986d0/
  11       end
  12 c--------------------------------------------------------------------------
  13       subroutine initialize
  14 C
  15 C Define constants and zero out tables.
  16 C
  17       implicit real*8 (a-h,o-z)
  18       include 'DIMENSIONS'
  19 #ifdef MPI
  20       include 'mpif.h'
  21 #endif
  22 #ifndef ISNAN
  23       external proc_proc
  24 #ifdef WINPGI
  25 cMS$ATTRIBUTES C ::  proc_proc
  26 #endif
  27 #endif
  28       include 'COMMON.IOUNITS'
  29       include 'COMMON.CHAIN'
  30       include 'COMMON.INTERACT'
  31       include 'COMMON.GEO'
  32       include 'COMMON.LOCAL'
  33       include 'COMMON.TORSION'
  34       include 'COMMON.FFIELD'
  35       include 'COMMON.SBRIDGE'
  36       include 'COMMON.MCM'
  37       include 'COMMON.MINIM'
  38       include 'COMMON.DERIV'
  39       include 'COMMON.SPLITELE'
  40 c Common blocks from the diagonalization routines
  41       COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
  42       COMMON /MACHSW/ KDIAG,ICORFL,IXDR
  43       logical mask_r
  44 c      real*8 text1 /'initial_i'/
  45
  46       mask_r=.false.
  47 #ifndef ISNAN
  48 c NaNQ initialization
  49       i=-1
  50       rr=dacos(100.0d0)
  51 #ifdef WINPGI
  52       idumm=proc_proc(rr,i)
  53 #else
  54       call proc_proc(rr,i)
  55 #endif
  56 #endif
  57
  58       kdiag=0
  59       icorfl=0
  60       iw=2
  61 C
  62 C The following is just to define auxiliary variables used in angle conversion
  63 C
  64       pi=4.0D0*datan(1.0D0)
  65       dwapi=2.0D0*pi
  66       dwapi3=dwapi/3.0D0
  67       pipol=0.5D0*pi
  68       deg2rad=pi/180.0D0
  69       rad2deg=1.0D0/deg2rad
  70       angmin=10.0D0*deg2rad
  71 C
  72 C Define I/O units.
  73 C
  74       inp=    1
  75       iout=   2
  76       ipdbin= 3
  77       ipdb=   7
  78       icart = 30
  79       imol2=  4
  80       igeom=  8
  81       intin=  9
  82       ithep= 11
  83       ithep_pdb=51
  84       irotam=12
  85       irotam_pdb=52
  86       itorp= 13
  87       itordp= 23
  88       ielep= 14
  89       isidep=15
  90       iscpp=25
  91       icbase=16
  92       ifourier=20
  93       istat= 17
  94       irest1=55
  95       irest2=56
  96       iifrag=57
  97       ientin=18
  98       ientout=19
  99       ibond = 28
 100       isccor = 29
 101 crc for write_rmsbank1
 102       izs1=21
 103 cdr  include secondary structure prediction bias
 104       isecpred=27
 105 C
 106 C CSA I/O units (separated from others especially for Jooyoung)
 107 C
 108       icsa_rbank=30
 109       icsa_seed=31
 110       icsa_history=32
 111       icsa_bank=33
 112       icsa_bank1=34
 113       icsa_alpha=35
 114       icsa_alpha1=36
 115       icsa_bankt=37
 116       icsa_int=39
 117       icsa_bank_reminimized=38
 118       icsa_native_int=41
 119       icsa_in=40
 120 crc for ifc error 118
 121       icsa_pdb=42
 122 C
 123 C Set default weights of the energy terms.
 124 C
 125       wlong=1.0D0
 126       welec=1.0D0
 127       wtor =1.0D0
 128       wang =1.0D0
 129       wscloc=1.0D0
 130       wstrain=1.0D0
 131 C
 132 C Zero out tables.
 133 C
 134 c      print '(a,$)','Inside initialize'
 135 c      call memmon_print_usage()
 136       do i=1,maxres2
 137         do j=1,3
 138           c(j,i)=0.0D0
 139           dc(j,i)=0.0D0
 140         enddo
 141       enddo
 142       do i=1,maxres
 143         do j=1,3
 144           xloc(j,i)=0.0D0
 145         enddo
 146       enddo
 147       do i=1,ntyp
 148         do j=1,ntyp
 149           aa(i,j)=0.0D0
 150           bb(i,j)=0.0D0
 151           augm(i,j)=0.0D0
 152           sigma(i,j)=0.0D0
 153           r0(i,j)=0.0D0
 154           chi(i,j)=0.0D0
 155         enddo
 156         do j=1,2
 157           bad(i,j)=0.0D0
 158         enddo
 159         chip(i)=0.0D0
 160         alp(i)=0.0D0
 161         sigma0(i)=0.0D0
 162         sigii(i)=0.0D0
 163         rr0(i)=0.0D0
 164         a0thet(i)=0.0D0
 165         do j=1,2
 166          do ichir1=-1,1
 167           do ichir2=-1,1
 168           athet(j,i,ichir1,ichir2)=0.0D0
 169           bthet(j,i,ichir1,ichir2)=0.0D0
 170           enddo
 171          enddo
 172         enddo
 173         do j=0,3
 174           polthet(j,i)=0.0D0
 175         enddo
 176         do j=1,3
 177           gthet(j,i)=0.0D0
 178         enddo
 179         theta0(i)=0.0D0
 180         sig0(i)=0.0D0
 181         sigc0(i)=0.0D0
 182         do j=1,maxlob
 183           bsc(j,i)=0.0D0
 184           do k=1,3
 185             censc(k,j,i)=0.0D0
 186           enddo
 187           do k=1,3
 188             do l=1,3
 189               gaussc(l,k,j,i)=0.0D0
 190             enddo
 191           enddo
 192           nlob(i)=0
 193         enddo
 194       enddo
 195       nlob(ntyp1)=0
 196       dsc(ntyp1)=0.0D0
 197       do i=-maxtor,maxtor
 198         itortyp(i)=0
 199 cc      write (iout,*) "TU DOCHODZE",i,itortyp(i)
 200        do iblock=1,2
 201         do j=-maxtor,maxtor
 202           do k=1,maxterm
 203             v1(k,j,i,iblock)=0.0D0
 204             v2(k,j,i,iblock)=0.0D0
 205           enddo
 206         enddo
 207         enddo
 208       enddo
 209       do iblock=1,2
 210        do i=-maxtor,maxtor
 211         do j=-maxtor,maxtor
 212          do k=-maxtor,maxtor
 213           do l=1,maxtermd_1
 214             v1c(1,l,i,j,k,iblock)=0.0D0
 215             v1s(1,l,i,j,k,iblock)=0.0D0
 216             v1c(2,l,i,j,k,iblock)=0.0D0
 217             v1s(2,l,i,j,k,iblock)=0.0D0
 218           enddo !l
 219           do l=1,maxtermd_2
 220            do m=1,maxtermd_2
 221             v2c(m,l,i,j,k,iblock)=0.0D0
 222             v2s(m,l,i,j,k,iblock)=0.0D0
 223            enddo !m
 224           enddo !l
 225         enddo !k
 226        enddo !j
 227       enddo !i
 228       enddo !iblock
 229
 230       do i=1,maxres
 231         itype(i)=0
 232         itel(i)=0
 233       enddo
 234 C Initialize the bridge arrays
 235       ns=0
 236       nss=0
 237       nhpb=0
 238       do i=1,maxss
 239         iss(i)=0
 240       enddo
 241       do i=1,maxdim
 242         dhpb(i)=0.0D0
 243       enddo
 244       do i=1,maxres
 245         ihpb(i)=0
 246         jhpb(i)=0
 247       enddo
 248 C Initialize correlation arrays
 249       do i=-maxtor,maxtor
 250        do k=1,2
 251         b1(k,i)=0.0
 252         b2(k,i)=0.0
 253         b1tilde(k,i)=0.0
 254 c        b2tilde(k,i)=0.0
 255         do j=1,2
 256         CC(j,k,i)=0.0
 257         Ctilde(j,k,i)=0.0
 258         DD(j,k,i)=0.0
 259         Dtilde(j,k,i)=0.0
 260         EE(j,k,i)=0.0
 261         enddo
 262        enddo
 263       enddo
 264 C
 265 C Initialize timing.
 266 C
 267       call set_timers
 268 C
 269 C Initialize variables used in minimization.
 270 C
 271 c     maxfun=5000
 272 c     maxit=2000
 273       maxfun=500
 274       maxit=200
 275       tolf=1.0D-2
 276       rtolf=5.0D-4
 277 C
 278 C Initialize the variables responsible for the mode of gradient storage.
 279 C
 280       nfl=0
 281       icg=1
 282 C
 283 C Initialize constants used to split the energy into long- and short-range
 284 C components
 285 C
 286 C      r_cut=2.0d0
 287 C      rlamb=0.3d0
 288 #ifndef SPLITELE
 289       nprint_ene=nprint_ene-1
 290 #endif
 291       return
 292       end
 293 c-------------------------------------------------------------------------
 294       block data nazwy
 295       implicit real*8 (a-h,o-z)
 296       include 'DIMENSIONS'
 297       include 'COMMON.NAMES'
 298       include 'COMMON.FFIELD'
 299       data restyp /
 300      &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL',
 301      & 'DSG','DGN','DSN','DTH',
 302      &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
 303      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 304      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ',
 305      &'AIB','ABU','D'/
 306       data onelet /
 307      &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g',
 308      &'a','y','w','v','l','i','f','m','c','x',
 309      &'C','M','F','I','L','V','W','Y','A','G','T',
 310      &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/
 311       data potname /'LJ','LJK','BP','GB','GBV'/
 312       data ename /
 313      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 314      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 315      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 316      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"/
 317       data wname /
 318      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 319      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 320      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR"/
 321       data nprint_ene /20/
 322       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 323      & 21,0/
 324       end
 325 c---------------------------------------------------------------------------
 326       subroutine init_int_table
 327       implicit real*8 (a-h,o-z)
 328       include 'DIMENSIONS'
 329 #ifdef MPI
 330       include 'mpif.h'
 331       integer blocklengths(15),displs(15)
 332 #endif
 333       include 'COMMON.CONTROL'
 334       include 'COMMON.SETUP'
 335       include 'COMMON.CHAIN'
 336       include 'COMMON.INTERACT'
 337       include 'COMMON.LOCAL'
 338       include 'COMMON.SBRIDGE'
 339       include 'COMMON.TORCNSTR'
 340       include 'COMMON.IOUNITS'
 341       include 'COMMON.DERIV'
 342       include 'COMMON.CONTACTS'
 343       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
 344      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
 345      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
 346      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
 347      & ielend_all(maxres,0:max_fg_procs-1),
 348      & ntask_cont_from_all(0:max_fg_procs-1),
 349      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 350      & ntask_cont_to_all(0:max_fg_procs-1),
 351      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 352       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 353       logical scheck,lprint,flag
 354 #ifdef MPI
 355       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 356      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 357 C... Determine the numbers of start and end SC-SC interaction
 358 C... to deal with by current processor.
 359       do i=0,nfgtasks-1
 360         itask_cont_from(i)=fg_rank
 361         itask_cont_to(i)=fg_rank
 362       enddo
 363       lprint=.false.
 364       if (lprint)
 365      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 366       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 367       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 368       if (lprint)
 369      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 370      &  ' absolute rank',MyRank,
 371      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 372      &  ' my_sc_inde',my_sc_inde
 373       ind_sctint=0
 374       iatsc_s=0
 375       iatsc_e=0
 376 #endif
 377 c      lprint=.false.
 378       do i=1,maxres
 379         nint_gr(i)=0
 380         nscp_gr(i)=0
 381         do j=1,maxint_gr
 382           istart(i,1)=0
 383           iend(i,1)=0
 384           ielstart(i)=0
 385           ielend(i)=0
 386           iscpstart(i,1)=0
 387           iscpend(i,1)=0
 388         enddo
 389       enddo
 390       ind_scint=0
 391       ind_scint_old=0
 392 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 393 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 394       do i=nnt,nct-1
 395         scheck=.false.
 396         if (dyn_ss) goto 10
 397         do ii=1,nss
 398           if (ihpb(ii).eq.i+nres) then
 399             scheck=.true.
 400             jj=jhpb(ii)-nres
 401             goto 10
 402           endif
 403         enddo
 404    10   continue
 405 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 406         if (scheck) then
 407           if (jj.eq.i+1) then
 408 #ifdef MPI
 409 c            write (iout,*) 'jj=i+1'
 410             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 411      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 412 #else
 413             nint_gr(i)=1
 414             istart(i,1)=i+2
 415             iend(i,1)=nct
 416 #endif
 417           else if (jj.eq.nct) then
 418 #ifdef MPI
 419 c            write (iout,*) 'jj=nct'
 420             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 421      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 422 #else
 423             nint_gr(i)=1
 424             istart(i,1)=i+1
 425             iend(i,1)=nct-1
 426 #endif
 427           else
 428 #ifdef MPI
 429             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 430      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 431             ii=nint_gr(i)+1
 432             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 433      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 434 #else
 435             nint_gr(i)=2
 436             istart(i,1)=i+1
 437             iend(i,1)=jj-1
 438             istart(i,2)=jj+1
 439             iend(i,2)=nct
 440 #endif
 441           endif
 442         else
 443 #ifdef MPI
 444           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 445      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 446 #else
 447           nint_gr(i)=1
 448           istart(i,1)=i+1
 449           iend(i,1)=nct
 450           ind_scint=ind_scint+nct-i
 451 #endif
 452         endif
 453 #ifdef MPI
 454         ind_scint_old=ind_scint
 455 #endif
 456       enddo
 457    12 continue
 458 #ifndef MPI
 459       iatsc_s=nnt
 460       iatsc_e=nct-1
 461 #endif
 462 #ifdef MPI
 463       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 464      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 465 #endif
 466       if (lprint) then
 467       write (iout,'(a)') 'Interaction array:'
 468       do i=iatsc_s,iatsc_e
 469         write (iout,'(i3,2(2x,2i3))')
 470      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 471       enddo
 472       endif
 473       ispp=4
 474 #ifdef MPI
 475 C Now partition the electrostatic-interaction array
 476       npept=nct-nnt
 477       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 478       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 479       if (lprint)
 480      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 481      &  ' absolute rank',MyRank,
 482      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 483      &               ' my_ele_inde',my_ele_inde
 484       iatel_s=0
 485       iatel_e=0
 486       ind_eleint=0
 487       ind_eleint_old=0
 488       do i=nnt,nct-3
 489         ijunk=0
 490         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 491      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 492       enddo ! i
 493    13 continue
 494       if (iatel_s.eq.0) iatel_s=1
 495       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 496 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 497       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 498 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 499 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 500       ind_eleint_vdw=0
 501       ind_eleint_vdw_old=0
 502       iatel_s_vdw=0
 503       iatel_e_vdw=0
 504       do i=nnt,nct-3
 505         ijunk=0
 506         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 507      &    my_ele_inde_vdw,i,
 508      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 509      &    ielend_vdw(i),*15)
 510 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 511 c     &   " ielend_vdw",ielend_vdw(i)
 512       enddo ! i
 513       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 514    15 continue
 515 #else
 516       iatel_s=nnt
 517       iatel_e=nct-5
 518       do i=iatel_s,iatel_e
 519         ielstart(i)=i+4
 520         ielend(i)=nct-1
 521       enddo
 522       iatel_s_vdw=nnt
 523       iatel_e_vdw=nct-3
 524       do i=iatel_s_vdw,iatel_e_vdw
 525         ielstart_vdw(i)=i+2
 526         ielend_vdw(i)=nct-1
 527       enddo
 528 #endif
 529       if (lprint) then
 530         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 531      &  ' absolute rank',MyRank
 532         write (iout,*) 'Electrostatic interaction array:'
 533         do i=iatel_s,iatel_e
 534           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 535         enddo
 536       endif ! lprint
 537 c     iscp=3
 538       iscp=2
 539 C Partition the SC-p interaction array
 540 #ifdef MPI
 541       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 542       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 543       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 544      &  ' absolute rank',myrank,
 545      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 546      &               ' my_scp_inde',my_scp_inde
 547       iatscp_s=0
 548       iatscp_e=0
 549       ind_scpint=0
 550       ind_scpint_old=0
 551       do i=nnt,nct-1
 552         if (i.lt.nnt+iscp) then
 553 cd        write (iout,*) 'i.le.nnt+iscp'
 554           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 555      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 556      &      iscpend(i,1),*14)
 557         else if (i.gt.nct-iscp) then
 558 cd        write (iout,*) 'i.gt.nct-iscp'
 559           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 560      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 561      &      iscpend(i,1),*14)
 562         else
 563           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 564      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 565      &      iscpend(i,1),*14)
 566           ii=nscp_gr(i)+1
 567           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 568      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 569      &      iscpend(i,ii),*14)
 570         endif
 571       enddo ! i
 572    14 continue
 573 #else
 574       iatscp_s=nnt
 575       iatscp_e=nct-1
 576       do i=nnt,nct-1
 577         if (i.lt.nnt+iscp) then
 578           nscp_gr(i)=1
 579           iscpstart(i,1)=i+iscp
 580           iscpend(i,1)=nct
 581         elseif (i.gt.nct-iscp) then
 582           nscp_gr(i)=1
 583           iscpstart(i,1)=nnt
 584           iscpend(i,1)=i-iscp
 585         else
 586           nscp_gr(i)=2
 587           iscpstart(i,1)=nnt
 588           iscpend(i,1)=i-iscp
 589           iscpstart(i,2)=i+iscp
 590           iscpend(i,2)=nct
 591         endif
 592       enddo ! i
 593 #endif
 594       if (lprint) then
 595         write (iout,'(a)') 'SC-p interaction array:'
 596         do i=iatscp_s,iatscp_e
 597           write (iout,'(i3,2(2x,2i3))')
 598      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 599         enddo
 600       endif ! lprint
 601 C Partition local interactions
 602 #ifdef MPI
 603       call int_bounds(nres-2,loc_start,loc_end)
 604       loc_start=loc_start+1
 605       loc_end=loc_end+1
 606       call int_bounds(nres-2,ithet_start,ithet_end)
 607       ithet_start=ithet_start+2
 608       ithet_end=ithet_end+2
 609       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 610       iturn3_start=iturn3_start+nnt
 611       iphi_start=iturn3_start+2
 612       iturn3_end=iturn3_end+nnt
 613       iphi_end=iturn3_end+2
 614       iturn3_start=iturn3_start-1
 615       iturn3_end=iturn3_end-1
 616       call int_bounds(nres-3,itau_start,itau_end)
 617       itau_start=itau_start+3
 618       itau_end=itau_end+3
 619       call int_bounds(nres-3,iphi1_start,iphi1_end)
 620       iphi1_start=iphi1_start+3
 621       iphi1_end=iphi1_end+3
 622       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 623       iturn4_start=iturn4_start+nnt
 624       iphid_start=iturn4_start+2
 625       iturn4_end=iturn4_end+nnt
 626       iphid_end=iturn4_end+2
 627       iturn4_start=iturn4_start-1
 628       iturn4_end=iturn4_end-1
 629       call int_bounds(nres-2,ibond_start,ibond_end)
 630       ibond_start=ibond_start+1
 631       ibond_end=ibond_end+1
 632       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 633       ibondp_start=ibondp_start+nnt
 634       ibondp_end=ibondp_end+nnt
 635       call int_bounds1(nres-1,ivec_start,ivec_end)
 636 c      print *,"Processor",myrank,fg_rank,fg_rank1,
 637 c     &  " ivec_start",ivec_start," ivec_end",ivec_end
 638       iset_start=loc_start+2
 639       iset_end=loc_end+2
 640       if (ndih_constr.eq.0) then
 641         idihconstr_start=1
 642         idihconstr_end=0
 643       else
 644         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 645       endif
 646 c      nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 647 c      nlen=nres-nnt+1
 648       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 649       nlen=nres-nnt+1
 650       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 651       igrad_start=((2*nlen+1)
 652      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 653       jgrad_start(igrad_start)=
 654      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 655      &    +igrad_start
 656       jgrad_end(igrad_start)=nres
 657       igrad_end=((2*nlen+1)
 658      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 659       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 660       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 661      &    +igrad_end
 662       do i=igrad_start+1,igrad_end-1
 663         jgrad_start(i)=i+1
 664         jgrad_end(i)=nres
 665       enddo
 666       if (lprint) then
 667         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 668      & ' absolute rank',myrank,
 669      & ' loc_start',loc_start,' loc_end',loc_end,
 670      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 671      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 672      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 673      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 674      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 675      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 676      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 677      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 678      & ' iset_start',iset_start,' iset_end',iset_end,
 679      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 680      &   idihconstr_end
 681        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 682      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 683      &   ' ngrad_end',ngrad_end
 684        do i=igrad_start,igrad_end
 685          write(*,*) 'Processor:',fg_rank,myrank,i,
 686      &    jgrad_start(i),jgrad_end(i)
 687        enddo
 688       endif
 689       if (nfgtasks.gt.1) then
 690         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 691      &    MPI_INTEGER,FG_COMM1,IERROR)
 692         iaux=ivec_end-ivec_start+1
 693         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 694      &    MPI_INTEGER,FG_COMM1,IERROR)
 695         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 696      &    MPI_INTEGER,FG_COMM,IERROR)
 697         iaux=iset_end-iset_start+1
 698         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 699      &    MPI_INTEGER,FG_COMM,IERROR)
 700         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 701      &    MPI_INTEGER,FG_COMM,IERROR)
 702         iaux=ibond_end-ibond_start+1
 703         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 704      &    MPI_INTEGER,FG_COMM,IERROR)
 705         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 706      &    MPI_INTEGER,FG_COMM,IERROR)
 707         iaux=ithet_end-ithet_start+1
 708         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 709      &    MPI_INTEGER,FG_COMM,IERROR)
 710         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 711      &    MPI_INTEGER,FG_COMM,IERROR)
 712         iaux=iphi_end-iphi_start+1
 713         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 714      &    MPI_INTEGER,FG_COMM,IERROR)
 715         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 716      &    MPI_INTEGER,FG_COMM,IERROR)
 717         iaux=iphi1_end-iphi1_start+1
 718         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 719      &    MPI_INTEGER,FG_COMM,IERROR)
 720         do i=0,maxprocs-1
 721           do j=1,maxres
 722             ielstart_all(j,i)=0
 723             ielend_all(j,i)=0
 724           enddo
 725         enddo
 726         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 727      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 728         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 729      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 730         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 731      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 732         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 733      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 734         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 735      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 736         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 737      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 738         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 739      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 740         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 741      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 742         if (lprint) then
 743         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 744         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 745         write (iout,*) "iturn3_start_all",
 746      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 747         write (iout,*) "iturn3_end_all",
 748      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 749         write (iout,*) "iturn4_start_all",
 750      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 751         write (iout,*) "iturn4_end_all",
 752      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 753         write (iout,*) "The ielstart_all array"
 754         do i=nnt,nct
 755           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 756         enddo
 757         write (iout,*) "The ielend_all array"
 758         do i=nnt,nct
 759           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 760         enddo
 761         call flush(iout)
 762         endif
 763         ntask_cont_from=0
 764         ntask_cont_to=0
 765         itask_cont_from(0)=fg_rank
 766         itask_cont_to(0)=fg_rank
 767         flag=.false.
 768         do ii=iturn3_start,iturn3_end
 769           call add_int(ii,ii+2,iturn3_sent(1,ii),
 770      &                 ntask_cont_to,itask_cont_to,flag)
 771         enddo
 772         do ii=iturn4_start,iturn4_end
 773           call add_int(ii,ii+3,iturn4_sent(1,ii),
 774      &                 ntask_cont_to,itask_cont_to,flag)
 775         enddo
 776         do ii=iturn3_start,iturn3_end
 777           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 778         enddo
 779         do ii=iturn4_start,iturn4_end
 780           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 781         enddo
 782         if (lprint) then
 783         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 784      &   " ntask_cont_to",ntask_cont_to
 785         write (iout,*) "itask_cont_from",
 786      &    (itask_cont_from(i),i=1,ntask_cont_from)
 787         write (iout,*) "itask_cont_to",
 788      &    (itask_cont_to(i),i=1,ntask_cont_to)
 789         call flush(iout)
 790         endif
 791 c        write (iout,*) "Loop forward"
 792 c        call flush(iout)
 793         do i=iatel_s,iatel_e
 794 c          write (iout,*) "from loop i=",i
 795 c          call flush(iout)
 796           do j=ielstart(i),ielend(i)
 797             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 798           enddo
 799         enddo
 800 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 801 c     &     " iatel_e",iatel_e
 802 c        call flush(iout)
 803         nat_sent=0
 804         do i=iatel_s,iatel_e
 805 c          write (iout,*) "i",i," ielstart",ielstart(i),
 806 c     &      " ielend",ielend(i)
 807 c          call flush(iout)
 808           flag=.false.
 809           do j=ielstart(i),ielend(i)
 810             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 811      &                   itask_cont_to,flag)
 812           enddo
 813           if (flag) then
 814             nat_sent=nat_sent+1
 815             iat_sent(nat_sent)=i
 816           endif
 817         enddo
 818         if (lprint) then
 819         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 820      &   " ntask_cont_to",ntask_cont_to
 821         write (iout,*) "itask_cont_from",
 822      &    (itask_cont_from(i),i=1,ntask_cont_from)
 823         write (iout,*) "itask_cont_to",
 824      &    (itask_cont_to(i),i=1,ntask_cont_to)
 825         call flush(iout)
 826         write (iout,*) "iint_sent"
 827         do i=1,nat_sent
 828           ii=iat_sent(i)
 829           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 830      &      j=ielstart(ii),ielend(ii))
 831         enddo
 832         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 833      &    " iturn3_end",iturn3_end
 834         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 835      &      i=iturn3_start,iturn3_end)
 836         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 837      &    " iturn4_end",iturn4_end
 838         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 839      &      i=iturn4_start,iturn4_end)
 840         call flush(iout)
 841         endif
 842         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 843      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 844 c        write (iout,*) "Gather ntask_cont_from ended"
 845 c        call flush(iout)
 846         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 847      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 848      &   FG_COMM,IERR)
 849 c        write (iout,*) "Gather itask_cont_from ended"
 850 c        call flush(iout)
 851         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 852      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 853 c        write (iout,*) "Gather ntask_cont_to ended"
 854 c        call flush(iout)
 855         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 856      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 857 c        write (iout,*) "Gather itask_cont_to ended"
 858 c        call flush(iout)
 859         if (fg_rank.eq.king) then
 860           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 861           do i=0,nfgtasks-1
 862             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 863      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 864           enddo
 865           write (iout,*)
 866           call flush(iout)
 867           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 868           do i=0,nfgtasks-1
 869             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 870      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 871           enddo
 872           write (iout,*)
 873           call flush(iout)
 874 C Check if every send will have a matching receive
 875           ncheck_to=0
 876           ncheck_from=0
 877           do i=0,nfgtasks-1
 878             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 879             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 880           enddo
 881           write (iout,*) "Control sums",ncheck_from,ncheck_to
 882           if (ncheck_from.ne.ncheck_to) then
 883             write (iout,*) "Error: #receive differs from #send."
 884             write (iout,*) "Terminating program...!"
 885             call flush(iout)
 886             flag=.false.
 887           else
 888             flag=.true.
 889             do i=0,nfgtasks-1
 890               do j=1,ntask_cont_to_all(i)
 891                 ii=itask_cont_to_all(j,i)
 892                 do k=1,ntask_cont_from_all(ii)
 893                   if (itask_cont_from_all(k,ii).eq.i) then
 894                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 895                     exit
 896                   endif
 897                 enddo
 898                 if (k.eq.ntask_cont_from_all(ii)+1) then
 899                   flag=.false.
 900                   write (iout,*) "Error: send by",j," to",ii,
 901      &            " would have no matching receive"
 902                 endif
 903               enddo
 904             enddo
 905           endif
 906           if (.not.flag) then
 907             write (iout,*) "Unmatched sends; terminating program"
 908             call flush(iout)
 909           endif
 910         endif
 911         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 912 c        write (iout,*) "flag broadcast ended flag=",flag
 913 c        call flush(iout)
 914         if (.not.flag) then
 915           call MPI_Finalize(IERROR)
 916           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 917         endif
 918         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 919 c        write (iout,*) "MPI_Comm_group ended"
 920 c        call flush(iout)
 921         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 922      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 923         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 924      &    CONT_TO_GROUP,IERR)
 925         do i=1,nat_sent
 926           ii=iat_sent(i)
 927           iaux=4*(ielend(ii)-ielstart(ii)+1)
 928           call MPI_Group_translate_ranks(fg_group,iaux,
 929      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 930      &      iint_sent_local(1,ielstart(ii),i),IERR )
 931 c          write (iout,*) "Ranks translated i=",i
 932 c          call flush(iout)
 933         enddo
 934         iaux=4*(iturn3_end-iturn3_start+1)
 935         call MPI_Group_translate_ranks(fg_group,iaux,
 936      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 937      &      iturn3_sent_local(1,iturn3_start),IERR)
 938         iaux=4*(iturn4_end-iturn4_start+1)
 939         call MPI_Group_translate_ranks(fg_group,iaux,
 940      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 941      &      iturn4_sent_local(1,iturn4_start),IERR)
 942         if (lprint) then
 943         write (iout,*) "iint_sent_local"
 944         do i=1,nat_sent
 945           ii=iat_sent(i)
 946           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 947      &      j=ielstart(ii),ielend(ii))
 948           call flush(iout)
 949         enddo
 950         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 951      &    " iturn3_end",iturn3_end
 952         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 953      &      i=iturn3_start,iturn3_end)
 954         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 955      &    " iturn4_end",iturn4_end
 956         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 957      &      i=iturn4_start,iturn4_end)
 958         call flush(iout)
 959         endif
 960         call MPI_Group_free(fg_group,ierr)
 961         call MPI_Group_free(cont_from_group,ierr)
 962         call MPI_Group_free(cont_to_group,ierr)
 963         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 964         call MPI_Type_commit(MPI_UYZ,IERROR)
 965         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 966      &    IERROR)
 967         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 968         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 969         call MPI_Type_commit(MPI_MU,IERROR)
 970         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 971         call MPI_Type_commit(MPI_MAT1,IERROR)
 972         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 973         call MPI_Type_commit(MPI_MAT2,IERROR)
 974         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 975         call MPI_Type_commit(MPI_THET,IERROR)
 976         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 977         call MPI_Type_commit(MPI_GAM,IERROR)
 978 #ifndef MATGATHER
 979 c 9/22/08 Derived types to send matrices which appear in correlation terms
 980         do i=0,nfgtasks-1
 981           if (ivec_count(i).eq.ivec_count(0)) then
 982             lentyp(i)=0
 983           else
 984             lentyp(i)=1
 985           endif
 986         enddo
 987         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 988         if (ind_typ.eq.0) then
 989           ichunk=ivec_count(0)
 990         else
 991           ichunk=ivec_count(1)
 992         endif
 993 c        do i=1,4
 994 c          blocklengths(i)=4
 995 c        enddo
 996 c        displs(1)=0
 997 c        do i=2,4
 998 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 999 c        enddo
1000 c        do i=1,4
1001 c          blocklengths(i)=blocklengths(i)*ichunk
1002 c        enddo
1003 c        write (iout,*) "blocklengths and displs"
1004 c        do i=1,4
1005 c          write (iout,*) i,blocklengths(i),displs(i)
1006 c        enddo
1007 c        call flush(iout)
1008 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1009 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
1010 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
1011 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
1012 c        do i=1,4
1013 c          blocklengths(i)=2
1014 c        enddo
1015 c        displs(1)=0
1016 c        do i=2,4
1017 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1018 c        enddo
1019 c        do i=1,4
1020 c          blocklengths(i)=blocklengths(i)*ichunk
1021 c        enddo
1022 c        write (iout,*) "blocklengths and displs"
1023 c        do i=1,4
1024 c          write (iout,*) i,blocklengths(i),displs(i)
1025 c        enddo
1026 c        call flush(iout)
1027 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
1028 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
1029 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
1030 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
1031         do i=1,8
1032           blocklengths(i)=2
1033         enddo
1034         displs(1)=0
1035         do i=2,8
1036           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1037         enddo
1038         do i=1,15
1039           blocklengths(i)=blocklengths(i)*ichunk
1040         enddo
1041         call MPI_Type_indexed(8,blocklengths,displs,
1042      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1043         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1044         do i=1,8
1045           blocklengths(i)=4
1046         enddo
1047         displs(1)=0
1048         do i=2,8
1049           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1050         enddo
1051         do i=1,15
1052           blocklengths(i)=blocklengths(i)*ichunk
1053         enddo
1054         call MPI_Type_indexed(8,blocklengths,displs,
1055      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1056         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1057         do i=1,6
1058           blocklengths(i)=4
1059         enddo
1060         displs(1)=0
1061         do i=2,6
1062           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1063         enddo
1064         do i=1,6
1065           blocklengths(i)=blocklengths(i)*ichunk
1066         enddo
1067         call MPI_Type_indexed(6,blocklengths,displs,
1068      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1069         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1070         do i=1,2
1071           blocklengths(i)=8
1072         enddo
1073         displs(1)=0
1074         do i=2,2
1075           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1076         enddo
1077         do i=1,2
1078           blocklengths(i)=blocklengths(i)*ichunk
1079         enddo
1080         call MPI_Type_indexed(2,blocklengths,displs,
1081      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1082         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1083         do i=1,4
1084           blocklengths(i)=1
1085         enddo
1086         displs(1)=0
1087         do i=2,4
1088           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1089         enddo
1090         do i=1,4
1091           blocklengths(i)=blocklengths(i)*ichunk
1092         enddo
1093         call MPI_Type_indexed(4,blocklengths,displs,
1094      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1095         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1096         enddo
1097 #endif
1098       endif
1099       iint_start=ivec_start+1
1100       iint_end=ivec_end+1
1101       do i=0,nfgtasks-1
1102           iint_count(i)=ivec_count(i)
1103           iint_displ(i)=ivec_displ(i)
1104           ivec_displ(i)=ivec_displ(i)-1
1105           iset_displ(i)=iset_displ(i)-1
1106           ithet_displ(i)=ithet_displ(i)-1
1107           iphi_displ(i)=iphi_displ(i)-1
1108           iphi1_displ(i)=iphi1_displ(i)-1
1109           ibond_displ(i)=ibond_displ(i)-1
1110       enddo
1111       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1112      &     .and. (me.eq.0 .or. .not. out1file)) then
1113         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1114         do i=0,nfgtasks-1
1115           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1116      &      iset_count(i)
1117         enddo
1118         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1119      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1120         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1121         do i=0,nfgtasks-1
1122           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1123      &      iphi1_displ(i)
1124         enddo
1125         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1126      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1127      & ' SC-p interactions','were distributed among',nfgtasks,
1128      & ' fine-grain processors.'
1129       endif
1130 #else
1131       loc_start=2
1132       loc_end=nres-1
1133       ithet_start=3
1134       ithet_end=nres
1135       iturn3_start=nnt
1136       iturn3_end=nct-3
1137       iturn4_start=nnt
1138       iturn4_end=nct-4
1139       iphi_start=nnt+3
1140       iphi_end=nct
1141       iphi1_start=4
1142       iphi1_end=nres
1143       idihconstr_start=1
1144       idihconstr_end=ndih_constr
1145       iphid_start=iphi_start
1146       iphid_end=iphi_end-1
1147       itau_start=4
1148       itau_end=nres
1149       ibond_start=2
1150       ibond_end=nres-1
1151       ibondp_start=nnt
1152       ibondp_end=nct-1
1153       ivec_start=1
1154       ivec_end=nres-1
1155       iset_start=3
1156       iset_end=nres+1
1157       iint_start=2
1158       iint_end=nres-1
1159 #endif
1160       return
1161       end
1162 #ifdef MPI
1163 c---------------------------------------------------------------------------
1164       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1165       implicit none
1166       include "DIMENSIONS"
1167       include "COMMON.INTERACT"
1168       include "COMMON.SETUP"
1169       include "COMMON.IOUNITS"
1170       integer ii,jj,itask(4),ntask_cont_to,
1171      &itask_cont_to(0:max_fg_procs-1)
1172       logical flag
1173       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1174      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1175       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1176      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1177      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1178      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1179      & ielend_all(maxres,0:max_fg_procs-1)
1180       integer iproc,isent,k,l
1181 c Determines whether to send interaction ii,jj to other processors; a given
1182 c interaction can be sent to at most 2 processors.
1183 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1184 c one processor, otherwise flag is unchanged from the input value.
1185       isent=0
1186       itask(1)=fg_rank
1187       itask(2)=fg_rank
1188       itask(3)=fg_rank
1189       itask(4)=fg_rank
1190 c      write (iout,*) "ii",ii," jj",jj
1191 c Loop over processors to check if anybody could need interaction ii,jj
1192       do iproc=0,fg_rank-1
1193 c Check if the interaction matches any turn3 at iproc
1194         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1195           l=k+2
1196           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1197      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1198      &    then
1199 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1200 c            call flush(iout)
1201             flag=.true.
1202             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1203      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1204               isent=isent+1
1205               itask(isent)=iproc
1206               call add_task(iproc,ntask_cont_to,itask_cont_to)
1207             endif
1208           endif
1209         enddo
1210 C Check if the interaction matches any turn4 at iproc
1211         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1212           l=k+3
1213           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1214      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1215      &    then
1216 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1217 c            call flush(iout)
1218             flag=.true.
1219             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1220      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1221               isent=isent+1
1222               itask(isent)=iproc
1223               call add_task(iproc,ntask_cont_to,itask_cont_to)
1224             endif
1225           endif
1226         enddo
1227         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1228      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1229           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1230      &        ielend_all(ii-1,iproc).ge.jj-1) then
1231             flag=.true.
1232             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1233      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1234               isent=isent+1
1235               itask(isent)=iproc
1236               call add_task(iproc,ntask_cont_to,itask_cont_to)
1237             endif
1238           endif
1239           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1240      &        ielend_all(ii-1,iproc).ge.jj+1) then
1241             flag=.true.
1242             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1243      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1244               isent=isent+1
1245               itask(isent)=iproc
1246               call add_task(iproc,ntask_cont_to,itask_cont_to)
1247             endif
1248           endif
1249         endif
1250       enddo
1251       return
1252       end
1253 c---------------------------------------------------------------------------
1254       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1255       implicit none
1256       include "DIMENSIONS"
1257       include "COMMON.INTERACT"
1258       include "COMMON.SETUP"
1259       include "COMMON.IOUNITS"
1260       integer ii,jj,itask(2),ntask_cont_from,
1261      & itask_cont_from(0:max_fg_procs-1)
1262       logical flag
1263       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1264      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1265       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1266      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1267      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1268      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1269      & ielend_all(maxres,0:max_fg_procs-1)
1270       integer iproc,k,l
1271       do iproc=fg_rank+1,nfgtasks-1
1272         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1273           l=k+2
1274           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1275      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1276      &    then
1277 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1278             call add_task(iproc,ntask_cont_from,itask_cont_from)
1279           endif
1280         enddo
1281         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1282           l=k+3
1283           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1284      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1285      &    then
1286 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1287             call add_task(iproc,ntask_cont_from,itask_cont_from)
1288           endif
1289         enddo
1290         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1291           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1292      &    then
1293             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1294      &          jj+1.le.ielend_all(ii+1,iproc)) then
1295               call add_task(iproc,ntask_cont_from,itask_cont_from)
1296             endif
1297             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1298      &          jj-1.le.ielend_all(ii+1,iproc)) then
1299               call add_task(iproc,ntask_cont_from,itask_cont_from)
1300             endif
1301           endif
1302           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1303      &    then
1304             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1305      &          jj-1.le.ielend_all(ii-1,iproc)) then
1306               call add_task(iproc,ntask_cont_from,itask_cont_from)
1307             endif
1308             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1309      &          jj+1.le.ielend_all(ii-1,iproc)) then
1310                call add_task(iproc,ntask_cont_from,itask_cont_from)
1311             endif
1312           endif
1313         endif
1314       enddo
1315       return
1316       end
1317 c---------------------------------------------------------------------------
1318       subroutine add_task(iproc,ntask_cont,itask_cont)
1319       implicit none
1320       include "DIMENSIONS"
1321       integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1322       integer ii
1323       do ii=1,ntask_cont
1324         if (itask_cont(ii).eq.iproc) return
1325       enddo
1326       ntask_cont=ntask_cont+1
1327       itask_cont(ntask_cont)=iproc
1328       return
1329       end
1330 c---------------------------------------------------------------------------
1331       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1332       implicit real*8 (a-h,o-z)
1333       include 'DIMENSIONS'
1334       include 'mpif.h'
1335       include 'COMMON.SETUP'
1336       integer total_ints,lower_bound,upper_bound
1337       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1338       nint=total_ints/nfgtasks
1339       do i=1,nfgtasks
1340         int4proc(i-1)=nint
1341       enddo
1342       nexcess=total_ints-nint*nfgtasks
1343       do i=1,nexcess
1344         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1345       enddo
1346       lower_bound=0
1347       do i=0,fg_rank-1
1348         lower_bound=lower_bound+int4proc(i)
1349       enddo
1350       upper_bound=lower_bound+int4proc(fg_rank)
1351       lower_bound=lower_bound+1
1352       return
1353       end
1354 c---------------------------------------------------------------------------
1355       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1356       implicit real*8 (a-h,o-z)
1357       include 'DIMENSIONS'
1358       include 'mpif.h'
1359       include 'COMMON.SETUP'
1360       integer total_ints,lower_bound,upper_bound
1361       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1362       nint=total_ints/nfgtasks1
1363       do i=1,nfgtasks1
1364         int4proc(i-1)=nint
1365       enddo
1366       nexcess=total_ints-nint*nfgtasks1
1367       do i=1,nexcess
1368         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1369       enddo
1370       lower_bound=0
1371       do i=0,fg_rank1-1
1372         lower_bound=lower_bound+int4proc(i)
1373       enddo
1374       upper_bound=lower_bound+int4proc(fg_rank1)
1375       lower_bound=lower_bound+1
1376       return
1377       end
1378 c---------------------------------------------------------------------------
1379       subroutine int_partition(int_index,lower_index,upper_index,atom,
1380      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1381       implicit real*8 (a-h,o-z)
1382       include 'DIMENSIONS'
1383       include 'COMMON.IOUNITS'
1384       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1385      & first_atom,last_atom,int_gr,jat_start,jat_end
1386       logical lprn
1387       lprn=.false.
1388       if (lprn) write (iout,*) 'int_index=',int_index
1389       int_index_old=int_index
1390       int_index=int_index+last_atom-first_atom+1
1391       if (lprn)
1392      &   write (iout,*) 'int_index=',int_index,
1393      &               ' int_index_old',int_index_old,
1394      &               ' lower_index=',lower_index,
1395      &               ' upper_index=',upper_index,
1396      &               ' atom=',atom,' first_atom=',first_atom,
1397      &               ' last_atom=',last_atom
1398       if (int_index.ge.lower_index) then
1399         int_gr=int_gr+1
1400         if (at_start.eq.0) then
1401           at_start=atom
1402           jat_start=first_atom-1+lower_index-int_index_old
1403         else
1404           jat_start=first_atom
1405         endif
1406         if (lprn) write (iout,*) 'jat_start',jat_start
1407         if (int_index.ge.upper_index) then
1408           at_end=atom
1409           jat_end=first_atom-1+upper_index-int_index_old
1410           return1
1411         else
1412           jat_end=last_atom
1413         endif
1414         if (lprn) write (iout,*) 'jat_end',jat_end
1415       endif
1416       return
1417       end
1418 #endif
1419 c------------------------------------------------------------------------------
1420       subroutine hpb_partition
1421       implicit real*8 (a-h,o-z)
1422       include 'DIMENSIONS'
1423 #ifdef MPI
1424       include 'mpif.h'
1425 #endif
1426       include 'COMMON.SBRIDGE'
1427       include 'COMMON.IOUNITS'
1428       include 'COMMON.SETUP'
1429 #ifdef MPI
1430       call int_bounds(nhpb,link_start,link_end)
1431       write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1432      &  ' absolute rank',MyRank,
1433      &  ' nhpb',nhpb,' link_start=',link_start,
1434      &  ' link_end',link_end
1435 #else
1436       link_start=1
1437       link_end=nhpb
1438 #endif
1439       return
1440       end