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      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 279      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
 280       data onelet /
 281      &'C','M','F','I','L','V','W','Y','A','G','T',
 282      &'S','Q','N','E','D','H','R','K','P','X'/
 283       data potname /'LJ','LJK','BP','GB','GBV'/
 284       data ename /
 285      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 286      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 287      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 288      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"," "," ",
 289      &   "DFA DIS","DFA TOR","DFA NEI","DFA BET"/
 290       data wname /
 291      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 292      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 293      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR",
 294      &   " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/
 295       data nprint_ene /24/
 296       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 297      & 21,24,25,26,27,0,0,0/
 298       end
 299 c---------------------------------------------------------------------------
 300       subroutine init_int_table
 301       implicit real*8 (a-h,o-z)
 302       include 'DIMENSIONS'
 303 #ifdef MPI
 304       include 'mpif.h'
 305       integer blocklengths(15),displs(15)
 306 #endif
 307       include 'COMMON.CONTROL'
 308       include 'COMMON.SETUP'
 309       include 'COMMON.CHAIN'
 310       include 'COMMON.INTERACT'
 311       include 'COMMON.LOCAL'
 312       include 'COMMON.SBRIDGE'
 313       include 'COMMON.TORCNSTR'
 314       include 'COMMON.IOUNITS'
 315       include 'COMMON.DERIV'
 316       include 'COMMON.CONTACTS'
 317       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
 318      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
 319      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
 320      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
 321      & ielend_all(maxres,0:MaxProcs-1),
 322      & ntask_cont_from_all(0:max_fg_procs-1),
 323      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 324      & ntask_cont_to_all(0:max_fg_procs-1),
 325      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 326       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 327       logical scheck,lprint,flag
 328 #ifdef MPI
 329       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 330      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 331 C... Determine the numbers of start and end SC-SC interaction
 332 C... to deal with by current processor.
 333       do i=0,nfgtasks-1
 334         itask_cont_from(i)=fg_rank
 335         itask_cont_to(i)=fg_rank
 336       enddo
 337       lprint=.false.
 338       if (lprint)
 339      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 340       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 341       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 342       if (lprint)
 343      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 344      &  ' absolute rank',MyRank,
 345      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 346      &  ' my_sc_inde',my_sc_inde
 347       ind_sctint=0
 348       iatsc_s=0
 349       iatsc_e=0
 350 #endif
 351 c      lprint=.false.
 352       do i=1,maxres
 353         nint_gr(i)=0
 354         nscp_gr(i)=0
 355         do j=1,maxint_gr
 356           istart(i,1)=0
 357           iend(i,1)=0
 358           ielstart(i)=0
 359           ielend(i)=0
 360           iscpstart(i,1)=0
 361           iscpend(i,1)=0
 362         enddo
 363       enddo
 364       ind_scint=0
 365       ind_scint_old=0
 366 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 367 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 368       do i=nnt,nct-1
 369         scheck=.false.
 370         do ii=1,nss
 371           if (ihpb(ii).eq.i+nres) then
 372             scheck=.true.
 373             jj=jhpb(ii)-nres
 374             goto 10
 375           endif
 376         enddo
 377    10   continue
 378 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 379         if (scheck) then
 380           if (jj.eq.i+1) then
 381 #ifdef MPI
 382 c            write (iout,*) 'jj=i+1'
 383             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 384      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 385 #else
 386             nint_gr(i)=1
 387             istart(i,1)=i+2
 388             iend(i,1)=nct
 389 #endif
 390           else if (jj.eq.nct) then
 391 #ifdef MPI
 392 c            write (iout,*) 'jj=nct'
 393             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 394      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 395 #else
 396             nint_gr(i)=1
 397             istart(i,1)=i+1
 398             iend(i,1)=nct-1
 399 #endif
 400           else
 401 #ifdef MPI
 402             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 403      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 404             ii=nint_gr(i)+1
 405             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 406      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 407 #else
 408             nint_gr(i)=2
 409             istart(i,1)=i+1
 410             iend(i,1)=jj-1
 411             istart(i,2)=jj+1
 412             iend(i,2)=nct
 413 #endif
 414           endif
 415         else
 416 #ifdef MPI
 417           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 418      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 419 #else
 420           nint_gr(i)=1
 421           istart(i,1)=i+1
 422           iend(i,1)=nct
 423           ind_scint=ind_scint+nct-i
 424 #endif
 425         endif
 426 #ifdef MPI
 427         ind_scint_old=ind_scint
 428 #endif
 429       enddo
 430    12 continue
 431 #ifndef MPI
 432       iatsc_s=nnt
 433       iatsc_e=nct-1
 434 #endif
 435 #ifdef MPI
 436       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 437      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 438 #endif
 439       if (lprint) then
 440       write (iout,'(a)') 'Interaction array:'
 441       do i=iatsc_s,iatsc_e
 442         write (iout,'(i3,2(2x,2i3))')
 443      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 444       enddo
 445       endif
 446       ispp=4
 447 #ifdef MPI
 448 C Now partition the electrostatic-interaction array
 449       npept=nct-nnt
 450       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 451       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 452       if (lprint)
 453      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 454      &  ' absolute rank',MyRank,
 455      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 456      &               ' my_ele_inde',my_ele_inde
 457       iatel_s=0
 458       iatel_e=0
 459       ind_eleint=0
 460       ind_eleint_old=0
 461       do i=nnt,nct-3
 462         ijunk=0
 463         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 464      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 465       enddo ! i
 466    13 continue
 467       if (iatel_s.eq.0) iatel_s=1
 468       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 469 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 470       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 471 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 472 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 473       ind_eleint_vdw=0
 474       ind_eleint_vdw_old=0
 475       iatel_s_vdw=0
 476       iatel_e_vdw=0
 477       do i=nnt,nct-3
 478         ijunk=0
 479         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 480      &    my_ele_inde_vdw,i,
 481      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 482      &    ielend_vdw(i),*15)
 483 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 484 c     &   " ielend_vdw",ielend_vdw(i)
 485       enddo ! i
 486       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 487    15 continue
 488 #else
 489       iatel_s=nnt
 490       iatel_e=nct-5
 491       do i=iatel_s,iatel_e
 492         ielstart(i)=i+4
 493         ielend(i)=nct-1
 494       enddo
 495       iatel_s_vdw=nnt
 496       iatel_e_vdw=nct-3
 497       do i=iatel_s_vdw,iatel_e_vdw
 498         ielstart_vdw(i)=i+2
 499         ielend_vdw(i)=nct-1
 500       enddo
 501 #endif
 502       if (lprint) then
 503         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 504      &  ' absolute rank',MyRank
 505         write (iout,*) 'Electrostatic interaction array:'
 506         do i=iatel_s,iatel_e
 507           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 508         enddo
 509       endif ! lprint
 510 c     iscp=3
 511       iscp=2
 512 C Partition the SC-p interaction array
 513 #ifdef MPI
 514       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 515       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 516       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 517      &  ' absolute rank',myrank,
 518      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 519      &               ' my_scp_inde',my_scp_inde
 520       iatscp_s=0
 521       iatscp_e=0
 522       ind_scpint=0
 523       ind_scpint_old=0
 524       do i=nnt,nct-1
 525         if (i.lt.nnt+iscp) then
 526 cd        write (iout,*) 'i.le.nnt+iscp'
 527           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 528      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 529      &      iscpend(i,1),*14)
 530         else if (i.gt.nct-iscp) then
 531 cd        write (iout,*) 'i.gt.nct-iscp'
 532           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 533      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 534      &      iscpend(i,1),*14)
 535         else
 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           ii=nscp_gr(i)+1
 540           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 541      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 542      &      iscpend(i,ii),*14)
 543         endif
 544       enddo ! i
 545    14 continue
 546 #else
 547       iatscp_s=nnt
 548       iatscp_e=nct-1
 549       do i=nnt,nct-1
 550         if (i.lt.nnt+iscp) then
 551           nscp_gr(i)=1
 552           iscpstart(i,1)=i+iscp
 553           iscpend(i,1)=nct
 554         elseif (i.gt.nct-iscp) then
 555           nscp_gr(i)=1
 556           iscpstart(i,1)=nnt
 557           iscpend(i,1)=i-iscp
 558         else
 559           nscp_gr(i)=2
 560           iscpstart(i,1)=nnt
 561           iscpend(i,1)=i-iscp
 562           iscpstart(i,2)=i+iscp
 563           iscpend(i,2)=nct
 564         endif
 565       enddo ! i
 566 #endif
 567       if (lprint) then
 568         write (iout,'(a)') 'SC-p interaction array:'
 569         do i=iatscp_s,iatscp_e
 570           write (iout,'(i3,2(2x,2i3))')
 571      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 572         enddo
 573       endif ! lprint
 574 C Partition local interactions
 575 #ifdef MPI
 576       call int_bounds(nres-2,loc_start,loc_end)
 577       loc_start=loc_start+1
 578       loc_end=loc_end+1
 579       call int_bounds(nres-2,ithet_start,ithet_end)
 580       ithet_start=ithet_start+2
 581       ithet_end=ithet_end+2
 582       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 583       iturn3_start=iturn3_start+nnt
 584       iphi_start=iturn3_start+2
 585       iturn3_end=iturn3_end+nnt
 586       iphi_end=iturn3_end+2
 587       iturn3_start=iturn3_start-1
 588       iturn3_end=iturn3_end-1
 589       call int_bounds(nres-3,iphi1_start,iphi1_end)
 590       iphi1_start=iphi1_start+3
 591       iphi1_end=iphi1_end+3
 592       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 593       iturn4_start=iturn4_start+nnt
 594       iphid_start=iturn4_start+2
 595       iturn4_end=iturn4_end+nnt
 596       iphid_end=iturn4_end+2
 597       iturn4_start=iturn4_start-1
 598       iturn4_end=iturn4_end-1
 599       call int_bounds(nres-2,ibond_start,ibond_end)
 600       ibond_start=ibond_start+1
 601       ibond_end=ibond_end+1
 602       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 603       ibondp_start=ibondp_start+nnt
 604       ibondp_end=ibondp_end+nnt
 605       call int_bounds1(nres-1,ivec_start,ivec_end)
 606       print *,"Processor",myrank,fg_rank,fg_rank1,
 607      &  " ivec_start",ivec_start," ivec_end",ivec_end
 608       iset_start=loc_start+2
 609       iset_end=loc_end+2
 610       if (ndih_constr.eq.0) then
 611         idihconstr_start=1
 612         idihconstr_end=0
 613       else
 614         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 615       endif
 616       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 617       nlen=nres-nnt+1
 618       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 619       igrad_start=((2*nlen+1)
 620      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 621       jgrad_start(igrad_start)=
 622      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 623      &    +igrad_start
 624       jgrad_end(igrad_start)=nres
 625       igrad_end=((2*nlen+1)
 626      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 627       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 628       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 629      &    +igrad_end
 630       do i=igrad_start+1,igrad_end-1
 631         jgrad_start(i)=i+1
 632         jgrad_end(i)=nres
 633       enddo
 634       if (lprint) then
 635         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 636      & ' absolute rank',myrank,
 637      & ' loc_start',loc_start,' loc_end',loc_end,
 638      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 639      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 640      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 641      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 642      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 643      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 644      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 645      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 646      & ' iset_start',iset_start,' iset_end',iset_end,
 647      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 648      &   idihconstr_end
 649        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 650      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 651      &   ' ngrad_end',ngrad_end
 652        do i=igrad_start,igrad_end
 653          write(*,*) 'Processor:',fg_rank,myrank,i,
 654      &    jgrad_start(i),jgrad_end(i)
 655        enddo
 656       endif
 657       if (nfgtasks.gt.1) then
 658         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 659      &    MPI_INTEGER,FG_COMM1,IERROR)
 660         iaux=ivec_end-ivec_start+1
 661         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 662      &    MPI_INTEGER,FG_COMM1,IERROR)
 663         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 664      &    MPI_INTEGER,FG_COMM,IERROR)
 665         iaux=iset_end-iset_start+1
 666         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 667      &    MPI_INTEGER,FG_COMM,IERROR)
 668         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 669      &    MPI_INTEGER,FG_COMM,IERROR)
 670         iaux=ibond_end-ibond_start+1
 671         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 672      &    MPI_INTEGER,FG_COMM,IERROR)
 673         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 674      &    MPI_INTEGER,FG_COMM,IERROR)
 675         iaux=ithet_end-ithet_start+1
 676         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 677      &    MPI_INTEGER,FG_COMM,IERROR)
 678         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 679      &    MPI_INTEGER,FG_COMM,IERROR)
 680         iaux=iphi_end-iphi_start+1
 681         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 682      &    MPI_INTEGER,FG_COMM,IERROR)
 683         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 684      &    MPI_INTEGER,FG_COMM,IERROR)
 685         iaux=iphi1_end-iphi1_start+1
 686         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 687      &    MPI_INTEGER,FG_COMM,IERROR)
 688         do i=0,maxprocs-1
 689           do j=1,maxres
 690             ielstart_all(j,i)=0
 691             ielend_all(j,i)=0
 692           enddo
 693         enddo
 694         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 695      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 696         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 697      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 698         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 699      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 700         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 701      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 702         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 703      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 704         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 705      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 706         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 707      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 708         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 709      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 710         if (lprint) then
 711         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 712         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 713         write (iout,*) "iturn3_start_all",
 714      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 715         write (iout,*) "iturn3_end_all",
 716      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 717         write (iout,*) "iturn4_start_all",
 718      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 719         write (iout,*) "iturn4_end_all",
 720      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 721         write (iout,*) "The ielstart_all array"
 722         do i=nnt,nct
 723           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 724         enddo
 725         write (iout,*) "The ielend_all array"
 726         do i=nnt,nct
 727           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 728         enddo
 729         call flush(iout)
 730         endif
 731         ntask_cont_from=0
 732         ntask_cont_to=0
 733         itask_cont_from(0)=fg_rank
 734         itask_cont_to(0)=fg_rank
 735         flag=.false.
 736         do ii=iturn3_start,iturn3_end
 737           call add_int(ii,ii+2,iturn3_sent(1,ii),
 738      &                 ntask_cont_to,itask_cont_to,flag)
 739         enddo
 740         do ii=iturn4_start,iturn4_end
 741           call add_int(ii,ii+3,iturn4_sent(1,ii),
 742      &                 ntask_cont_to,itask_cont_to,flag)
 743         enddo
 744         do ii=iturn3_start,iturn3_end
 745           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 746         enddo
 747         do ii=iturn4_start,iturn4_end
 748           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 749         enddo
 750         if (lprint) then
 751         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 752      &   " ntask_cont_to",ntask_cont_to
 753         write (iout,*) "itask_cont_from",
 754      &    (itask_cont_from(i),i=1,ntask_cont_from)
 755         write (iout,*) "itask_cont_to",
 756      &    (itask_cont_to(i),i=1,ntask_cont_to)
 757         call flush(iout)
 758         endif
 759 c        write (iout,*) "Loop forward"
 760 c        call flush(iout)
 761         do i=iatel_s,iatel_e
 762 c          write (iout,*) "from loop i=",i
 763 c          call flush(iout)
 764           do j=ielstart(i),ielend(i)
 765             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 766           enddo
 767         enddo
 768 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 769 c     &     " iatel_e",iatel_e
 770 c        call flush(iout)
 771         nat_sent=0
 772         do i=iatel_s,iatel_e
 773 c          write (iout,*) "i",i," ielstart",ielstart(i),
 774 c     &      " ielend",ielend(i)
 775 c          call flush(iout)
 776           flag=.false.
 777           do j=ielstart(i),ielend(i)
 778             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 779      &                   itask_cont_to,flag)
 780           enddo
 781           if (flag) then
 782             nat_sent=nat_sent+1
 783             iat_sent(nat_sent)=i
 784           endif
 785         enddo
 786         if (lprint) then
 787         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 788      &   " ntask_cont_to",ntask_cont_to
 789         write (iout,*) "itask_cont_from",
 790      &    (itask_cont_from(i),i=1,ntask_cont_from)
 791         write (iout,*) "itask_cont_to",
 792      &    (itask_cont_to(i),i=1,ntask_cont_to)
 793         call flush(iout)
 794         write (iout,*) "iint_sent"
 795         do i=1,nat_sent
 796           ii=iat_sent(i)
 797           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 798      &      j=ielstart(ii),ielend(ii))
 799         enddo
 800         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 801      &    " iturn3_end",iturn3_end
 802         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 803      &      i=iturn3_start,iturn3_end)
 804         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 805      &    " iturn4_end",iturn4_end
 806         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 807      &      i=iturn4_start,iturn4_end)
 808         call flush(iout)
 809         endif
 810         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 811      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 812 c        write (iout,*) "Gather ntask_cont_from ended"
 813 c        call flush(iout)
 814         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 815      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 816      &   FG_COMM,IERR)
 817 c        write (iout,*) "Gather itask_cont_from ended"
 818 c        call flush(iout)
 819         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 820      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 821 c        write (iout,*) "Gather ntask_cont_to ended"
 822 c        call flush(iout)
 823         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 824      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 825 c        write (iout,*) "Gather itask_cont_to ended"
 826 c        call flush(iout)
 827         if (fg_rank.eq.king) then
 828           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 829           do i=0,nfgtasks-1
 830             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 831      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 832           enddo
 833           write (iout,*)
 834           call flush(iout)
 835           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 836           do i=0,nfgtasks-1
 837             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 838      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 839           enddo
 840           write (iout,*)
 841           call flush(iout)
 842 C Check if every send will have a matching receive
 843           ncheck_to=0
 844           ncheck_from=0
 845           do i=0,nfgtasks-1
 846             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 847             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 848           enddo
 849           write (iout,*) "Control sums",ncheck_from,ncheck_to
 850           if (ncheck_from.ne.ncheck_to) then
 851             write (iout,*) "Error: #receive differs from #send."
 852             write (iout,*) "Terminating program...!"
 853             call flush(iout)
 854             flag=.false.
 855           else
 856             flag=.true.
 857             do i=0,nfgtasks-1
 858               do j=1,ntask_cont_to_all(i)
 859                 ii=itask_cont_to_all(j,i)
 860                 do k=1,ntask_cont_from_all(ii)
 861                   if (itask_cont_from_all(k,ii).eq.i) then
 862                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 863                     exit
 864                   endif
 865                 enddo
 866                 if (k.eq.ntask_cont_from_all(ii)+1) then
 867                   flag=.false.
 868                   write (iout,*) "Error: send by",j," to",ii,
 869      &            " would have no matching receive"
 870                 endif
 871               enddo
 872             enddo
 873           endif
 874           if (.not.flag) then
 875             write (iout,*) "Unmatched sends; terminating program"
 876             call flush(iout)
 877           endif
 878         endif
 879         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 880 c        write (iout,*) "flag broadcast ended flag=",flag
 881 c        call flush(iout)
 882         if (.not.flag) then
 883           call MPI_Finalize(IERROR)
 884           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 885         endif
 886         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 887 c        write (iout,*) "MPI_Comm_group ended"
 888 c        call flush(iout)
 889         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 890      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 891         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 892      &    CONT_TO_GROUP,IERR)
 893         do i=1,nat_sent
 894           ii=iat_sent(i)
 895           iaux=4*(ielend(ii)-ielstart(ii)+1)
 896           call MPI_Group_translate_ranks(fg_group,iaux,
 897      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 898      &      iint_sent_local(1,ielstart(ii),i),IERR )
 899 c          write (iout,*) "Ranks translated i=",i
 900 c          call flush(iout)
 901         enddo
 902         iaux=4*(iturn3_end-iturn3_start+1)
 903         call MPI_Group_translate_ranks(fg_group,iaux,
 904      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 905      &      iturn3_sent_local(1,iturn3_start),IERR)
 906         iaux=4*(iturn4_end-iturn4_start+1)
 907         call MPI_Group_translate_ranks(fg_group,iaux,
 908      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 909      &      iturn4_sent_local(1,iturn4_start),IERR)
 910         if (lprint) then
 911         write (iout,*) "iint_sent_local"
 912         do i=1,nat_sent
 913           ii=iat_sent(i)
 914           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 915      &      j=ielstart(ii),ielend(ii))
 916           call flush(iout)
 917         enddo
 918         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 919      &    " iturn3_end",iturn3_end
 920         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 921      &      i=iturn3_start,iturn3_end)
 922         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 923      &    " iturn4_end",iturn4_end
 924         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 925      &      i=iturn4_start,iturn4_end)
 926         call flush(iout)
 927         endif
 928         call MPI_Group_free(fg_group,ierr)
 929         call MPI_Group_free(cont_from_group,ierr)
 930         call MPI_Group_free(cont_to_group,ierr)
 931         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 932         call MPI_Type_commit(MPI_UYZ,IERROR)
 933         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 934      &    IERROR)
 935         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 936         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 937         call MPI_Type_commit(MPI_MU,IERROR)
 938         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 939         call MPI_Type_commit(MPI_MAT1,IERROR)
 940         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 941         call MPI_Type_commit(MPI_MAT2,IERROR)
 942         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 943         call MPI_Type_commit(MPI_THET,IERROR)
 944         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 945         call MPI_Type_commit(MPI_GAM,IERROR)
 946 #ifndef MATGATHER
 947 c 9/22/08 Derived types to send matrices which appear in correlation terms
 948         do i=0,nfgtasks-1
 949           if (ivec_count(i).eq.ivec_count(0)) then
 950             lentyp(i)=0
 951           else
 952             lentyp(i)=1
 953           endif
 954         enddo
 955         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 956         if (ind_typ.eq.0) then
 957           ichunk=ivec_count(0)
 958         else
 959           ichunk=ivec_count(1)
 960         endif
 961 c        do i=1,4
 962 c          blocklengths(i)=4
 963 c        enddo
 964 c        displs(1)=0
 965 c        do i=2,4
 966 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 967 c        enddo
 968 c        do i=1,4
 969 c          blocklengths(i)=blocklengths(i)*ichunk
 970 c        enddo
 971 c        write (iout,*) "blocklengths and displs"
 972 c        do i=1,4
 973 c          write (iout,*) i,blocklengths(i),displs(i)
 974 c        enddo
 975 c        call flush(iout)
 976 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 977 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 978 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 979 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 980 c        do i=1,4
 981 c          blocklengths(i)=2
 982 c        enddo
 983 c        displs(1)=0
 984 c        do i=2,4
 985 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 986 c        enddo
 987 c        do i=1,4
 988 c          blocklengths(i)=blocklengths(i)*ichunk
 989 c        enddo
 990 c        write (iout,*) "blocklengths and displs"
 991 c        do i=1,4
 992 c          write (iout,*) i,blocklengths(i),displs(i)
 993 c        enddo
 994 c        call flush(iout)
 995 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 996 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
 997 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
 998 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
 999         do i=1,8
1000           blocklengths(i)=2
1001         enddo
1002         displs(1)=0
1003         do i=2,8
1004           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1005         enddo
1006         do i=1,15
1007           blocklengths(i)=blocklengths(i)*ichunk
1008         enddo
1009         call MPI_Type_indexed(8,blocklengths,displs,
1010      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1011         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1012         do i=1,8
1013           blocklengths(i)=4
1014         enddo
1015         displs(1)=0
1016         do i=2,8
1017           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1018         enddo
1019         do i=1,15
1020           blocklengths(i)=blocklengths(i)*ichunk
1021         enddo
1022         call MPI_Type_indexed(8,blocklengths,displs,
1023      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1024         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1025         do i=1,6
1026           blocklengths(i)=4
1027         enddo
1028         displs(1)=0
1029         do i=2,6
1030           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1031         enddo
1032         do i=1,6
1033           blocklengths(i)=blocklengths(i)*ichunk
1034         enddo
1035         call MPI_Type_indexed(6,blocklengths,displs,
1036      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1037         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1038         do i=1,2
1039           blocklengths(i)=8
1040         enddo
1041         displs(1)=0
1042         do i=2,2
1043           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1044         enddo
1045         do i=1,2
1046           blocklengths(i)=blocklengths(i)*ichunk
1047         enddo
1048         call MPI_Type_indexed(2,blocklengths,displs,
1049      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1050         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1051         do i=1,4
1052           blocklengths(i)=1
1053         enddo
1054         displs(1)=0
1055         do i=2,4
1056           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1057         enddo
1058         do i=1,4
1059           blocklengths(i)=blocklengths(i)*ichunk
1060         enddo
1061         call MPI_Type_indexed(4,blocklengths,displs,
1062      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1063         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1064         enddo
1065 #endif
1066       endif
1067       iint_start=ivec_start+1
1068       iint_end=ivec_end+1
1069       do i=0,nfgtasks-1
1070           iint_count(i)=ivec_count(i)
1071           iint_displ(i)=ivec_displ(i)
1072           ivec_displ(i)=ivec_displ(i)-1
1073           iset_displ(i)=iset_displ(i)-1
1074           ithet_displ(i)=ithet_displ(i)-1
1075           iphi_displ(i)=iphi_displ(i)-1
1076           iphi1_displ(i)=iphi1_displ(i)-1
1077           ibond_displ(i)=ibond_displ(i)-1
1078       enddo
1079       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1080      &     .and. (me.eq.0 .or. out1file)) then
1081         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1082         do i=0,nfgtasks-1
1083           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1084      &      iset_count(i)
1085         enddo
1086         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1087      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1088         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1089         do i=0,nfgtasks-1
1090           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1091      &      iphi1_displ(i)
1092         enddo
1093         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1094      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1095      & ' SC-p interactions','were distributed among',nfgtasks,
1096      & ' fine-grain processors.'
1097       endif
1098 #else
1099       loc_start=2
1100       loc_end=nres-1
1101       ithet_start=3
1102       ithet_end=nres
1103       iturn3_start=nnt
1104       iturn3_end=nct-3
1105       iturn4_start=nnt
1106       iturn4_end=nct-4
1107       iphi_start=nnt+3
1108       iphi_end=nct
1109       iphi1_start=4
1110       iphi1_end=nres
1111       idihconstr_start=1
1112       idihconstr_end=ndih_constr
1113       iphid_start=iphi_start
1114       iphid_end=iphi_end-1
1115       ibond_start=2
1116       ibond_end=nres-1
1117       ibondp_start=nnt+1
1118       ibondp_end=nct
1119       ivec_start=1
1120       ivec_end=nres-1
1121       iset_start=3
1122       iset_end=nres+1
1123       iint_start=2
1124       iint_end=nres-1
1125 #endif
1126       return
1127       end
1128 #ifdef MPI
1129 c---------------------------------------------------------------------------
1130       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1131       implicit none
1132       include "DIMENSIONS"
1133       include "COMMON.INTERACT"
1134       include "COMMON.SETUP"
1135       include "COMMON.IOUNITS"
1136       integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
1137       logical flag
1138       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1139      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1140       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1141      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1142      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1143      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1144      & ielend_all(maxres,0:MaxProcs-1)
1145       integer iproc,isent,k,l
1146 c Determines whether to send interaction ii,jj to other processors; a given
1147 c interaction can be sent to at most 2 processors.
1148 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1149 c one processor, otherwise flag is unchanged from the input value.
1150       isent=0
1151       itask(1)=fg_rank
1152       itask(2)=fg_rank
1153       itask(3)=fg_rank
1154       itask(4)=fg_rank
1155 c      write (iout,*) "ii",ii," jj",jj
1156 c Loop over processors to check if anybody could need interaction ii,jj
1157       do iproc=0,fg_rank-1
1158 c Check if the interaction matches any turn3 at iproc
1159         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1160           l=k+2
1161           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1162      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1163      &    then
1164 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1165 c            call flush(iout)
1166             flag=.true.
1167             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1168      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1169               isent=isent+1
1170               itask(isent)=iproc
1171               call add_task(iproc,ntask_cont_to,itask_cont_to)
1172             endif
1173           endif
1174         enddo
1175 C Check if the interaction matches any turn4 at iproc
1176         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1177           l=k+3
1178           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1179      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1180      &    then
1181 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1182 c            call flush(iout)
1183             flag=.true.
1184             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1185      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1186               isent=isent+1
1187               itask(isent)=iproc
1188               call add_task(iproc,ntask_cont_to,itask_cont_to)
1189             endif
1190           endif
1191         enddo
1192         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1193      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1194           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1195      &        ielend_all(ii-1,iproc).ge.jj-1) then
1196             flag=.true.
1197             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1198      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1199               isent=isent+1
1200               itask(isent)=iproc
1201               call add_task(iproc,ntask_cont_to,itask_cont_to)
1202             endif
1203           endif
1204           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1205      &        ielend_all(ii-1,iproc).ge.jj+1) then
1206             flag=.true.
1207             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1208      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1209               isent=isent+1
1210               itask(isent)=iproc
1211               call add_task(iproc,ntask_cont_to,itask_cont_to)
1212             endif
1213           endif
1214         endif
1215       enddo
1216       return
1217       end
1218 c---------------------------------------------------------------------------
1219       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1220       implicit none
1221       include "DIMENSIONS"
1222       include "COMMON.INTERACT"
1223       include "COMMON.SETUP"
1224       include "COMMON.IOUNITS"
1225       integer ii,jj,itask(2),ntask_cont_from,
1226      & itask_cont_from(0:MaxProcs-1)
1227       logical flag
1228       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1229      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1230       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1231      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1232      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1233      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1234      & ielend_all(maxres,0:MaxProcs-1)
1235       integer iproc,k,l
1236       do iproc=fg_rank+1,nfgtasks-1
1237         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1238           l=k+2
1239           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1240      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1241      &    then
1242 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1243             call add_task(iproc,ntask_cont_from,itask_cont_from)
1244           endif
1245         enddo
1246         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1247           l=k+3
1248           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1249      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1250      &    then
1251 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1252             call add_task(iproc,ntask_cont_from,itask_cont_from)
1253           endif
1254         enddo
1255         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1256           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1257      &    then
1258             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1259      &          jj+1.le.ielend_all(ii+1,iproc)) then
1260               call add_task(iproc,ntask_cont_from,itask_cont_from)
1261             endif
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           endif
1267           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1268      &    then
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             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           endif
1278         endif
1279       enddo
1280       return
1281       end
1282 c---------------------------------------------------------------------------
1283       subroutine add_task(iproc,ntask_cont,itask_cont)
1284       implicit none
1285       include "DIMENSIONS"
1286       integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
1287       integer ii
1288       do ii=1,ntask_cont
1289         if (itask_cont(ii).eq.iproc) return
1290       enddo
1291       ntask_cont=ntask_cont+1
1292       itask_cont(ntask_cont)=iproc
1293       return
1294       end
1295 c---------------------------------------------------------------------------
1296       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1297       implicit real*8 (a-h,o-z)
1298       include 'DIMENSIONS'
1299       include 'mpif.h'
1300       include 'COMMON.SETUP'
1301       integer total_ints,lower_bound,upper_bound
1302       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1303       nint=total_ints/nfgtasks
1304       do i=1,nfgtasks
1305         int4proc(i-1)=nint
1306       enddo
1307       nexcess=total_ints-nint*nfgtasks
1308       do i=1,nexcess
1309         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1310       enddo
1311       lower_bound=0
1312       do i=0,fg_rank-1
1313         lower_bound=lower_bound+int4proc(i)
1314       enddo
1315       upper_bound=lower_bound+int4proc(fg_rank)
1316       lower_bound=lower_bound+1
1317       return
1318       end
1319 c---------------------------------------------------------------------------
1320       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1321       implicit real*8 (a-h,o-z)
1322       include 'DIMENSIONS'
1323       include 'mpif.h'
1324       include 'COMMON.SETUP'
1325       integer total_ints,lower_bound,upper_bound
1326       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1327       nint=total_ints/nfgtasks1
1328       do i=1,nfgtasks1
1329         int4proc(i-1)=nint
1330       enddo
1331       nexcess=total_ints-nint*nfgtasks1
1332       do i=1,nexcess
1333         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1334       enddo
1335       lower_bound=0
1336       do i=0,fg_rank1-1
1337         lower_bound=lower_bound+int4proc(i)
1338       enddo
1339       upper_bound=lower_bound+int4proc(fg_rank1)
1340       lower_bound=lower_bound+1
1341       return
1342       end
1343 c---------------------------------------------------------------------------
1344       subroutine int_partition(int_index,lower_index,upper_index,atom,
1345      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1346       implicit real*8 (a-h,o-z)
1347       include 'DIMENSIONS'
1348       include 'COMMON.IOUNITS'
1349       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1350      & first_atom,last_atom,int_gr,jat_start,jat_end
1351       logical lprn
1352       lprn=.false.
1353       if (lprn) write (iout,*) 'int_index=',int_index
1354       int_index_old=int_index
1355       int_index=int_index+last_atom-first_atom+1
1356       if (lprn)
1357      &   write (iout,*) 'int_index=',int_index,
1358      &               ' int_index_old',int_index_old,
1359      &               ' lower_index=',lower_index,
1360      &               ' upper_index=',upper_index,
1361      &               ' atom=',atom,' first_atom=',first_atom,
1362      &               ' last_atom=',last_atom
1363       if (int_index.ge.lower_index) then
1364         int_gr=int_gr+1
1365         if (at_start.eq.0) then
1366           at_start=atom
1367           jat_start=first_atom-1+lower_index-int_index_old
1368         else
1369           jat_start=first_atom
1370         endif
1371         if (lprn) write (iout,*) 'jat_start',jat_start
1372         if (int_index.ge.upper_index) then
1373           at_end=atom
1374           jat_end=first_atom-1+upper_index-int_index_old
1375           return1
1376         else
1377           jat_end=last_atom
1378         endif
1379         if (lprn) write (iout,*) 'jat_end',jat_end
1380       endif
1381       return
1382       end
1383 #endif
1384 c------------------------------------------------------------------------------
1385       subroutine hpb_partition
1386       implicit real*8 (a-h,o-z)
1387       include 'DIMENSIONS'
1388 #ifdef MPI
1389       include 'mpif.h'
1390 #endif
1391       include 'COMMON.SBRIDGE'
1392       include 'COMMON.IOUNITS'
1393       include 'COMMON.SETUP'
1394       include 'COMMON.CONTROL'
1395 #ifdef MPI
1396       call int_bounds(nhpb,link_start,link_end)
1397       if (.not. out1file)
1398      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1399      &  ' absolute rank',MyRank,
1400      &  ' nhpb',nhpb,' link_start=',link_start,
1401      &  ' link_end',link_end
1402 #else
1403       link_start=1
1404       link_end=nhpb
1405 #endif
1406       return
1407       end