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