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