2 implicit real*8 (a-h,o-z)
7 & /'pool','chain regrow','multi-bond','phi','theta','side chain',
9 c Conversion from poises to molecular unit and the gas constant
10 data cPoise /2.9361d0/, Rb /0.001986d0/
12 c--------------------------------------------------------------------------
15 C Define constants and zero out tables.
17 implicit real*8 (a-h,o-z)
25 cMS$ATTRIBUTES C :: proc_proc
28 include 'COMMON.IOUNITS'
29 include 'COMMON.CHAIN'
30 include 'COMMON.INTERACT'
32 include 'COMMON.LOCAL'
33 include 'COMMON.TORSION'
34 include 'COMMON.FFIELD'
35 include 'COMMON.SBRIDGE'
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
44 c real*8 text1 /'initial_i'/
63 C The following is just to define auxiliary variables used in angle conversion
102 crc for write_rmsbank1
104 cdr include secondary structure prediction bias
107 C CSA I/O units (separated from others especially for Jooyoung)
118 icsa_bank_reminimized=38
121 crc for ifc error 118
124 C Set default weights of the energy terms.
135 print '(a,$)','Inside initialize'
136 c call memmon_print_usage()
169 athet(j,i,k,kk)=0.0D0
170 bthet(j,i,k,kk)=0.0D0
190 gaussc(l,k,j,i)=0.0D0
203 v1(k,j,i,iblock)=0.0D0
204 v2(k,j,i,iblock)=0.0D0
213 C Initialize the bridge arrays
232 C Initialize variables used in minimization.
241 C Initialize the variables responsible for the mode of gradient storage.
246 C Initialize constants used to split the energy into long- and short-range
252 nprint_ene=nprint_ene-1
256 c-------------------------------------------------------------------------
258 implicit real*8 (a-h,o-z)
260 include 'COMMON.NAMES'
261 include 'COMMON.FFIELD'
263 &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
264 &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
266 &'C','M','F','I','L','V','W','Y','A','G','T',
267 &'S','Q','N','E','D','H','R','K','P','X'/
268 data potname /'LJ','LJK','BP','GB','GBV'/
270 & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
271 & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
272 & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
273 & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," "/
275 & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
276 & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
277 & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR",
280 data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
283 c---------------------------------------------------------------------------
284 subroutine init_int_table
285 implicit real*8 (a-h,o-z)
289 integer blocklengths(15),displs(15)
291 include 'COMMON.CONTROL'
292 include 'COMMON.SETUP'
293 include 'COMMON.CHAIN'
294 include 'COMMON.INTERACT'
295 include 'COMMON.LOCAL'
296 include 'COMMON.SBRIDGE'
297 include 'COMMON.TORCNSTR'
298 include 'COMMON.IOUNITS'
299 include 'COMMON.DERIV'
300 include 'COMMON.CONTACTS'
301 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
302 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
303 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
304 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
305 & ielend_all(maxres,0:max_fg_procs-1),
306 & ntask_cont_from_all(0:max_fg_procs-1),
307 & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
308 & ntask_cont_to_all(0:max_fg_procs-1),
309 & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
310 integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
311 logical scheck,lprint,flag
313 integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
314 & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
315 C... Determine the numbers of start and end SC-SC interaction
316 C... to deal with by current processor.
318 itask_cont_from(i)=fg_rank
319 itask_cont_to(i)=fg_rank
323 &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
324 n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
325 call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
327 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
328 & ' absolute rank',MyRank,
329 & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
330 & ' my_sc_inde',my_sc_inde
350 cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
351 cd & (ihpb(i),jhpb(i),i=1,nss)
356 if (ihpb(ii).eq.i+nres) then
363 cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
367 c write (iout,*) 'jj=i+1'
368 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
369 & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
375 else if (jj.eq.nct) then
377 c write (iout,*) 'jj=nct'
378 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
379 & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
387 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
388 & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
390 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
391 & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
402 call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
403 & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
408 ind_scint=ind_scint+nct-i
412 ind_scint_old=ind_scint
420 if (iatsc_s.eq.0) iatsc_s=1
422 if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
423 & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
426 write (iout,'(a)') 'Interaction array:'
428 write (iout,'(i3,2(2x,2i3))')
429 & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
434 C Now partition the electrostatic-interaction array
436 nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
437 call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
439 & write (*,*) 'Processor',fg_rank,' CG group',kolor,
440 & ' absolute rank',MyRank,
441 & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
442 & ' my_ele_inde',my_ele_inde
449 call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
450 & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
453 if (iatel_s.eq.0) iatel_s=1
454 nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
455 c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
456 call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
457 c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
458 c & " my_ele_inde_vdw",my_ele_inde_vdw
465 call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
467 & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
469 c write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
470 c & " ielend_vdw",ielend_vdw(i)
472 if (iatel_s_vdw.eq.0) iatel_s_vdw=1
483 do i=iatel_s_vdw,iatel_e_vdw
489 write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
490 & ' absolute rank',MyRank
491 write (iout,*) 'Electrostatic interaction array:'
493 write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
498 C Partition the SC-p interaction array
500 nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
501 call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
502 if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
503 & ' absolute rank',myrank,
504 & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
505 & ' my_scp_inde',my_scp_inde
511 if (i.lt.nnt+iscp) then
512 cd write (iout,*) 'i.le.nnt+iscp'
513 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
514 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
516 else if (i.gt.nct-iscp) then
517 cd write (iout,*) 'i.gt.nct-iscp'
518 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
519 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
522 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
523 & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
526 call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
527 & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
536 if (i.lt.nnt+iscp) then
538 iscpstart(i,1)=i+iscp
540 elseif (i.gt.nct-iscp) then
548 iscpstart(i,2)=i+iscp
553 if (iatscp_s.eq.0) iatscp_s=1
555 write (iout,'(a)') 'SC-p interaction array:'
556 do i=iatscp_s,iatscp_e
557 write (iout,'(i3,2(2x,2i3))')
558 & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
561 C Partition local interactions
563 call int_bounds(nres-2,loc_start,loc_end)
564 loc_start=loc_start+1
566 call int_bounds(nres-2,ithet_start,ithet_end)
567 ithet_start=ithet_start+2
568 ithet_end=ithet_end+2
569 call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
570 iturn3_start=iturn3_start+nnt
571 iphi_start=iturn3_start+2
572 iturn3_end=iturn3_end+nnt
573 iphi_end=iturn3_end+2
574 iturn3_start=iturn3_start-1
575 iturn3_end=iturn3_end-1
576 call int_bounds(nres-3,itau_start,itau_end)
577 itau_start=itau_start+3
579 call int_bounds(nres-3,iphi1_start,iphi1_end)
580 iphi1_start=iphi1_start+3
581 iphi1_end=iphi1_end+3
582 call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
583 iturn4_start=iturn4_start+nnt
584 iphid_start=iturn4_start+2
585 iturn4_end=iturn4_end+nnt
586 iphid_end=iturn4_end+2
587 iturn4_start=iturn4_start-1
588 iturn4_end=iturn4_end-1
589 call int_bounds(nres-2,ibond_start,ibond_end)
590 ibond_start=ibond_start+1
591 ibond_end=ibond_end+1
592 call int_bounds(nct-nnt,ibondp_start,ibondp_end)
593 ibondp_start=ibondp_start+nnt
594 ibondp_end=ibondp_end+nnt
595 call int_bounds1(nres-1,ivec_start,ivec_end)
596 print *,"Processor",myrank,fg_rank,fg_rank1,
597 & " ivec_start",ivec_start," ivec_end",ivec_end
598 iset_start=loc_start+2
600 if (ndih_constr.eq.0) then
604 call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
606 nsumgrad=(nres-nnt)*(nres-nnt+1)/2
608 call int_bounds(nsumgrad,ngrad_start,ngrad_end)
609 igrad_start=((2*nlen+1)
610 & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
611 jgrad_start(igrad_start)=
612 & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
614 jgrad_end(igrad_start)=nres
615 igrad_end=((2*nlen+1)
616 & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
617 if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
618 jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
620 do i=igrad_start+1,igrad_end-1
625 write (*,*) 'Processor:',fg_rank,' CG group',kolor,
626 & ' absolute rank',myrank,
627 & ' loc_start',loc_start,' loc_end',loc_end,
628 & ' ithet_start',ithet_start,' ithet_end',ithet_end,
629 & ' iphi_start',iphi_start,' iphi_end',iphi_end,
630 & ' iphid_start',iphid_start,' iphid_end',iphid_end,
631 & ' ibond_start',ibond_start,' ibond_end',ibond_end,
632 & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
633 & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
634 & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
635 & ' ivec_start',ivec_start,' ivec_end',ivec_end,
636 & ' iset_start',iset_start,' iset_end',iset_end,
637 & ' idihconstr_start',idihconstr_start,' idihconstr_end',
639 write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
640 & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
641 & ' ngrad_end',ngrad_end
642 do i=igrad_start,igrad_end
643 write(*,*) 'Processor:',fg_rank,myrank,i,
644 & jgrad_start(i),jgrad_end(i)
647 if (nfgtasks.gt.1) then
648 call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
649 & MPI_INTEGER,FG_COMM1,IERROR)
650 iaux=ivec_end-ivec_start+1
651 call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
652 & MPI_INTEGER,FG_COMM1,IERROR)
653 call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
654 & MPI_INTEGER,FG_COMM,IERROR)
655 iaux=iset_end-iset_start+1
656 call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
657 & MPI_INTEGER,FG_COMM,IERROR)
658 call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
659 & MPI_INTEGER,FG_COMM,IERROR)
660 iaux=ibond_end-ibond_start+1
661 call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
662 & MPI_INTEGER,FG_COMM,IERROR)
663 call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
664 & MPI_INTEGER,FG_COMM,IERROR)
665 iaux=ithet_end-ithet_start+1
666 call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
667 & MPI_INTEGER,FG_COMM,IERROR)
668 call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
669 & MPI_INTEGER,FG_COMM,IERROR)
670 iaux=iphi_end-iphi_start+1
671 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
672 & MPI_INTEGER,FG_COMM,IERROR)
673 call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
674 & MPI_INTEGER,FG_COMM,IERROR)
675 iaux=iphi1_end-iphi1_start+1
676 call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
677 & MPI_INTEGER,FG_COMM,IERROR)
684 call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
685 & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
686 call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
687 & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
688 call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
689 & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
690 call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
691 & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
692 call MPI_Allgather(iatel_s,1,MPI_INTEGER,
693 & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
694 call MPI_Allgather(iatel_e,1,MPI_INTEGER,
695 & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
696 call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
697 & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
698 call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
699 & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
701 write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
702 write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
703 write (iout,*) "iturn3_start_all",
704 & (iturn3_start_all(i),i=0,nfgtasks-1)
705 write (iout,*) "iturn3_end_all",
706 & (iturn3_end_all(i),i=0,nfgtasks-1)
707 write (iout,*) "iturn4_start_all",
708 & (iturn4_start_all(i),i=0,nfgtasks-1)
709 write (iout,*) "iturn4_end_all",
710 & (iturn4_end_all(i),i=0,nfgtasks-1)
711 write (iout,*) "The ielstart_all array"
713 write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
715 write (iout,*) "The ielend_all array"
717 write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
723 itask_cont_from(0)=fg_rank
724 itask_cont_to(0)=fg_rank
726 do ii=iturn3_start,iturn3_end
727 call add_int(ii,ii+2,iturn3_sent(1,ii),
728 & ntask_cont_to,itask_cont_to,flag)
730 do ii=iturn4_start,iturn4_end
731 call add_int(ii,ii+3,iturn4_sent(1,ii),
732 & ntask_cont_to,itask_cont_to,flag)
734 do ii=iturn3_start,iturn3_end
735 call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
737 do ii=iturn4_start,iturn4_end
738 call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
741 write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
742 & " ntask_cont_to",ntask_cont_to
743 write (iout,*) "itask_cont_from",
744 & (itask_cont_from(i),i=1,ntask_cont_from)
745 write (iout,*) "itask_cont_to",
746 & (itask_cont_to(i),i=1,ntask_cont_to)
749 c write (iout,*) "Loop forward"
752 c write (iout,*) "from loop i=",i
754 do j=ielstart(i),ielend(i)
755 call add_int_from(i,j,ntask_cont_from,itask_cont_from)
758 c write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
759 c & " iatel_e",iatel_e
763 c write (iout,*) "i",i," ielstart",ielstart(i),
764 c & " ielend",ielend(i)
767 do j=ielstart(i),ielend(i)
768 call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
769 & itask_cont_to,flag)
777 write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
778 & " ntask_cont_to",ntask_cont_to
779 write (iout,*) "itask_cont_from",
780 & (itask_cont_from(i),i=1,ntask_cont_from)
781 write (iout,*) "itask_cont_to",
782 & (itask_cont_to(i),i=1,ntask_cont_to)
784 write (iout,*) "iint_sent"
787 write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
788 & j=ielstart(ii),ielend(ii))
790 write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
791 & " iturn3_end",iturn3_end
792 write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
793 & i=iturn3_start,iturn3_end)
794 write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
795 & " iturn4_end",iturn4_end
796 write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
797 & i=iturn4_start,iturn4_end)
800 call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
801 & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
802 c write (iout,*) "Gather ntask_cont_from ended"
804 call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
805 & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
807 c write (iout,*) "Gather itask_cont_from ended"
809 call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
810 & 1,MPI_INTEGER,king,FG_COMM,IERR)
811 c write (iout,*) "Gather ntask_cont_to ended"
813 call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
814 & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
815 c write (iout,*) "Gather itask_cont_to ended"
817 if (fg_rank.eq.king) then
818 write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
820 write (iout,'(20i4)') i,ntask_cont_from_all(i),
821 & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
825 write (iout,*) "Contact send task map (proc, #tasks, tasks)"
827 write (iout,'(20i4)') i,ntask_cont_to_all(i),
828 & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
832 C Check if every send will have a matching receive
836 ncheck_to=ncheck_to+ntask_cont_to_all(i)
837 ncheck_from=ncheck_from+ntask_cont_from_all(i)
839 write (iout,*) "Control sums",ncheck_from,ncheck_to
840 if (ncheck_from.ne.ncheck_to) then
841 write (iout,*) "Error: #receive differs from #send."
842 write (iout,*) "Terminating program...!"
848 do j=1,ntask_cont_to_all(i)
849 ii=itask_cont_to_all(j,i)
850 do k=1,ntask_cont_from_all(ii)
851 if (itask_cont_from_all(k,ii).eq.i) then
852 if(lprint)write(iout,*)"Matching send/receive",i,ii
856 if (k.eq.ntask_cont_from_all(ii)+1) then
858 write (iout,*) "Error: send by",j," to",ii,
859 & " would have no matching receive"
865 write (iout,*) "Unmatched sends; terminating program"
869 call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
870 c write (iout,*) "flag broadcast ended flag=",flag
873 call MPI_Finalize(IERROR)
874 stop "Error in INIT_INT_TABLE: unmatched send/receive."
876 call MPI_Comm_group(FG_COMM,fg_group,IERR)
877 c write (iout,*) "MPI_Comm_group ended"
879 call MPI_Group_incl(fg_group,ntask_cont_from+1,
880 & itask_cont_from(0),CONT_FROM_GROUP,IERR)
881 call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
882 & CONT_TO_GROUP,IERR)
885 iaux=4*(ielend(ii)-ielstart(ii)+1)
886 call MPI_Group_translate_ranks(fg_group,iaux,
887 & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
888 & iint_sent_local(1,ielstart(ii),i),IERR )
889 c write (iout,*) "Ranks translated i=",i
892 iaux=4*(iturn3_end-iturn3_start+1)
893 call MPI_Group_translate_ranks(fg_group,iaux,
894 & iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
895 & iturn3_sent_local(1,iturn3_start),IERR)
896 iaux=4*(iturn4_end-iturn4_start+1)
897 call MPI_Group_translate_ranks(fg_group,iaux,
898 & iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
899 & iturn4_sent_local(1,iturn4_start),IERR)
901 write (iout,*) "iint_sent_local"
904 write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
905 & j=ielstart(ii),ielend(ii))
908 write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
909 & " iturn3_end",iturn3_end
910 write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
911 & i=iturn3_start,iturn3_end)
912 write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
913 & " iturn4_end",iturn4_end
914 write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
915 & i=iturn4_start,iturn4_end)
918 call MPI_Group_free(fg_group,ierr)
919 call MPI_Group_free(cont_from_group,ierr)
920 call MPI_Group_free(cont_to_group,ierr)
921 call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
922 call MPI_Type_commit(MPI_UYZ,IERROR)
923 call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
925 call MPI_Type_commit(MPI_UYZGRAD,IERROR)
926 call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
927 call MPI_Type_commit(MPI_MU,IERROR)
928 call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
929 call MPI_Type_commit(MPI_MAT1,IERROR)
930 call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
931 call MPI_Type_commit(MPI_MAT2,IERROR)
932 call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
933 call MPI_Type_commit(MPI_THET,IERROR)
934 call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
935 call MPI_Type_commit(MPI_GAM,IERROR)
937 c 9/22/08 Derived types to send matrices which appear in correlation terms
939 if (ivec_count(i).eq.ivec_count(0)) then
945 do ind_typ=lentyp(0),lentyp(nfgtasks-1)
946 if (ind_typ.eq.0) then
956 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
959 c blocklengths(i)=blocklengths(i)*ichunk
961 c write (iout,*) "blocklengths and displs"
963 c write (iout,*) i,blocklengths(i),displs(i)
966 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
967 c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
968 c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
969 c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
975 c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
978 c blocklengths(i)=blocklengths(i)*ichunk
980 c write (iout,*) "blocklengths and displs"
982 c write (iout,*) i,blocklengths(i),displs(i)
985 c call MPI_Type_indexed(4,blocklengths(1),displs(1),
986 c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
987 c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
988 c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
994 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
997 blocklengths(i)=blocklengths(i)*ichunk
999 call MPI_Type_indexed(8,blocklengths,displs,
1000 & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
1001 call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
1007 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1010 blocklengths(i)=blocklengths(i)*ichunk
1012 call MPI_Type_indexed(8,blocklengths,displs,
1013 & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1014 call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1020 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1023 blocklengths(i)=blocklengths(i)*ichunk
1025 call MPI_Type_indexed(6,blocklengths,displs,
1026 & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1027 call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1033 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1036 blocklengths(i)=blocklengths(i)*ichunk
1038 call MPI_Type_indexed(2,blocklengths,displs,
1039 & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1040 call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1046 displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1049 blocklengths(i)=blocklengths(i)*ichunk
1051 call MPI_Type_indexed(4,blocklengths,displs,
1052 & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1053 call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1057 iint_start=ivec_start+1
1060 iint_count(i)=ivec_count(i)
1061 iint_displ(i)=ivec_displ(i)
1062 ivec_displ(i)=ivec_displ(i)-1
1063 iset_displ(i)=iset_displ(i)-1
1064 ithet_displ(i)=ithet_displ(i)-1
1065 iphi_displ(i)=iphi_displ(i)-1
1066 iphi1_displ(i)=iphi1_displ(i)-1
1067 ibond_displ(i)=ibond_displ(i)-1
1069 if (nfgtasks.gt.1 .and. fg_rank.eq.king
1070 & .and. (me.eq.0 .or. out1file)) then
1071 write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1073 write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1076 write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1077 & " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1078 write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1080 write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1083 write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1084 & nele_int_tot,' electrostatic and ',nscp_int_tot,
1085 & ' SC-p interactions','were distributed among',nfgtasks,
1086 & ' fine-grain processors.'
1102 idihconstr_end=ndih_constr
1103 iphid_start=iphi_start
1104 iphid_end=iphi_end-1
1121 c---------------------------------------------------------------------------
1122 subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1124 include "DIMENSIONS"
1125 include "COMMON.INTERACT"
1126 include "COMMON.SETUP"
1127 include "COMMON.IOUNITS"
1128 integer ii,jj,itask(4),
1129 & ntask_cont_to,itask_cont_to(0:max_fg_procs-1)
1131 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1132 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1133 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1134 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1135 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1136 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1137 & ielend_all(maxres,0:max_fg_procs-1)
1138 integer iproc,isent,k,l
1139 c Determines whether to send interaction ii,jj to other processors; a given
1140 c interaction can be sent to at most 2 processors.
1141 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1142 c one processor, otherwise flag is unchanged from the input value.
1148 c write (iout,*) "ii",ii," jj",jj
1149 c Loop over processors to check if anybody could need interaction ii,jj
1150 do iproc=0,fg_rank-1
1151 c Check if the interaction matches any turn3 at iproc
1152 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1154 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1155 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1157 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1160 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1161 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1164 call add_task(iproc,ntask_cont_to,itask_cont_to)
1168 C Check if the interaction matches any turn4 at iproc
1169 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1171 if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1172 & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1174 c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1177 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1178 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1181 call add_task(iproc,ntask_cont_to,itask_cont_to)
1185 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1186 & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1187 if (ielstart_all(ii-1,iproc).le.jj-1.and.
1188 & ielend_all(ii-1,iproc).ge.jj-1) then
1190 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1191 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1194 call add_task(iproc,ntask_cont_to,itask_cont_to)
1197 if (ielstart_all(ii-1,iproc).le.jj+1.and.
1198 & ielend_all(ii-1,iproc).ge.jj+1) then
1200 if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1201 & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1204 call add_task(iproc,ntask_cont_to,itask_cont_to)
1211 c---------------------------------------------------------------------------
1212 subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1214 include "DIMENSIONS"
1215 include "COMMON.INTERACT"
1216 include "COMMON.SETUP"
1217 include "COMMON.IOUNITS"
1218 integer ii,jj,itask(2),ntask_cont_from,
1219 & itask_cont_from(0:max_fg_procs-1)
1221 integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1222 & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1223 common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1224 & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1225 & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1226 &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1227 & ielend_all(maxres,0:max_fg_procs-1)
1229 do iproc=fg_rank+1,nfgtasks-1
1230 do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1232 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1233 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1235 c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1236 call add_task(iproc,ntask_cont_from,itask_cont_from)
1239 do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1241 if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1242 & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1244 c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1245 call add_task(iproc,ntask_cont_from,itask_cont_from)
1248 if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1249 if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1251 if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1252 & jj+1.le.ielend_all(ii+1,iproc)) then
1253 call add_task(iproc,ntask_cont_from,itask_cont_from)
1255 if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1256 & jj-1.le.ielend_all(ii+1,iproc)) then
1257 call add_task(iproc,ntask_cont_from,itask_cont_from)
1260 if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1262 if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1263 & jj-1.le.ielend_all(ii-1,iproc)) then
1264 call add_task(iproc,ntask_cont_from,itask_cont_from)
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)
1275 c---------------------------------------------------------------------------
1276 subroutine add_task(iproc,ntask_cont,itask_cont)
1278 include "DIMENSIONS"
1279 integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1282 if (itask_cont(ii).eq.iproc) return
1284 ntask_cont=ntask_cont+1
1285 itask_cont(ntask_cont)=iproc
1288 c---------------------------------------------------------------------------
1289 subroutine int_bounds(total_ints,lower_bound,upper_bound)
1290 implicit real*8 (a-h,o-z)
1291 include 'DIMENSIONS'
1293 include 'COMMON.SETUP'
1294 integer total_ints,lower_bound,upper_bound
1295 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1296 nint=total_ints/nfgtasks
1300 nexcess=total_ints-nint*nfgtasks
1302 int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1306 lower_bound=lower_bound+int4proc(i)
1308 upper_bound=lower_bound+int4proc(fg_rank)
1309 lower_bound=lower_bound+1
1312 c---------------------------------------------------------------------------
1313 subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1314 implicit real*8 (a-h,o-z)
1315 include 'DIMENSIONS'
1317 include 'COMMON.SETUP'
1318 integer total_ints,lower_bound,upper_bound
1319 integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1320 nint=total_ints/nfgtasks1
1324 nexcess=total_ints-nint*nfgtasks1
1326 int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1330 lower_bound=lower_bound+int4proc(i)
1332 upper_bound=lower_bound+int4proc(fg_rank1)
1333 lower_bound=lower_bound+1
1336 c---------------------------------------------------------------------------
1337 subroutine int_partition(int_index,lower_index,upper_index,atom,
1338 & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1339 implicit real*8 (a-h,o-z)
1340 include 'DIMENSIONS'
1341 include 'COMMON.IOUNITS'
1342 integer int_index,lower_index,upper_index,atom,at_start,at_end,
1343 & first_atom,last_atom,int_gr,jat_start,jat_end
1346 if (lprn) write (iout,*) 'int_index=',int_index
1347 int_index_old=int_index
1348 int_index=int_index+last_atom-first_atom+1
1350 & write (iout,*) 'int_index=',int_index,
1351 & ' int_index_old',int_index_old,
1352 & ' lower_index=',lower_index,
1353 & ' upper_index=',upper_index,
1354 & ' atom=',atom,' first_atom=',first_atom,
1355 & ' last_atom=',last_atom
1356 if (int_index.ge.lower_index) then
1358 if (at_start.eq.0) then
1360 jat_start=first_atom-1+lower_index-int_index_old
1362 jat_start=first_atom
1364 if (lprn) write (iout,*) 'jat_start',jat_start
1365 if (int_index.ge.upper_index) then
1367 jat_end=first_atom-1+upper_index-int_index_old
1372 if (lprn) write (iout,*) 'jat_end',jat_end
1377 c------------------------------------------------------------------------------
1378 subroutine hpb_partition
1379 implicit real*8 (a-h,o-z)
1380 include 'DIMENSIONS'
1384 include 'COMMON.SBRIDGE'
1385 include 'COMMON.IOUNITS'
1386 include 'COMMON.SETUP'
1387 include 'COMMON.CONTROL'
1388 c write(2,*)"hpb_partition: nhpb=",nhpb
1390 call int_bounds(nhpb,link_start,link_end)
1392 & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1393 & ' absolute rank',MyRank,
1394 & ' nhpb',nhpb,' link_start=',link_start,
1395 & ' link_end',link_end
1400 c write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end