changes to avoid PMPI_Scatterv: Invalid buffer pointer in Intel MPI
[unres.git] / source / unres / src_MD-M / MP.F
1 #ifdef MPI
2       subroutine init_task
3       implicit real*8 (a-h,o-z)
4       include 'DIMENSIONS'
5       include 'mpif.h'
6       include 'COMMON.SETUP'
7       include 'COMMON.CONTROL'
8       include 'COMMON.IOUNITS'
9       logical lprn /.false./
10 c      real*8 text1 /'group_i '/,text2/'group_f '/,
11 c     & text3/'initialb'/,text4/'initiale'/,
12 c     & text5/'openb'/,text6/'opene'/
13       integer cgtasks(0:max_cg_procs)
14       character*3 cfgprocs 
15       integer cg_size,fg_size,fg_size1
16 c  start parallel processing
17 c      print *,'Initializing MPI'
18       call mpi_init(ierr)
19       if (ierr.ne.0) then
20         print *, ' cannot initialize MPI'
21         stop
22       endif
23 c  determine # of nodes and current node
24       call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr )
25       if (ierr.ne.0) then
26         print *, ' cannot determine rank of all processes'
27         call MPI_Finalize( MPI_COMM_WORLD, IERR )
28         stop
29       endif
30       call MPI_Comm_size( MPI_Comm_world, nodes, ierr )
31       if (ierr.ne.0) then
32         print *, ' cannot determine number of processes'
33         stop
34       endif
35       Nprocs=nodes
36       MyRank=me
37 C Determine the number of "fine-grain" tasks
38       call getenv_loc("FGPROCS",cfgprocs)
39       read (cfgprocs,'(i3)') nfgtasks
40       if (nfgtasks.eq.0) nfgtasks=1
41       call getenv_loc("MAXGSPROCS",cfgprocs)
42       read (cfgprocs,'(i3)') max_gs_size
43       if (max_gs_size.eq.0) max_gs_size=2
44       if (lprn) 
45      &  print *,"Processor",me," nfgtasks",nfgtasks,
46      & " max_gs_size",max_gs_size
47       if (nfgtasks.eq.1) then
48         CG_COMM = MPI_COMM_WORLD
49         fg_size=1
50         fg_rank=0
51         nfgtasks1=1
52         fg_rank1=0
53       else
54         nodes=nprocs/nfgtasks
55         if (nfgtasks*nodes.ne.nprocs) then
56           write (*,'(a)') 'ERROR: Number of processors assigned',
57      &     ' to coarse-grained tasks must be divisor',
58      &     ' of the total number of processors.'
59           call MPI_Finalize( MPI_COMM_WORLD, IERR )
60           stop
61         endif
62 C Put the ranks of coarse-grain processes in one table and create
63 C the respective communicator. The processes with ranks "in between" 
64 C the ranks of CG processes will perform fine graining for the CG
65 C process with the next lower rank.
66         do i=0,nprocs-1,nfgtasks
67           cgtasks(i/nfgtasks)=i
68         enddo
69         if (lprn) then
70         print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1)
71 c        print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group"
72         endif
73 c        call memmon_print_usage()
74         call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR)
75         call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR)
76         call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR)
77         call MPI_Group_rank(cg_group,me,ierr)
78         call MPI_Group_free(world_group,ierr)
79         call MPI_Group_free(cg_group,ierr)
80 c        print "(a,i5,a)","Processor",myrank," After MPI_Comm_group"
81 c        call memmon_print_usage()
82         if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr)
83         if (lprn) print *," Processor",myrank," CG rank",me
84 C Create communicators containig processes doing "fine grain" tasks. 
85 C The processes within each FG_COMM should have fast communication.
86         kolor=MyRank/nfgtasks
87         key=mod(MyRank,nfgtasks)
88         call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr)
89         call MPI_Comm_size(FG_COMM,fg_size,ierr)
90         if (fg_size.ne.nfgtasks) then
91           write (*,*) "OOOOps... the number of fg tasks is",fg_size,
92      &      " but",nfgtasks," was requested. MyRank=",MyRank
93         endif
94         call MPI_Comm_rank(FG_COMM,fg_rank,ierr)
95         if (fg_size.gt.max_gs_size) then
96           kolor1=fg_rank/max_gs_size
97           key1=mod(fg_rank,max_gs_size)
98           call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr)
99           call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr)
100           call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr)
101         else
102           FG_COMM1=FG_COMM
103           nfgtasks1=nfgtasks
104           fg_rank1=fg_rank
105         endif
106       endif
107       if (lprn) then
108       if (fg_rank.eq.0) then
109       write (*,*) "Processor",MyRank," out of",nprocs,
110      & " rank in CG_COMM",me," size of CG_COMM",nodes,
111      & " size of FG_COMM",fg_size,
112      & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
113       else
114       write (*,*) "Processor",MyRank," out of",nprocs,
115      & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size,
116      & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
117       endif
118       endif
119 C Initialize other variables.
120 c      print '(a)','Before initialize'
121 c      call memmon_print_usage()
122       call initialize
123 c      print '(a,i5,a)','Processor',myrank,' After initialize'
124 c      call memmon_print_usage()
125 C Open task-dependent files.
126 c      print '(a,i5,a)','Processor',myrank,' Before openunits'
127 c      call memmon_print_usage()
128       call openunits
129 c      print '(a,i5,a)','Processor',myrank,' After openunits'
130 c      call memmon_print_usage()
131       if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) 
132      &  write (iout,'(80(1h*)/a/80(1h*))') 
133      & 'United-residue force field calculation - parallel job.'
134 c      print *,"Processor",myrank," exited OPENUNITS"
135       return
136       end
137 C-----------------------------------------------------------------------------
138       subroutine finish_task
139       implicit real*8 (a-h,o-z)
140       include 'DIMENSIONS'
141       include 'mpif.h'
142       include 'COMMON.SETUP'
143       include 'COMMON.CONTROL'
144       include 'COMMON.REMD'
145       include 'COMMON.IOUNITS'
146       include 'COMMON.FFIELD'
147       include 'COMMON.TIME1'
148       include 'COMMON.MD'
149       integer ilen
150       external ilen
151 c
152       call MPI_Barrier(CG_COMM,ierr)
153       if (nfgtasks.gt.1) 
154      &    call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR)
155       time1=MPI_WTIME()
156 c      if (me.eq.king .or. .not. out1file) then
157        write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.'
158        write (iout,*) 'Total wall clock time',time1-walltime,' sec'
159        if (nfgtasks.gt.1) then
160          write (iout,'(80(1h=)/a/(80(1h=)))') 
161      &    "Details of FG communication time"
162           write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') 
163      &    "BROADCAST:",time_bcast,"REDUCE:",time_reduce,
164      &    "GATHER:",time_gather,
165      &    "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,
166      &    "BARRIER ene",time_barrier_e,
167      &    "BARRIER grad",time_barrier_g,"TOTAL:",
168      &    time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv
169      &    +time_barrier_e+time_barrier_g
170           write (*,*) 'Total wall clock time',time1-walltime,' sec'
171           write (*,*) "Processor",me," BROADCAST time",time_bcast,
172      &      " REDUCE time",
173      &      time_reduce," GATHER time",time_gather," SCATTER time",
174      &      time_scatter," SENDRECV",time_sendrecv,
175      &      " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g
176         endif
177 c      endif
178       write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.'
179       if (ilen(tmpdir).gt.0) then
180         write (*,*) "Processor",me,
181      &   ": moving output files to the parent directory..."
182         close(inp)
183         close(istat,status='keep')
184         if (ntwe.gt.0) call move_from_tmp(statname)
185         close(irest2,status='keep')
186         if (modecalc.eq.12.or.
187      &     (modecalc.eq.14 .and. .not.restart1file)) then
188           call move_from_tmp(rest2name) 
189         else if (modecalc.eq.14.and. me.eq.king) then
190           call move_from_tmp(mremd_rst_name)
191         endif
192         if (mdpdb) then
193          close(ipdb,status='keep')
194          call move_from_tmp(pdbname)
195         else if (me.eq.king .or. .not.traj1file) then
196          close(icart,status='keep')
197          call move_from_tmp(cartname)
198         endif
199         if (me.eq.king .or. .not. out1file) then
200           close (iout,status='keep')
201           call move_from_tmp(outname)
202         endif
203       endif
204       return
205       end
206 c-------------------------------------------------------------------------
207       subroutine pattern_receive      
208       implicit real*8 (a-h,o-z)
209       include 'DIMENSIONS'
210       include 'mpif.h'
211       include 'COMMON.SETUP'
212       include 'COMMON.THREAD'
213       include 'COMMON.IOUNITS'
214       integer tag,status(MPI_STATUS_SIZE)
215       integer source,ThreadType
216       logical flag
217       ThreadType=45
218       source=mpi_any_source
219       call mpi_iprobe(source,ThreadType,
220      &                 CG_COMM,flag,status,ierr)
221       do while (flag)
222         write (iout,*) 'Processor ',Me,' is receiving threading',
223      & ' pattern from processor',status(mpi_source)
224         write (*,*) 'Processor ',Me,' is receiving threading',
225      & ' pattern from processor',status(mpi_source)
226         nexcl=nexcl+1
227         call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source),
228      &    ThreadType, CG_COMM,ireq,ierr)
229         write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl),
230      &    iexam(2,nexcl)
231         source=mpi_any_source
232       call mpi_iprobe(source,ThreadType,               
233      &                 CG_COMM,flag,status,ierr)
234       enddo
235       return
236       end
237 c----------------------------------------------------------------------------
238       subroutine pattern_send
239       implicit real*8 (a-h,o-z)
240       include 'DIMENSIONS'
241       include 'mpif.h'
242       include 'COMMON.INFO'
243       include 'COMMON.THREAD'
244       include 'COMMON.IOUNITS'
245       integer source,ThreadType,ireq
246       ThreadType=45 
247       do iproc=0,nprocs-1
248         if (iproc.ne.me .and. .not.Koniec(iproc) ) then
249           call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc,
250      &                  ThreadType, CG_COMM, ireq, ierr)
251           write (iout,*) 'CG processor ',me,' has sent pattern ',
252      &    'to processor',iproc
253           write (*,*) 'CG processor ',me,' has sent pattern ',
254      &    'to processor',iproc
255           write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl)
256         endif
257       enddo
258       return
259       end
260 c-----------------------------------------------------------------------------
261       subroutine send_stop_sig(Kwita)
262       implicit real*8 (a-h,o-z)
263       include 'DIMENSIONS'
264       include 'mpif.h'
265       include 'COMMON.INFO'
266       include 'COMMON.IOUNITS'
267       integer StopType,StopId,iproc,Kwita,NBytes
268       StopType=66
269 c     Kwita=-1
270 C     print *,'CG processor',me,' StopType=',StopType
271       Koniec(me)=.true.
272       if (me.eq.king) then
273 C Master sends the STOP signal to everybody.
274         write (iout,'(a,a)') 
275      &   'Master is sending STOP signal to other processors.'
276         do iproc=1,nprocs-1
277           print *,'Koniec(',iproc,')=',Koniec(iproc)
278           if (.not. Koniec(iproc)) then
279             call mpi_send(Kwita,1,mpi_integer,iproc,StopType,
280      &          mpi_comm_world,ierr)
281             write (iout,*) 'Iproc=',iproc,' StopID=',StopID
282             write (*,*) 'Iproc=',iproc,' StopID=',StopID
283           endif
284         enddo
285       else
286 C Else send the STOP signal to Master.
287         call mpi_send(Kwita,1,mpi_integer,MasterID,StopType,
288      &          mpi_comm_world,ierr)
289         write (iout,*) 'CG processor=',me,' StopID=',StopID
290         write (*,*) 'CG processor=',me,' StopID=',StopID
291       endif
292       return
293       end 
294 c-----------------------------------------------------------------------------
295       subroutine recv_stop_sig(Kwita)
296       implicit real*8 (a-h,o-z)
297       include 'DIMENSIONS' 
298       include 'mpif.h'
299       include 'COMMON.INFO'
300       include 'COMMON.IOUNITS'
301       integer source,StopType,StopId,iproc,Kwita
302       logical flag
303       StopType=66
304       Kwita=0
305       source=mpi_any_source
306 c     print *,'CG processor:',me,' StopType=',StopType
307       call mpi_iprobe(source,StopType,
308      &                 mpi_comm_world,flag,status,ierr)
309       do while (flag)
310         Koniec(status(mpi_source))=.true.
311         write (iout,*) 'CG processor ',me,' is receiving STOP signal',
312      & ' from processor',status(mpi_source)
313         write (*,*) 'CG processor ',me,' is receiving STOP signal',
314      & ' from processor',status(mpi_source)
315         call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType,
316      &           mpi_comm_world,ireq,ierr)
317         call mpi_iprobe(source,StopType,
318      &                 mpi_comm_world,flag,status,ierr)
319       enddo       
320       return
321       end
322 c-----------------------------------------------------------------------------
323       subroutine send_MCM_info(ione)
324       implicit real*8 (a-h,o-z)
325       include 'DIMENSIONS'
326       include 'mpif.h'
327       include 'COMMON.SETUP'
328       include 'COMMON.MCM'
329       include 'COMMON.IOUNITS'
330       integer tag,status(MPI_STATUS_SIZE)
331       integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes
332       common /aaaa/ isend,irecv
333       integer nsend
334       save nsend
335       nsend=nsend+1
336       MCM_info_Type=77
337 cd    write (iout,'(a,i4,a)') 'CG Processor',me,
338 cd   & ' is sending MCM info to Master.'
339       write (*,'(a,i4,a,i8)') 'CG processor',me,
340      & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID
341       call mpi_isend(ione,1,mpi_integer,MasterID,
342      &               MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr)
343 cd    write (iout,*) 'CG processor',me,' has sent info to the master;',
344 cd   &    ' MCM_info_ID=',MCM_info_ID
345       write (*,*) 'CG processor',me,' has sent info to the master;',
346      &    ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr
347       isend=0
348       irecv=0
349       return
350       end 
351 c----------------------------------------------------------------------------
352       subroutine receive_MCM_info
353       implicit real*8 (a-h,o-z)
354       include 'DIMENSIONS'
355       include 'mpif.h'
356       include 'COMMON.SETUP'
357       include 'COMMON.MCM'
358       include 'COMMON.IOUNITS'
359       integer tag,status(MPI_STATUS_SIZE)
360       integer source,MCM_info_Type,MCM_info_ID,iproc,ione
361       logical flag
362       MCM_info_Type=77
363       source=mpi_any_source
364 c     print *,'source=',source,' dontcare=',dontcare
365       call mpi_iprobe(source,MCM_info_Type,
366      &                mpi_comm_world,flag,status,ierr)
367       do while (flag)
368         source=status(mpi_source)
369         itask=source/fgProcs+1
370 cd      write (iout,*) 'Master is receiving MCM info from processor ',
371 cd   &                 source,' itask',itask
372         write (*,*) 'Master is receiving MCM info from processor ',
373      &                 source,' itask',itask
374         call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type,
375      &                  mpi_comm_world,MCM_info_ID,ierr)
376 cd      write (iout,*) 'Received from processor',source,' IONE=',ione 
377         write (*,*) 'Received from processor',source,' IONE=',ione 
378         nacc_tot=nacc_tot+1
379         if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1
380 cd      print *,'nsave_part(',itask,')=',nsave_part(itask)
381 cd      write (iout,*) 'Nacc_tot=',Nacc_tot
382 cd      write (*,*) 'Nacc_tot=',Nacc_tot
383         source=mpi_any_source
384               call mpi_iprobe(source,MCM_info_Type,
385      &                mpi_comm_world,flag,status,ierr)
386       enddo
387       return
388       end 
389 c---------------------------------------------------------------------------
390       subroutine send_thread_results
391       implicit real*8 (a-h,o-z)
392       include 'DIMENSIONS'
393       include 'mpif.h'
394       include 'COMMON.SETUP'
395       include 'COMMON.THREAD'
396       include 'COMMON.IOUNITS'
397       integer tag,status(MPI_STATUS_SIZE)
398       integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
399      &   EnerID,msglen,nbytes
400       double precision buffer(20*maxthread+2) 
401       ThreadType=444
402       EnerType=555
403       ipatt(1,nthread+1)=nthread
404       ipatt(2,nthread+1)=nexcl
405       do i=1,nthread
406         do j=1,n_ene
407           ener(j,i+nthread)=ener0(j,i)
408         enddo
409       enddo
410       ener(1,2*nthread+1)=max_time_for_thread
411       ener(2,2*nthread+1)=ave_time_for_thread
412 C Send the IPATT array
413       write (iout,*) 'CG processor',me,
414      & ' is sending IPATT array to master: NTHREAD=',nthread
415       write (*,*) 'CG processor',me,
416      & ' is sending IPATT array to master: NTHREAD=',nthread
417       msglen=2*nthread+2
418       call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID,
419      & ThreadType,mpi_comm_world,ierror)
420       write (iout,*) 'CG processor',me,
421      & ' has sent IPATT array to master MSGLEN',msglen
422       write (*,*) 'CG processor',me,
423      & ' has sent IPATT array to master MSGLEN',msglen
424 C Send the energies.
425       msglen=n_ene2*nthread+2
426       write (iout,*) 'CG processor',me,' is sending energies to master.'
427       write (*,*) 'CG processor',me,' is sending energies to master.'
428       call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID,
429      & EnerType,mpi_comm_world,ierror)
430       write (iout,*) 'CG processor',me,' has sent energies to master.'
431       write (*,*) 'CG processor',me,' has sent energies to master.'
432       return
433       end
434 c----------------------------------------------------------------------------
435       subroutine receive_thread_results(iproc)
436       implicit real*8 (a-h,o-z)
437       include 'DIMENSIONS'
438       include 'mpif.h'
439       include 'COMMON.INFO'
440       include 'COMMON.THREAD'
441       include 'COMMON.IOUNITS'
442       integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
443      &   EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp
444       double precision buffer(20*maxthread+2),max_time_for_thread_t,
445      & ave_time_for_thread_t
446       logical flag
447       ThreadType=444
448       EnerType=555
449 C Receive the IPATT array
450       call mpi_probe(iproc,ThreadType,
451      &                 mpi_comm_world,status,ierr)
452       call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR)
453       write (iout,*) 'Master is receiving IPATT array from processor:',
454      &    iproc,' MSGLEN',msglen
455       write (*,*) 'Master is receiving IPATT array from processor:',
456      &    iproc,' MSGLEN',msglen
457       call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc,
458      & ThreadType,
459      & mpi_comm_world,status,ierror)
460       write (iout,*) 'Master has received IPATT array from processor:',
461      &    iproc,' MSGLEN=',msglen
462       write (*,*) 'Master has received IPATT array from processor:',
463      &    iproc,' MSGLEN=',msglen
464       nthread_temp=ipatt(1,nthread+msglen/2)
465       nexcl_temp=ipatt(2,nthread+msglen/2)
466 C Receive the energies.
467       call mpi_probe(iproc,EnerType,
468      &                 mpi_comm_world,status,ierr)
469       call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR)
470       write (iout,*) 'Master is receiving energies from processor:',
471      &    iproc,' MSGLEN=',MSGLEN
472       write (*,*) 'Master is receiving energies from processor:',
473      &    iproc,' MSGLEN=',MSGLEN
474       call mpi_recv(ener(1,nthread+1),msglen,
475      & MPI_DOUBLE_PRECISION,iproc,
476      & EnerType,MPI_COMM_WORLD,status,ierror)
477       write (iout,*) 'Msglen=',Msglen
478       write (*,*) 'Msglen=',Msglen
479       write (iout,*) 'Master has received energies from processor',iproc
480       write (*,*) 'Master has received energies from processor',iproc
481       write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
482       write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
483       do i=1,nthread_temp
484         do j=1,n_ene
485           ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i)
486         enddo
487       enddo
488       max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1)
489       ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1)
490       write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
491       write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
492       write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
493       write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
494       if (max_time_for_thread_t.gt.max_time_for_thread)
495      & max_time_for_thread=max_time_for_thread_t
496       ave_time_for_thread=(nthread*ave_time_for_thread+
497      & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp)
498       nthread=nthread+nthread_temp
499       return
500       end
501 #else
502       subroutine init_task
503       implicit real*8 (a-h,o-z)
504       include 'DIMENSIONS'
505       include 'COMMON.SETUP'
506       me=0
507       myrank=0
508       fg_rank=0
509       fg_size=1
510       nodes=1
511       nprocs=1
512       call initialize
513       call openunits
514       write (iout,'(80(1h*)/a/80(1h*))') 
515      & 'United-residue force field calculation - serial job.'
516       return
517       end
518 #endif