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