comm_mpi.f 38.1 KB
Newer Older
1
c-----------------------------------------------------------------------
2
      subroutine setupcomm(comm,newcomm,newcommg,path_in,session_in)
3
4
5
6
      include 'mpif.h'
      include 'SIZE'
      include 'PARALLEL' 
      include 'TSTEP' 
7
8
      include 'INPUT'

9
10
      integer comm, newcomm, newcommg
      character session_in*(*), path_in*(*)
11
      logical flag
12
13
14
15
16
17
18
    
      common /nekmpi/ mid,mp,nekcomm,nekgroup,nekreal
 
      integer nid_global_root(0:nsessmax-1)
      character*132 session_mult(0:nsessmax-1), path_mult(0:nsessmax-1)

      logical ifhigh
Stefan's avatar
Stefan committed
19
      logical mpi_is_initialized
20

Stefan K's avatar
Stefan K committed
21
22
      integer*8 ntags

23
      call mpi_initialized(mpi_is_initialized, ierr)
Stefan's avatar
Stefan committed
24
      if (.not.mpi_is_initialized) call mpi_init(ierr)
25
26
27
28
29
30
31

      call mpi_comm_dup(comm,newcommg,ierr)
      newcomm = newcommg
      nekcomm = newcommg 

      call mpi_comm_size(nekcomm,np_global,ierr)
      call mpi_comm_rank(nekcomm,nid_global,ierr)
32
33

      ! check upper tag size limit
34
      call mpi_comm_get_attr(nekcomm,MPI_TAG_UB,ntags,flag,ierr)
Stefan K's avatar
Stefan K committed
35
      if (ntags .lt. np_global) then
36
37
38
39
40
41
42
43
         if(nid_global.eq.0) write(6,*) 'ABORT: MPI_TAG_UB too small!'
         call exitt
      endif

      ! set defaults
      nid         = nid_global
      ifneknek    = .false.
      ifneknekc   = .false. ! session are uncoupled
Stefan's avatar
Stefan committed
44
      nsessions   = 1
45
46

      ierr = 0
Stefan's avatar
Stefan committed
47
      nlin = 0
48
      if (nid .eq. 0) then
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
         l = ltrunc(session_in,len(session_in))
         if (l .gt. 0) then
            call blank(session_mult(0),132)
            call chcopy(session_mult(0), session_in, l)
            l = ltrunc(path_in,len(path_in))
            call blank(path_mult(0)   ,132)
            call chcopy(path_mult(0), path_in, l)
         else
           write(6,*) 'Reading session file ...'
           open (unit=8,file='SESSION.NAME',status='old',err=24)
 21        read (8,*,END=22)
           nlin = nlin + 1 
           goto 21
 22        rewind(8)
           if (nlin.gt.2) read(8,*,err=24) nsessions
           if (nsessions.gt.1) read(8,*,err=24) ifneknekc
           do n=0,nsessions-1
              call blank(session_mult(n),132)
              call blank(path_mult(n)   ,132)
              read(8,11,err=24) session_mult(n)
              read(8,11,err=24) path_mult(n)
              if (nsessions.gt.1) read(8,*,err=24)  npsess(n)
           enddo
 11        format(a132)
           close(8)
         endif
75
76
77
78
79
80
81
82
         write(6,*) 'Number of sessions:',nsessions
         goto 23
 24      ierr = 1
      endif
 23   continue
      call err_chk(ierr,' Error while reading SESSION.NAME!$')

      call bcast(nsessions,ISIZE)
83
84
85
86
      if (nsessions .gt. nsessmax) 
     &   call exitti('nsessmax in SIZE too low!$',nsessmax)
      if (nsessions .gt. 1) ifneknek = .true.

87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
      call bcast(ifneknekc,LSIZE)
      do n = 0,nsessions-1
         call bcast(npsess(n),ISIZE)
         call bcast(session_mult(n),132*CSIZE)
         call bcast(path_mult(n),132*CSIZE)
      enddo

      ! single session run
      if (.not.ifneknek) then
         ifneknekc = .false.
         session   = session_mult(0)
         path      = path_mult(0)
         return
      endif
 
c     Check if specified number of ranks in each session is consistent 
c     with the total number of ranks
      npall=0
      do n=0,nsessions-1
         npall=npall+npsess(n)
      enddo
      if (npall.ne.np_global) 
     &   call exitti('Number of ranks does not match!$',npall)

c     Assign key for splitting into multiple groups
      nid_global_root_next=0
      do n=0,nsessions-1
         nid_global_root(n)=nid_global_root_next
         nid_global_root_next=nid_global_root(n)+npsess(n)
         if (nid_global.ge.nid_global_root(n).and.
     &       nid_global.lt.nid_global_root_next) idsess = n
      enddo
119
      call mpi_comm_split(comm,idsess,nid,newcomm,ierr)
120
121
122
123
124
 
      session = session_mult(idsess)
      path    = path_mult   (idsess)

      if (ifneknekc) then
Stefan K's avatar
Stefan K committed
125
         if (nsessions.gt.2) call exitti(
126
127
128
129
130
131
     &     'More than 2 coupled sessions are currently not supported!$',
     $     nsessions)
      endif 

      return
      end
132
c---------------------------------------------------------------------
133
      subroutine iniproc()
stefanke's avatar
stefanke committed
134
135
      include 'SIZE'
      include 'PARALLEL'
Stefan K's avatar
#456    
Stefan K committed
136
      include 'INPUT'
stefanke's avatar
stefanke committed
137
138
      include 'mpif.h'

stefanke's avatar
stefanke committed
139
      common /nekmpi/ nid_,np_,nekcomm,nekgroup,nekreal
stefanke's avatar
stefanke committed
140

stefanke's avatar
stefanke committed
141
      logical flag
stefanke's avatar
stefanke committed
142

143
144
145
146
      nid  = mynode()
      nid_ = nid
      np   = numnodes()
      np_  = np
stefanke's avatar
stefanke committed
147

148
      nio = -1             ! Default io flag 
Stefan K's avatar
#456    
Stefan K committed
149
      if (nid.eq.0) nio=0  ! Only node 0 writes
150

Stefan K's avatar
#456    
Stefan K committed
151
152
153
154
155
156
157
158
      if (nid.eq.nio) then
         if (ifneknek) then
           call set_stdout(' ',idsess) 
         else
           call set_stdout(' ',-1) 
         endif
      endif

Stefan's avatar
Stefan committed
159
160
161
162
163
164
      if (wdsize .eq. 4)
     $   call exitti('Single precision mode not supported!',wdsize)

      call MPI_Type_Extent(MPI_DOUBLE_PRECISION,isize_mpi,ierr)
      if (isize_mpi .ne. wdsize) then
         call exitti('MPI real size does not match$',isize_mpi)
stefanke's avatar
stefanke committed
165
      endif
stefanke's avatar
stefanke committed
166

Stefan's avatar
Stefan committed
167
168
169
      call MPI_Type_Extent(MPI_INTEGER,isize_mpi,ierr)
       if (isize_mpi .ne. isize) then
         call exitti('MPI integer size does not match$',isize_mpi)
stefanke's avatar
stefanke committed
170
      endif
Stefan's avatar
Stefan committed
171
172
173
174
175
176

      call MPI_Type_Extent(MPI_INTEGER8,isize_mpi,ierr)
       if (isize_mpi .ne. isize8) then
         call exitti('MPI integer8 size does not match$',isize_mpi)
      endif

stefanke's avatar
stefanke committed
177
      PID = 0
stefanke's avatar
stefanke committed
178
179
      NULLPID=0
      NODE0=0
stefanke's avatar
stefanke committed
180
181
      NODE= NID+1

182
183
184
185
186
187
188
189
190
C     Test timer accuracy
      edif = 0.0
      do i = 1,10
         e1 = dnekclock()
         e2 = dnekclock()
         edif = edif + e2-e1
      enddo
      edif = edif/10.

Stefan K's avatar
Stefan K committed
191
      call fgslib_crystal_setup(cr_h,nekcomm,np)  ! set cr handle to new instance
stefanke's avatar
stefanke committed
192
193
194
195
      return
      end
c-----------------------------------------------------------------------
      subroutine gop( x, w, op, n)
196

stefanke's avatar
stefanke committed
197
c     Global vector commutative operation
198
199
200

      include 'CTIMER'

stefanke's avatar
stefanke committed
201
202
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
203

stefanke's avatar
stefanke committed
204
205
      real x(n), w(n)
      character*3 op
206
207
208

      if (ifsync) call nekgsync()

Stefan's avatar
Stefan committed
209
#ifdef TIMER
210
211
212
213
214
215
216
217
      if (icalld.eq.0) then
        tgop =0.0d0
        ngop =0
        icalld=1
      endif
      ngop = ngop + 1
      etime1=dnekclock()
#endif
stefanke's avatar
stefanke committed
218
219
c
      if (op.eq.'+  ') then
Stefan's avatar
Stefan committed
220
      call mpi_allreduce(x,w,n,MPI_DOUBLE_PRECISION,mpi_sum,nekcomm,ie)
stefanke's avatar
stefanke committed
221
      elseif (op.EQ.'M  ') then
Stefan's avatar
Stefan committed
222
      call mpi_allreduce(x,w,n,MPI_DOUBLE_PRECISION,mpi_max,nekcomm,ie)
stefanke's avatar
stefanke committed
223
      elseif (op.EQ.'m  ') then
Stefan's avatar
Stefan committed
224
      call mpi_allreduce(x,w,n,MPI_DOUBLE_PRECISION,mpi_min,nekcomm,ie)
stefanke's avatar
stefanke committed
225
      elseif (op.EQ.'*  ') then
Stefan's avatar
Stefan committed
226
      call mpi_allreduce(x,w,n,MPI_DOUBLE_PRECISION,mpi_prod,nekcomm,ie)
stefanke's avatar
stefanke committed
227
      else
Stefan's avatar
Stefan committed
228
229
      write(6,*) nid,' OP ',op,' not supported.  ABORT in GOP.'
      call exitt
stefanke's avatar
stefanke committed
230
      endif
fischer's avatar
fischer committed
231

stefanke's avatar
stefanke committed
232
      call copy(x,w,n)
fischer's avatar
fischer committed
233

Stefan's avatar
Stefan committed
234
#ifdef TIMER
235
236
237
      tgop =tgop +(dnekclock()-etime1)
#endif

stefanke's avatar
stefanke committed
238
239
240
241
242
      return
      end
c-----------------------------------------------------------------------
      subroutine igop( x, w, op, n)
c
stefanke's avatar
stefanke committed
243
c     Global vector commutative operation
stefanke's avatar
stefanke committed
244
245
246
c
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
fischer's avatar
fischer committed
247

stefanke's avatar
stefanke committed
248
249
      integer x(n), w(n)
      character*3 op
fischer's avatar
fischer committed
250

stefanke's avatar
stefanke committed
251
      if     (op.eq.'+  ') then
stefanke's avatar
stefanke committed
252
253
254
255
256
257
258
259
        call mpi_allreduce (x,w,n,mpi_integer,mpi_sum ,nekcomm,ierr)
      elseif (op.EQ.'M  ') then
        call mpi_allreduce (x,w,n,mpi_integer,mpi_max ,nekcomm,ierr)
      elseif (op.EQ.'m  ') then
        call mpi_allreduce (x,w,n,mpi_integer,mpi_min ,nekcomm,ierr)
      elseif (op.EQ.'*  ') then
        call mpi_allreduce (x,w,n,mpi_integer,mpi_prod,nekcomm,ierr)
      else
fischer's avatar
fischer committed
260
        write(6,*) nid,' OP ',op,' not supported.  ABORT in igop.'
stefanke's avatar
stefanke committed
261
262
        call exitt
      endif
fischer's avatar
fischer committed
263

stefanke's avatar
stefanke committed
264
      call icopy(x,w,n)
fischer's avatar
fischer committed
265

266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
      return
      end
c-----------------------------------------------------------------------
      subroutine i8gop( x, w, op, n)
c
c     Global vector commutative operation
c
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal

      integer*8 x(n), w(n)
      character*3 op

      if     (op.eq.'+  ') then
        call mpi_allreduce (x,w,n,mpi_integer8,mpi_sum ,nekcomm,ierr)
      elseif (op.EQ.'M  ') then
        call mpi_allreduce (x,w,n,mpi_integer8,mpi_max ,nekcomm,ierr)
      elseif (op.EQ.'m  ') then
        call mpi_allreduce (x,w,n,mpi_integer8,mpi_min ,nekcomm,ierr)
      elseif (op.EQ.'*  ') then
        call mpi_allreduce (x,w,n,mpi_integer8,mpi_prod,nekcomm,ierr)
      else
        write(6,*) nid,' OP ',op,' not supported.  ABORT in igop.'
        call exitt
      endif

      call i8copy(x,w,n)

stefanke's avatar
stefanke committed
294
295
296
297
298
299
300
      return
      end
c-----------------------------------------------------------------------
      subroutine csend(mtype,buf,len,jnid,jpid)
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      real*4 buf(1)
stefanke's avatar
stefanke committed
301

stefanke's avatar
stefanke committed
302
      call mpi_send (buf,len,mpi_byte,jnid,mtype,nekcomm,ierr)
stefanke's avatar
stefanke committed
303

stefanke's avatar
stefanke committed
304
305
306
      return
      end
c-----------------------------------------------------------------------
stefanke's avatar
stefanke committed
307
      subroutine crecv(mtype,buf,lenm)
stefanke's avatar
stefanke committed
308
309
310
311
312
313
314
315
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer status(mpi_status_size)
C
      real*4 buf(1)
      len = lenm
      jnid = mpi_any_source

Ron Rahaman's avatar
Ron Rahaman committed
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
      call mpi_recv (buf,len,mpi_byte
     $              ,jnid,mtype,nekcomm,status,ierr)
c
      if (len.gt.lenm) then 
          write(6,*) nid,'long message in mpi_crecv:',len,lenm
          call exitt
      endif
c
      return
      end
c-----------------------------------------------------------------------
      subroutine crecv2(mtype,buf,lenm,jnid)
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer status(mpi_status_size)
C
      real*4 buf(1)
      len = lenm

stefanke's avatar
stefanke committed
335
      call mpi_recv (buf,len,mpi_byte
stefanke's avatar
stefanke committed
336
     $              ,jnid,mtype,nekcomm,status,ierr)
stefanke's avatar
stefanke committed
337
c
stefanke's avatar
stefanke committed
338
339
340
341
      if (len.gt.lenm) then 
          write(6,*) nid,'long message in mpi_crecv:',len,lenm
          call exitt
      endif
stefanke's avatar
stefanke committed
342
343
344
345
c
      return
      end
c-----------------------------------------------------------------------
stefanke's avatar
stefanke committed
346
      subroutine crecv3(mtype,buf,len,lenm)
stefanke's avatar
stefanke committed
347
348
349
350
351
352
353
354
355
356
357
358
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer status(mpi_status_size)
C
      real*4 buf(1)
      len = lenm
      jnid = mpi_any_source

      call mpi_recv (buf,len,mpi_byte
     $            ,jnid,mtype,nekcomm,status,ierr)
      call mpi_get_count (status,mpi_byte,len,ierr)
c
stefanke's avatar
stefanke committed
359
360
      if (len.gt.lenm) then 
          write(6,*) nid,'long message in mpi_crecv:',len,lenm
361
          call exitt
stefanke's avatar
stefanke committed
362
      endif
stefanke's avatar
stefanke committed
363
364
365
366
367
368
369
c
      return
      end
c-----------------------------------------------------------------------
      integer function numnodes()
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
stefanke's avatar
stefanke committed
370

stefanke's avatar
stefanke committed
371
      call mpi_comm_size (nekcomm, numnodes , ierr)
stefanke's avatar
stefanke committed
372

stefanke's avatar
stefanke committed
373
374
375
376
377
378
379
      return
      end
c-----------------------------------------------------------------------
      integer function mynode()
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer myid
stefanke's avatar
stefanke committed
380

stefanke's avatar
stefanke committed
381
382
      call mpi_comm_rank (nekcomm, myid, ierr)
      mynode = myid
stefanke's avatar
stefanke committed
383

stefanke's avatar
stefanke committed
384
385
386
      return
      end
c-----------------------------------------------------------------------
stefanke's avatar
stefanke committed
387
      real*8 function dnekclock()
stefanke's avatar
stefanke committed
388
389
      include 'mpif.h'
c
stefanke's avatar
   
stefanke committed
390
391
392
393
394
395
396
397
      dnekclock=mpi_wtime()
c
      return
      end
c-----------------------------------------------------------------------
      real*8 function dnekclock_sync()
      include 'mpif.h'
c
398
      call nekgsync()
stefanke's avatar
   
stefanke committed
399
      dnekclock_sync=mpi_wtime()
stefanke's avatar
stefanke committed
400
401
402
403
404
405
406
407
408
409
410
c
      return
      end
c-----------------------------------------------------------------------
      subroutine lbcast(ifif)
C
C     Broadcast logical variable to all processors.
C
      include 'SIZE'
      include 'PARALLEL'
      include 'mpif.h'
fischer's avatar
fischer committed
411

stefanke's avatar
stefanke committed
412
      logical ifif
fischer's avatar
fischer committed
413

stefanke's avatar
stefanke committed
414
      if (np.eq.1) return
fischer's avatar
fischer committed
415

stefanke's avatar
stefanke committed
416
417
418
419
420
      item=0
      if (ifif) item=1
      call bcast(item,isize)
      ifif=.false.
      if (item.eq.1) ifif=.true.
fischer's avatar
fischer committed
421

stefanke's avatar
stefanke committed
422
423
424
425
426
427
428
      return
      end
c-----------------------------------------------------------------------
      subroutine bcast(buf,len)
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      real*4 buf(1)
stefanke's avatar
stefanke committed
429

stefanke's avatar
stefanke committed
430
      call mpi_bcast (buf,len,mpi_byte,0,nekcomm,ierr)
stefanke's avatar
stefanke committed
431

stefanke's avatar
stefanke committed
432
433
434
      return
      end
c-----------------------------------------------------------------------
stefanke's avatar
stefanke committed
435
      subroutine create_comm(inewcomm)
stefanke's avatar
stefanke committed
436
      include 'mpif.h'
peet's avatar
peet committed
437
438
439
440
441
442
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal

c      call mpi_comm_group (mpi_comm_world,itmp,ierr)
c      call mpi_comm_create (mpi_comm_world,itmp,icomm,ierr)
c      call mpi_group_free (itmp,ierr)

stefanke's avatar
stefanke committed
443
      call mpi_comm_dup(nekcomm,inewcomm,ierr)
stefanke's avatar
stefanke committed
444

stefanke's avatar
stefanke committed
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
      return
      end
c-----------------------------------------------------------------------
      function isend(msgtag,x,len,jnid,jpid)
c
c     Note: len in bytes
c
      integer x(1)
C
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
C
      call mpi_isend (x,len,mpi_byte,jnid,msgtag
     $       ,nekcomm,imsg,ierr)
      isend = imsg
c     write(6,*) nid,' isend:',imsg,msgtag,len,jnid,(x(k),k=1,len/4)
c
      return
      end
c-----------------------------------------------------------------------
      function irecv(msgtag,x,len)
c
c     Note: len in bytes
c
      integer x(1)
C
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
C
      call mpi_irecv (x,len,mpi_byte,mpi_any_source,msgtag
     $       ,nekcomm,imsg,ierr)
      irecv = imsg
c     write(6,*) nid,' irecv:',imsg,msgtag,len
stefanke's avatar
stefanke committed
478
c
stefanke's avatar
stefanke committed
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
c
      return
      end
c-----------------------------------------------------------------------
      subroutine msgwait(imsg)
c
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer status(mpi_status_size)
c
c     write(6,*) nid,' msgwait:',imsg
c
      call mpi_wait (imsg,status,ierr)
c
      return
      end
c-----------------------------------------------------------------------
496
      subroutine nekgsync()
fischer's avatar
fischer committed
497

stefanke's avatar
stefanke committed
498
499
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
fischer's avatar
fischer committed
500

stefanke's avatar
stefanke committed
501
      call mpi_barrier(nekcomm,ierr)
fischer's avatar
fischer committed
502

fischer's avatar
fischer committed
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
      return
      end
c-----------------------------------------------------------------------
      subroutine exittr(stringi,rdata,idata)
      character*1 stringi(132)
      character*1 stringo(132)
      character*25 s25
      include 'SIZE'
      include 'TOTAL'
      include 'CTIMER'

      call blank(stringo,132)
      call chcopy(stringo,stringi,132)
      len = indx1(stringo,'$',1)
      write(s25,25) rdata,idata
   25 format(1x,1p1e14.6,i10)
      call chcopy(stringo(len),s25,25)

      if (nid.eq.0) write(6,1) (stringo(k),k=1,len+24)
    1 format('EXIT: ',132a1)

      call exitt

526
527
528
      return
      end
c-----------------------------------------------------------------------
529
530
531
      subroutine exitti(stringi,idata)
      character*1 stringi(132)
      character*1 stringo(132)
532
533
534
535
536
      character*11 s11
      include 'SIZE'
      include 'TOTAL'
      include 'CTIMER'

537
538
539
      call blank(stringo,132)
      call chcopy(stringo,stringi,132)
      len = indx1(stringo,'$',1)
540
541
      write(s11,11) idata
   11 format(1x,i10)
542
      call chcopy(stringo(len),s11,11)
543

544
      if (nid.eq.0) write(6,1) (stringo(k),k=1,len+10)
heisey's avatar
heisey committed
545
    1 format('EXIT: ',132a1)
546
547
548

      call exitt

stefanke's avatar
stefanke committed
549
550
      return
      end
stefanke's avatar
stefanke committed
551
552
553
c-----------------------------------------------------------------------
      subroutine err_chk(ierr,string)
      character*1 string(132)
stefanke's avatar
stefanke committed
554
555
      character*1 ostring(132)
      character*10 s10
stefanke's avatar
stefanke committed
556
      include 'SIZE'
557
558
c     include 'TOTAL'
c     include 'CTIMER'
stefanke's avatar
stefanke committed
559
560
561
562
563

      ierr = iglsum(ierr,1)
      if(ierr.eq.0) return 

      len = indx1(string,'$',1)
stefanke's avatar
stefanke committed
564
565
566
      call blank(ostring,132)
      write(s10,11) ierr
   11 format(1x,' ierr=',i3)
stefanke's avatar
stefanke committed
567

stefanke's avatar
stefanke committed
568
569
570
571
      call chcopy(ostring,string,len-1)
      call chcopy(ostring(len),s10,10)

      if (nid.eq.0) write(6,1) (ostring(k),k=1,len+10)
stefanke's avatar
stefanke committed
572
573
574
575
576
577
578
    1 format('ERROR: ',132a1)

      call exitt

      return
      end
c
579
580
c-----------------------------------------------------------------------
      subroutine exitt0
Stefan K's avatar
Stefan K committed
581

582
583
      include 'SIZE'
      include 'TOTAL'
stefanke's avatar
stefanke committed
584

Stefan K's avatar
Stefan K committed
585
586
587
588
589
      if (nid.eq.0) then
         write(6,*) ' '
         write(6,'(A)') 'run successful: dying ...'
         write(6,*) ' '
      endif
stefanke's avatar
stefanke committed
590

Stefan K's avatar
Stefan K committed
591
592
593
c      if (nid.eq.0) call close_files
      call print_runtime_info
      call nek_die(0) 
594
595
596

      return
      end
stefanke's avatar
stefanke committed
597
598
c-----------------------------------------------------------------------
      subroutine exitt
Stefan K's avatar
Stefan K committed
599

stefanke's avatar
stefanke committed
600
601
      include 'SIZE'
      include 'TOTAL'
stefanke's avatar
stefanke committed
602

Stefan K's avatar
Stefan K committed
603
604
605
606
607
      if (nid.eq.0) then
         write(6,*) ' '
         write(6,'(A)') 'an error occured: dying ...'
         write(6,*) ' '
      endif
608

Stefan K's avatar
Stefan K committed
609
610
c      call print_stack()
c      if (nid.eq.0) call close_files
611
c      call print_runtime_info
Stefan K's avatar
Stefan K committed
612
613
614
615
616
617
618
619
620
621
      call nek_die(1) 
 
      return
      end
c-----------------------------------------------------------------------
      subroutine print_runtime_info
      include 'SIZE'
      include 'TOTAL'
      include 'CTIMER'
      include 'mpif.h'
fischer's avatar
fischer committed
622

stefanke's avatar
stefanke committed
623
#ifdef PAPI
624
      gflops = glsum(dnekgflops(),1)
stefanke's avatar
stefanke committed
625
626
#endif

Stefan K's avatar
Stefan K committed
627
      tstop  = dnekclock_sync()
stefanke's avatar
stefanke committed
628
      ttotal = tstop-etimes
629
      tsol   = max(ttime - tprep,0.0)
Stefan K's avatar
Stefan K committed
630
      nxyz   = lx1*ly1*lz1
631

632
633
      dtmp4 = glsum(getmaxrss(),1)/1e9

634
635
636
637
      if (nid.eq.0) then 
         dtmp1 = 0
         dtmp2 = 0
         if(istep.gt.0) then
fischer's avatar
fischer committed
638
           dgp   = nvtot
639
           dgp   = max(dgp,1.)*max(istep,1)
Stefan K's avatar
Stefan K committed
640
641
642
           dtmp0 = np*(ttime-tprep)
           dtmp1 = 0
           if (dtmp0.gt.0) dtmp1 = dgp/dtmp0 
643
           dtmp2 = (ttime-tprep)/max(istep,1)
644
         endif 
stefanke's avatar
stefanke committed
645
         write(6,*) ' '
Stefan K's avatar
Stefan K committed
646
         write(6,'(5(A,1p1e13.5,A,/))') 
stefanke's avatar
stefanke committed
647
     &       'total elapsed time             : ',ttotal, ' sec'
648
     &      ,'total solver time w/o IO       : ',tsol,   ' sec'
stefanke's avatar
stefanke committed
649
     &      ,'time/timestep                  : ',dtmp2 , ' sec'
650
     &      ,'avg throughput per timestep    : ',dtmp1 , ' gridpts/CPUs'
651
     &      ,'total max memory usage         : ',dtmp4 , ' GB'
stefanke's avatar
stefanke committed
652
#ifdef PAPI
653
654
         write(6,'(1(A,1p1e13.5,/))') 
     &      ,'total Gflops/s                 : ',gflops
stefanke's avatar
stefanke committed
655
#endif
stefanke's avatar
stefanke committed
656
      endif 
stefanke's avatar
stefanke committed
657
      call flush_io
fischer's avatar
fischer committed
658

Stefan K's avatar
Stefan K committed
659
660
661
662
663
664
665
666
      return
      end
c-----------------------------------------------------------------------
      subroutine nek_die(ierr)
      include 'SIZE'
      include 'mpif.h'

      call mpi_finalize (ierr_)
667
      call cexit(ierr)
Stefan K's avatar
Stefan K committed
668
 
Stefan K's avatar
Stefan K committed
669
670
671
672
673
674
675
      return
      end
c-----------------------------------------------------------------------
      subroutine fgslib_userExitHandler(istatus)

      call exitt

stefanke's avatar
stefanke committed
676
677
678
      return
      end
c-----------------------------------------------------------------------
679
680
      subroutine printHeader

Stefan's avatar
Stefan committed
681
682
683
684
685
686
687
688
689
      include 'SIZE'
      include 'PARALLEL'

      include 'HEADER'
      write(6,*) 'Number of MPI ranks :', np
c      WRITE(6,*) 'REAL     wdsize     :',WDSIZE
c      WRITE(6,*) 'INTEGER  wdsize     :',ISIZE
c      WRITE(6,*) 'INTEGER8 wdsize     :',ISIZE8
      WRITE(6,*) ' '
stefanke's avatar
stefanke committed
690
691
692

      return
      end
693
c-----------------------------------------------------------------------
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
      function igl_running_sum(in)
c
      include 'mpif.h'
      common /nekmpi/ nid,np,nekcomm,nekgroup,nekreal
      integer status(mpi_status_size)
      integer x,w,r

      x = in  ! running sum
      w = in  ! working buff
      r = 0   ! recv buff

      call mpi_scan(x,r,1,mpi_integer,mpi_sum,nekcomm,ierr)
      igl_running_sum = r

      return
      end
fischer's avatar
fischer committed
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
c-----------------------------------------------------------------------
      subroutine platform_timer(ivb) ! mxm, ping-pong, and all_reduce timer

      include 'SIZE'
      include 'TOTAL'


      call mxm_test_all(nid,ivb)  ! measure mxm times
c     call exitti('done mxm_test_all$',ivb)

      call comm_test(ivb)         ! measure message-passing and all-reduce times

      return
      end
c-----------------------------------------------------------------------
      subroutine comm_test(ivb) ! measure message-passing and all-reduce times
                                ! ivb = 0 --> minimal verbosity
                                ! ivb = 1 --> fully verbose
heisey's avatar
heisey committed
728
                                ! ivb = 2 --> smaller sample set(shorter)
fischer's avatar
fischer committed
729
730
731
732
733

      include 'SIZE'
      include 'PARALLEL'

      call gop_test(ivb)   ! added, Jan. 8, 2008
734
735
736
737

      log_np=log2(np)
      np2 = 2**log_np
      if (np2.eq.np) call gp2_test(ivb)   ! added, Jan. 8, 2008
fischer's avatar
fischer committed
738
739
740
741
742

      io = 6
      n512 = min(512,np-1)

      do nodeb=1,n512
743
744
745
746
747
748
749
750
751
752
753
         call pingpongo(alphas,betas,0,nodeb,.0005,io,ivb)
         if (nid.eq.0) write(6,2) nodeb,np,alphas,betas
    2    format(2i10,1p2e15.7,' alpha betao')
      enddo

      do kk=0,2
      do nodeb=1,n512
         call pingpong (alphas,betas,0,nodeb,.0005,io,ivb,kk)
         if (nid.eq.0) write(6,1) nodeb,np,alphas,betas,kk
    1    format(2i10,1p2e15.7,' alpha beta',i1)
      enddo
fischer's avatar
fischer committed
754
755
756
757
758
      enddo

      return
      end
c-----------------------------------------------------------------------
759
      subroutine pingpong(alphas,betas,nodea,nodeb,dt,io,ivb,kk)
fischer's avatar
fischer committed
760
761
762
763
764

      include 'SIZE'
      common /nekmpi/ mid,np,nekcomm,nekgroup,nekreal

      parameter  (lt=lx1*ly1*lz1*lelt)
Paul Fischer's avatar
Paul Fischer committed
765
766
      parameter (mwd = 3*lt/2)
      common /scrns/ x(mwd),y(mwd),x1(mwd),y1(mwd)
fischer's avatar
fischer committed
767
768
769
770
771
772
773
774
775
776
777
778

      include 'mpif.h'
      integer status(mpi_status_size)

      character*10 fname

      if (nid.eq.nodea) then
         write(fname,3) np,nodeb
    3    format('t',i4.4,'.',i4.4)
         if (io.ne.6) open (unit=io,file=fname)
      endif

779
      call nekgsync
fischer's avatar
fischer committed
780
781
782
783
784
785
786
787
      call get_msg_vol(msg_vol,dt,nodea,nodeb) ! Est. msg vol for dt s

      nwds = 0
      if (nid.eq.nodea.and.ivb.gt.0) write(io,*)

      betas = 0  ! Reported inverse bandwidth
      count = 0

heisey's avatar
heisey committed
788
789
790
791
792
793
794
795
      do itest = 1,500

         nloop = msg_vol/(nwds+2)
         nloop = min(nloop,1000)
         nloop = max(nloop,1)

         len   = 8*nwds
     
796
         if (kk.eq.0)
Paul Fischer's avatar
Paul Fischer committed
797
     $      call ping_loop (t1,t0,len,nloop,nodea,nodeb,nid,x,y,x1,y1)
798
         if (kk.eq.1)
Paul Fischer's avatar
Paul Fischer committed
799
     $      call ping_loop1(t1,t0,len,nloop,nodea,nodeb,nid,x,y)
800
         if (kk.eq.2)
Paul Fischer's avatar
Paul Fischer committed
801
     $      call ping_loop2(t1,t0,len,nloop,nodea,nodeb,nid,x,y)
heisey's avatar
heisey committed
802
803
804
805
806
807

         if (nid.eq.nodea) then
            tmsg = (t1-t0)/(2*nloop)   ! 2*nloop--> Double Buffer
            tmsg = tmsg / 2.           ! one-way cost = 1/2 round-trip
            tpwd = tmsg                ! time-per-word
            if (nwds.gt.0) tpwd = tmsg/nwds
808
809
            if (ivb.gt.0) write(io,1) nodeb,np,nloop,nwds,tmsg,tpwd,kk
    1       format(3i6,i12,1p2e16.8,' pgn',i1)
heisey's avatar
heisey committed
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826

            if (nwds.eq.1) then
               alphas = tmsg
            elseif (nwds.gt.10000) then   ! "average" beta
               betas = (betas*count + tpwd)/(count+1)
               count = count + 1
            endif
         endif

         if (ivb.eq.2) then
            nwds = (nwds+1)*1.25
         else
            nwds = (nwds+1)*1.016
         endif
         if (nwds.gt.mwd) then
c        if (nwds.gt.1024) then
            if (nid.eq.nodea.and.io.ne.6) close(unit=io)
827
            call nekgsync
heisey's avatar
heisey committed
828
829
830
831
832
833
            return
         endif

      enddo

      if (nid.eq.nodea.and.io.ne.6) close(unit=io)
834
      call nekgsync
heisey's avatar
heisey committed
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858

      return
      end
c-----------------------------------------------------------------------
      subroutine pingpongo(alphas,betas,nodea,nodeb,dt,io,ivb)

      include 'SIZE'
      common /nekmpi/ mid,np,nekcomm,nekgroup,nekreal

      parameter  (lt=lx1*ly1*lz1*lelt)
      parameter (mwd = 3*lt)
      common /scrns/ x(mwd),y(mwd)

      include 'mpif.h'
      integer status(mpi_status_size)

      character*10 fname

      if (nid.eq.nodea) then
         write(fname,3) np,nodeb
    3    format('t',i4.4,'.',i4.4)
         if (io.ne.6) open (unit=io,file=fname)
      endif

859
      call nekgsync
heisey's avatar
heisey committed
860
861
862
863
864
865
866
867
      call get_msg_vol(msg_vol,dt,nodea,nodeb) ! Est. msg vol for dt s

      nwds = 0
      if (nid.eq.nodea.and.ivb.gt.0) write(io,*)

      betas = 0  ! Reported inverse bandwidth
      count = 0

fischer's avatar
fischer committed
868
      do itest = 1,500
869
         call nekgsync
fischer's avatar
fischer committed
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
         nloop = msg_vol/(nwds+2)
         nloop = min(nloop,1000)
         nloop = max(nloop,1)

         len   = 8*nwds
         jnid = mpi_any_source

         if (nid.eq.nodea) then

            msg  = irecv(itest,y,1)
            call csend(itest,x,1,nodeb,0)   ! Initiate send, to synch.
            call msgwait(msg)

            t0 = mpi_wtime ()
            do i=1,nloop
               call mpi_irecv(y,len,mpi_byte,mpi_any_source,i
     $                        ,nekcomm,msg,ierr)
               call mpi_send (x,len,mpi_byte,nodeb,i,nekcomm,ierr)
               call mpi_wait (msg,status,ierr)
            enddo
            t1 = mpi_wtime ()
            tmsg = (t1-t0)/nloop
            tmsg = tmsg / 2.       ! Round-trip message time = twice one-way
            tpwd = tmsg
            if (nwds.gt.0) tpwd = tmsg/nwds
heisey's avatar
heisey committed
895
            if (ivb.gt.0) write(io,1) nodeb,np,nloop,nwds,tmsg,tpwd
896
    1       format(3i6,i12,1p2e16.8,' pgo')
fischer's avatar
fischer committed
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923

            if (nwds.eq.1) then
               alphas = tmsg
            elseif (nwds.gt.10000) then
               betas = (betas*count + tpwd)/(count+1)
               count = count + 1
            endif

         elseif (nid.eq.nodeb) then

            call crecv(itest,y,1)           ! Initiate send, to synch.
            call csend(itest,x,1,nodea,0)

            t0 = dnekclock()
            do i=1,nloop
               call mpi_recv (y,len,mpi_byte
     $               ,jnid,i,nekcomm,status,ierr)
               call mpi_send (x,len,mpi_byte,nodea,i,nekcomm,ierr)
            enddo
            t1 = dnekclock()
            tmsg = (t1-t0)/nloop

         endif

         nwds = (nwds+1)*1.016
         if (nwds.gt.mwd) then
            if (nid.eq.nodea.and.io.ne.6) close(unit=io)
924
            call nekgsync
fischer's avatar
fischer committed
925
926
927
928
929
930
            return
         endif

      enddo

      if (nid.eq.nodea.and.io.ne.6) close(unit=io)
931
      call nekgsync
932

fischer's avatar
fischer committed
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
      return
      end
c-----------------------------------------------------------------------
      subroutine get_msg_vol(msg_vol,dt,nodea,nodeb)
      include 'SIZE'
      common /nekmpi/ mid,np,nekcomm,nekgroup,nekreal
      parameter (lt=lx1*ly1*lz1*lelt)
      common /scrns/ x(3*lt),y(3*lt)
!
!     Est. msg vol for dt s
!
      msg_vol = 1000

      nwds  = min(1000,lt)
      nloop = 50
 
      tmsg = 0.
      call gop(tmsg,t1,'+  ',1)

      len = 8*nwds
      if (nid.eq.nodea) then

         msg  = irecv(1,y,1)
         call csend(1,x,1,nodeb,0)   ! Initiate send, to synch.
         call msgwait(msg)

         t0 = dnekclock()
         do i=1,nloop
            msg  = irecv(i,y,len)
            call csend(i,x,len,nodeb,0)
            call msgwait(msg)
         enddo
         t1   = dnekclock()
         tmsg = (t1-t0)/nloop
         tpwd = tmsg/nwds

      elseif (nid.eq.nodeb) then

         call crecv(1,y,1)           ! Initiate send, to synch.
         call csend(1,x,1,nodea,0)

         t0 = dnekclock()
         do i=1,nloop
            call crecv(i,y,len)
            call csend(i,x,len,nodea,0)
         enddo
         t1   = dnekclock()
         tmsg = (t1-t0)/nloop
         tmsg = 0.

      endif

      call gop(tmsg,t1,'+  ',1)
      msg_vol = nwds*(dt/tmsg)
c     if (nid.eq.nodea) write(6,*) nid,msg_vol,nwds,dt,tmsg,' msgvol'

      return
      end
c-----------------------------------------------------------------------
      subroutine gop_test(ivb)
      include 'SIZE'
      common /nekmpi/ mid,np,nekcomm,nekgroup,nekreal
      include 'mpif.h'
      integer status(mpi_status_size)

      parameter  (lt=lx1*ly1*lz1*lelt)
      parameter (mwd = 3*lt)
      common /scrns/ x(mwd),y(mwd)
For faster browsing, not all history is shown. View entire blame