source/unres/src_CSA_DiL/initialize_p.F

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