source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/mct/mpeu/m_zeit.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 4 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818

File size: 28.5 KB
Line 
1!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
3!-----------------------------------------------------------------------
4! CVS m_zeit.F90,v 1.10 2004-04-21 22:54:49 jacob Exp
5! CVS MCT_2_8_0 
6!-----------------------------------------------------------------------
7!BOP
8!
9! !MODULE: m_zeit - a multi-timer of process times and wall-clock times
10!
11! !DESCRIPTION:
12!
13! !INTERFACE:
14
15    module m_zeit
16      implicit none
17      private   ! except
18
19      public :: zeit_ci         ! push a new name to the timer
20      public :: zeit_co         ! pop the current name on the timer
21      public :: zeit_flush      ! print per PE timing
22      public :: zeit_allflush   ! print all PE timing
23      public :: zeit_reset      ! reset the timers to its initial state
24
25        ! Flags of all printable timers
26
27      public ::  MWTIME ! MPI_Wtime() wall-clock time
28      public ::  XWTIME ! times() wall-clock time
29      public ::  PUTIME ! times() process user time
30      public ::  PSTIME ! times() process system time
31      public ::  CUTIME ! times() user time of all child-processes
32      public ::  CSTIME ! times() system time of all child-processes
33      public :: ALLTIME ! all of above
34      public ::  UWRATE ! (putime+cutime)/xwtime
35
36      interface zeit_ci;    module procedure ci_;    end interface
37      interface zeit_co;    module procedure co_;    end interface
38      interface zeit_flush; module procedure flush_; end interface
39      interface zeit_allflush; module procedure allflush_; end interface
40      interface zeit_reset; module procedure reset_; end interface
41
42! !REVISION HISTORY:
43!
44!       22Jan01 - Jay Larson <larson@mcs.anl.gov> - Minor correction in
45!                 write statements in the routines sp_balances_() and
46!                 mp_balances_():  replaced x (single-space) descriptor
47!                 with 1x.  This is apparently strict adherance to the
48!                 f90 standard (though the first of many, many compilers
49!                 where it has arisen).  This was for the SunOS platform.
50!       05Mar98 - Jing Guo <guo@thunder>        -
51!               . rewritten for possible MPI applications, with
52!                 additional functionalities and new performance
53!                 analysis information.
54!               . Interface names have been redefined to ensure all
55!                 use cases to be verified.
56!               . removed the type(pzeit) data structure, therefore,
57!                 limited to single _instance_ applications.
58!               . added additional data components for more detailed
59!                 timing analysis.
60!               . used times() for the XPG4 standard conforming
61!                 timing functions.
62!               . used MPI_Wtime() for the MPI standard conforming
63!                 high-resolution timing functions.
64!
65!       20Feb97 - Jing Guo <guo@eramus>         -
66!               . rewritten in Fortran 90 as the first modular
67!                 version, with a type(pzeit) data structure.
68!
69!       10may96 - Jing G. -     Add _TZEITS macro for the testing code
70!       09may96 - Jing G. -     Changed output format also modifed
71!                               comments
72!       11Oct95 - Jing G. -     Removed earlier way of letting clock
73!                               timing (clkknt and clktot) to be no less
74!                               then the CPU timing, following a
75!                               suggestion by James Abeles from Cray.
76!                               This way, users may use the routings to
77!                               timing multitasking speedup as well.
78!       12May95 - Jing G. -     Merged zeitCRAY.f and zeitIRIS.f.
79!       Before  - ?       -     See zeitCRAY.f and zeitIRIS.f for more
80!                               information.  Authors of those files are
81!                               not known to me.
82!
83! !DESIGN ISSUES:
84!
85!       05Mar98 - Jing Guo <guo@thunder>        -
86!               . Removing the data structure may be consider as a
87!                 limitation to future changes to multiple _instance_
88!                 applications.  However, it is unlikely there will be
89!                 any neccessary multi-_intance_ application soon, if
90!                 ever for this module.
91!               . Without an additional layer with the derived
92!                 datatype, one may worry less the tricky performance
93!                 issues associated with ci_/co_.
94!               . Performance issue with the flush_() calls are not
95!                 considered.
96!
97!       20Feb97 - Jing Guo <guo@eramus>         -
98!               . Currently a single threaded module.  May be easily
99!                 extended to multi-threaded module by adding the name
100!                 of an instance of the class to the argument list.  It
101!                 requires some but very limited interface extensions.
102!                 Right now, the backward compatibility is the main
103!                 issue.
104!
105! 10may96 - Jing Guo <guo@eramus>               -
106!
107!     + This zeit subroutine collection replaces original zeit files
108!       used in PSAS on both systems, UNICOS and IRIX, with following
109!       changes:
110!
111!             + Removed the some bugs in zeitCRAY.f that overite the
112!               first user defined name entry in a special situation
113!               (but not being able to correct in zeitCRAY.f).
114!
115!             + Unified both zeitCRAY.f and zeitIRIS.f in to one file
116!               (this file), that handles system dependency in only
117!               one subroutine syszeit_() with a couple of lines of
118!               differences.
119!
120!             + Added system CPU time counts for system supporting
121!               the function.
122!
123!             + Added some error checking and reporting functions.
124!
125!             + According to zeitCRAY.f, "zeit" is "time" in Germen.
126!               The name is used through the code as another name for
127!               "time".
128!
129!             + This version does not work for parallelized processes.
130!
131!     + Elapsed time records since the first call are used.  Although
132!       it may loose accuracy when the values of the time records
133!       become large, it will keep the total time values conserved.
134!
135!     + The accuracy of the elapsed times at a IEEE real*4 accuracy
136!       (ffrac = 2^23 ~= 1.19e-7) should be no worse than +- 1 second
137!       in 97 days, if only the numerical accuracy is considered.
138!
139!     + The precision of "wall clock" time returned by syszeit_() is
140!       only required to be reliable upto seconds.
141!
142!     + The wall clock time for individual name tag (clkknt) is
143!       accumulated by adding the differences between two integer
144!       values, iclk and iclksv.  Care must be taken to compute the
145!       differences of iclk and iclksv first.  That is, doing
146!
147!               clkknt()=clkknt() + (iclk-iclksv)
148!
149!       not
150!
151!               clkknt()=clkknt() + iclk-iclksv
152!
153!       The latter statement may ignore the difference between the two
154!       integer values (iclk and iclksv).
155!
156!EOP
157!_______________________________________________________________________
158  character(len=*),parameter :: myname='MCT(MPEU)::m_zeit'
159
160  integer,parameter ::  MWTIME =  1
161  integer,parameter ::  XWTIME =  2
162  integer,parameter ::  PUTIME =  4
163  integer,parameter ::  PSTIME =  8
164  integer,parameter ::  CUTIME = 16
165  integer,parameter ::  CSTIME = 32
166  integer,parameter :: ALLTIME = MWTIME + XWTIME + PUTIME +     &
167                                 PSTIME + CUTIME + CSTIME
168  integer,parameter ::  UWRATE = 64
169
170  integer,parameter :: MASKS(0:5) =     &
171        (/ MWTIME,XWTIME,PUTIME,PSTIME,CUTIME,CSTIME /)
172
173  character(len=*),parameter :: ZEIT='.zeit.'
174  character(len=8),parameter :: HEADER(0:5) =   &
175    (/  '[MWTIME]','[XWTIME]','[PUTIME]',       &
176        '[PSTIME]','[CUTIME]','[CSTIME]'        /)
177  character(len=8),parameter :: UWRHDR = '[UWRATE]'
178
179  integer,parameter :: MXN= 250 ! the size of a name list
180! integer,parameter :: NSZ= 32  ! the size of a name
181! LPC jun/6/2000
182  integer,parameter :: NSZ= 36  ! the size of a name
183  integer,parameter :: MXS= 64  ! the depth of the timer stack
184
185  integer,save :: nreset=0
186  logical,save :: started=.false.
187  logical,save :: balanced=.false.
188
189  character(len=NSZ),   &
190          save :: ciname=' '
191  character(len=NSZ),   &
192          save :: coname=' '
193
194  integer,save :: mxdep=0       ! the maximum ndep value recorded
195  integer,save :: ndep=-1       ! depth, number of net ci_()
196  integer,save :: lnk_n(0:MXS)  ! name index of the depth
197
198  integer,save                  :: nname=-1     ! number of accounts
199  character(len=NSZ),   &
200          save,dimension(0:MXN) :: name_l       ! the accounts
201  integer,save,dimension(0:MXN) :: knt_l        ! counts of ci_() calls
202  integer,save,dimension(0:MXN) :: level_l      ! remaining ci_() counts
203
204  real*8,save,dimension(0:5)       :: zts_sv    ! the last timings
205
206  real*8,save,dimension(0:5,0:MXN) ::  zts_l    ! credited to a name
207  real*8,save,dimension(0:5,0:MXN) :: szts_l    ! all under the name
208  real*8,save,dimension(0:5,0:MXN) :: szts_sv   ! the last ci_ timings
209
210!=======================================================================
211contains
212
213!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
214!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
215!-----------------------------------------------------------------------
216!BOP
217!
218! !IROUTINE: ci_ - push an entry into the timer
219!
220! !DESCRIPTION:
221!
222! !INTERFACE:
223
224    subroutine ci_(name)
225      use m_stdio, only : stderr
226      use m_die, only : die
227      use m_mpif90,only : MP_wtime
228      implicit none
229      character(len=*), intent(in) :: name
230
231! !REVISION HISTORY:
232!       05Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
233!EOP
234!_______________________________________________________________________
235  character(len=*),parameter :: myname_=myname//'::ci_'
236
237        ! Local variables
238
239  real*8,dimension(0:5) :: zts
240  integer :: lname,iname
241  integer :: i
242
243        ! Encountered a limitation.  Programming is required
244
245  if(ndep >= MXS) then
246    write(stderr,'(2a,i4)') myname_,    &
247        ': stack overflow with "'//trim(name)//'", ndep =',ndep
248    call die(myname_)
249  endif
250
251        !--------------------------------------------------------
252        ! Initialize the stack if it is called the first time.
253
254  if(.not.started) call reset_()
255
256        ! Get the current _zeits_
257
258  call get_zeits(zts(1))
259  zts(0)=MP_wtime()
260
261        !--------------------------------------------------------
262        ! Charge the ticks since the last co_() to the current level
263
264  lname=lnk_n(ndep)
265
266  do i=0,5
267    zts_l(i,lname)=zts_l(i,lname) + zts(i)-zts_sv(i)
268  end do
269
270  do i=0,5
271    zts_sv(i)=zts(i)            ! update the record
272  end do
273
274        !--------------------------------------------------------
275        ! Is the name already in the list?  Case sensitive and
276        ! space maybe sensitive if they are inbeded between non-
277        ! space characters.
278        !
279        ! If the name is already in the list, the index of the
280        ! table entry is given.
281        !
282        ! If the name is not in the list, a new entry will be added
283        ! to the list, if 1) there is room, and 2)
284
285  iname=lookup_(name)
286
287        !--------------------------------------------------------
288        ! push up the stack level
289
290  ndep=ndep+1
291  if(mxdep <= ndep) mxdep=ndep
292
293  lnk_n(ndep)=iname
294  knt_l(iname)=knt_l(iname)+1
295
296        ! Recording the check-in time, if there is no remaining
297        ! levels for the same name.  This is used to handle
298        ! recursive ci_() calls for the same name.
299
300  if(level_l(iname) == 0) then
301    do i=0,5
302      szts_sv(i,iname)=zts_sv(i)
303    end do
304  endif
305
306        ! open a level
307
308  level_l(iname)=level_l(iname)+1
309
310end subroutine ci_
311
312!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
313!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
314!-----------------------------------------------------------------------
315!BOP
316!
317! !IROUTINE: co_ - pop the current level
318!
319! !DESCRIPTION:
320!
321! !INTERFACE:
322
323    subroutine co_(name,tms)
324      use m_stdio, only : stderr
325      use m_die, only : die
326      use m_mpif90,only : MP_wtime
327      implicit none
328      character(len=*), intent(in) :: name      ! account name
329      real*8,optional,dimension(0:5,0:1),intent(out) :: tms ! timings
330
331!     The returned variable tms(0:5,0:1) contains two sets of timing
332!   information.  tms(0:5,0) is the NET timing data charged under the
333!   account name only, and tms(0:5,1) is the SCOPE timing data since
334!   the last ci() with the same account name and at the out most level.
335!
336! !REVISION HISTORY:
337!       11Oct99 - J.W. Larson - <jlarson@dao> explicit definition of
338!                 tms as real*8
339!       05Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
340!EOP
341!_______________________________________________________________________
342  character(len=*),parameter :: myname_=myname//'::co_'
343
344  real*8 :: tms0,tms1
345  real*8,dimension(0:5) :: zts
346  integer :: lname
347  integer :: i
348
349        ! Encountered a limitation.  Programming is required
350
351  if(ndep <= 0) then
352    write(stderr,'(2a,i4)') myname_,    &
353        ': stack underflow with "'//trim(name)//'", ndep =',ndep
354    call die(myname_)
355  endif
356
357        !--------------------------------------------------------
358        ! Initialize the stack if it is called the first time.
359
360  if(.not.started) call reset_()
361
362        ! Get the current _zeits_
363
364  call get_zeits(zts(1))
365  zts(0)=MP_wtime()
366
367        ! need special handling if ndep is too large or too small.
368
369  lname=lnk_n(ndep)
370  level_l(lname)=level_l(lname)-1       ! close a level
371
372  do i=0,5
373      tms0=zts(i)- zts_sv(i)            ! NET by the _account_
374      tms1=zts(i)-szts_sv(i,lname)      ! within its SCOPE
375
376      zts_l(i,lname)= zts_l(i,lname) + tms0
377
378      if(level_l(lname) == 0)           &
379        szts_l(i,lname)=szts_l(i,lname) + tms1
380
381      zts_sv(i)=zts(i)
382
383      if(present(tms)) then
384
385        ! Return the timings of the current call segment
386        !
387        !   tms(:,0) is for the NET timing data, that have been charged
388        !       to this account.
389        !
390        !   tms(:,1) is for the SCOPE timing data since the ci() of the
391        !       same account name at the out most level.
392       
393
394        tms(i,0)=tms0
395        tms(i,1)=tms1   ! only the sub-segments
396      endif
397  end do
398
399        ! Record the unbalanced ci/co.  Name .void. is supplied for
400        ! backward compartible calls of pzeitend()
401
402  if(name /= '.void.'.and.balanced) then
403    balanced = lname == MXN .or. name == name_l(lname)
404    if(.not.balanced) then
405      ciname=name_l(lname)
406      coname=name
407    endif
408  endif
409
410        ! pop (need special handling of ndep too large or too small.
411
412  ndep=ndep-1
413
414end subroutine co_
415
416!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
417!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
418!-----------------------------------------------------------------------
419!BOP
420!
421! !IROUTINE: reset_ - reset module m_zeit to an initial state
422!
423! !DESCRIPTION:
424!
425! !INTERFACE:
426
427    subroutine reset_()
428      use m_mpif90,only : MP_wtime
429      implicit none
430
431! !REVISION HISTORY:
432!       04Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
433!EOP
434!_______________________________________________________________________
435  character(len=*),parameter :: myname_=myname//'::reset_'
436  integer :: i
437
438        ! keep tracking the number of reset_() calls
439
440  nreset=nreset+1
441  started=.true.
442  balanced=.true.
443
444        ! Start timing
445
446  call get_zeits(zts_sv(1))
447  zts_sv(0)=MP_wtime()
448
449        ! Sign in the module name for the overheads (.eqv. ci_(ZEIT))
450
451  nname=0
452  name_l(nname)=ZEIT
453  knt_l(nname)=1
454
455  ndep =0
456  lnk_n(ndep)=nname
457
458        ! Initialize the timers.
459
460  do i=0,5
461     zts_l(i,nname)=0.
462    szts_l(i,nname)=0.
463    szts_sv(i,nname)=zts_sv(i)
464  end do
465  level_l(nname)=1
466
467end subroutine reset_
468!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
469!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
470!-----------------------------------------------------------------------
471!BOP
472!
473! !IROUTINE: lookup_ search/insert a name
474!
475! !DESCRIPTION:
476!
477! !INTERFACE:
478
479    function lookup_(name)
480      implicit none
481      character(len=*),intent(in) :: name
482      integer :: lookup_
483
484! !REVISION HISTORY:
485!       04Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
486!EOP
487!_______________________________________________________________________
488  character(len=*),parameter :: myname_=myname//'::lookup_'
489
490  logical :: found
491  integer :: ith
492  integer :: i
493
494  ith=-1
495  found=.false.
496  do while(.not.found.and. ith < min(nname,MXN))
497    ith=ith+1
498    found = name == name_l(ith)
499  end do
500
501  if(.not.found) then
502
503    found = nname >= MXN        ! Can not handle too many accounts?
504    ith=MXN                     ! Then use the account for ".foo."
505
506    if(.not.found) then         ! Otherwise, add a new account.
507      nname=nname+1
508      ith=nname
509
510      name_l(ith)=name
511      if(ith==MXN) name_l(ith)='.foo.'
512
513        ! Initialize a new account
514
515      do i=0,5
516         zts_l(i,ith)=0.
517        szts_l(i,ith)=0.
518      end do
519      level_l(ith)=0
520
521    endif
522  endif
523
524  lookup_=ith
525
526end function lookup_
527
528!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
529!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
530!-----------------------------------------------------------------------
531!BOP
532!
533! !IROUTINE: flush_ - print the timing data
534!
535! !DESCRIPTION:
536!
537! !INTERFACE:
538
539    subroutine flush_(lu,umask)
540      use m_stdio, only : stderr
541      use m_ioutil, only : luflush
542      use m_die, only : die
543      use m_mpif90,only : MP_wtime
544      implicit none
545      integer,intent(in) :: lu  ! logical unit for the output
546      integer,optional,intent(in) :: umask
547
548! !REVISION HISTORY:
549!       05Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
550!EOP
551!_______________________________________________________________________
552  character(len=*),parameter :: myname_=myname//'::flush_'
553  integer :: imask
554
555  real*8,dimension(0:5) :: zts
556  integer :: i,ier
557
558        ! specify which timer to print
559
560  imask=MWTIME
561  if(present(umask)) imask=umask
562
563        ! write a <newline>
564
565  write(lu,*,iostat=ier)
566  if(ier /= 0) then
567    write(stderr,'(2a,i3)') myname_,': can not write(), unit =',lu
568    call die(myname_)
569  endif
570
571  if(.not.balanced) write(lu,'(5a)') myname_,   &
572        ': ci/co unbalanced, ',trim(ciname),'/',trim(coname)
573
574  call luflush(lu)
575
576        ! latest times, but not closing on any entry
577
578  call get_zeits(zts(1))
579  zts(0)=MP_wtime()
580
581        ! Print selected tables
582
583  do i=0,5
584    if(iand(MASKS(i),imask) /= 0)       &
585      call sp_balances_(lu,i,zts(i))
586  end do
587#ifdef TODO
588  if(iand(UWRATE,imask) /= 0) call sp_rate_(lu,zts)
589#endif
590
591  call luflush(lu)
592
593end subroutine flush_
594
595!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
596!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
597!-----------------------------------------------------------------------
598!BOP
599!
600! !IROUTINE: sp_balances_ - print a table of a given timer
601!
602! !DESCRIPTION:
603!
604! !INTERFACE:
605
606    subroutine sp_balances_(lu,itm,zti)
607      implicit none
608      integer,intent(in) :: lu
609      integer,intent(in) :: itm
610      real*8,intent(in) :: zti
611
612! !REVISION HISTORY:
613!       06Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
614!       22Jan01 - Jay Larson <larson@mcs.anl.gov> - Minor correction in
615!                 A write statement:  replaced x (single-space) descriptor
616!                 with 1x.  This is apparently strict adherance to the
617!                 f90 standard (though the first of many, many compilers
618!                 where it has arisen).  This was for the SunOS platform.
619!       24Feb01 - Jay Larson <larson@mcs.anl.gov> - Extra decimal place in
620!                 timing numbers (some reformatting will be necessary).
621!EOP
622!_______________________________________________________________________
623  character(len=*),parameter :: myname_=myname//'::sp_balances_'
624
625  real*8,parameter :: res=.001  ! (sec)
626
627  integer,parameter :: lnmax=12
628  character(len=max(NSZ,lnmax)) :: name
629
630  character(len=1) :: tag
631  character(len=4) :: num
632
633  integer :: zt_min,zt_sec
634  integer :: sz_min,sz_sec
635  integer :: l,i,ln
636
637  real*8 :: sz0
638  real*8 :: zt,zt_percent,zt_percall
639  real*8 :: sz,sz_percent
640
641        ! The total time is given in the ZEIT bin
642
643  sz0=szts_l(itm,0)
644  if(level_l(0) /= 0) sz0=sz0 + zti - szts_sv(itm,0)
645  sz0=max(res,sz0)
646
647  write(lu,'(a,t14,a,t21,a,t31,a,t52,a)')       &
648    HEADER(itm), 'counts','period',     &
649      'NET    m:s      %',              &
650    'SCOPE    m:s      %'
651
652!23.|....1....|....2....|....3....|....4....|....5....|....6....|....7..
653![MWTIME]    counts period    NET    m:s      %    SCOPE    m:s      %
654!-----------------------------------------------------------------------
655!zeit.      (  3s  3d  3)   333.3   33:33   3.3+   333.3   33:33   3.3+
656!sub           333   33.3   333.3   33:33   3.3%   333.3   33:33   3.3%
657
658  write(lu,'(80a)') ('-',i=1,72)
659  do l=0,min(MXN,nname)
660
661    zt= zts_l(itm,l)
662    sz=szts_l(itm,l)
663    tag='%'
664    if(level_l(l) /= 0) then
665      zt=zt + zti -  zts_sv(itm)
666      sz=sz + zti - szts_sv(itm,l)
667      tag='+'
668    endif
669
670    zt_percall=zt/max(1,knt_l(l))
671
672    zt_percent=100.*zt/sz0
673    sz_percent=100.*sz/sz0
674
675    zt_sec=nint(zt)
676    zt_min=    zt_sec/60
677    zt_sec=mod(zt_sec,60)
678
679    sz_sec=nint(sz)
680    sz_min=    sz_sec/60
681    sz_sec=mod(sz_sec,60)
682
683    name=name_l(l)
684    ln=max(len_trim(name),lnmax)
685
686    select case(l)
687      case(0)
688        write(num,'(i4)') mxdep
689!       write(lu,'(2(a,i3),2a,t26,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))')&
690        write(lu,'(2(a,i3),2a,t26,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))')&
691          name(1:ln),nreset,'s',ndep,'/',num,           &
692          zt,zt_min,':',zt_sec,zt_percent,tag,          &
693          sz,sz_min,':',sz_sec,sz_percent,tag
694
695!       write(lu,'(2a,3(i3,a),t26,2(x,f7.1,x,i4.2,a,i2.2,x,f5.1,a))')&
696!         name(1:ln),'(',nreset,'s',ndep,'d',mxdep,')', &
697
698      case default
699        if(len_trim(name) < lnmax)then
700!          write(lu,'(a,1x,i5,1x,f6.1,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))') &
701          write(lu,'(a,1x,i5,1x,f7.2,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))') &
702          name(1:ln),knt_l(l),zt_percall,       &
703          zt,zt_min,':',zt_sec,zt_percent,tag,  &
704          sz,sz_min,':',sz_sec,sz_percent,tag
705        else
706          write(lu,'(a)')name(1:ln)
707!          write(lu,'(13x,i5,1x,f6.1,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))') &
708          write(lu,'(13x,i5,1x,f7.2,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))') &
709          knt_l(l),zt_percall,       &
710          zt,zt_min,':',zt_sec,zt_percent,tag,  &
711          sz,sz_min,':',sz_sec,sz_percent,tag
712        endif
713    end select
714
715  end do
716  write(lu,'(80a)') ('-',i=1,72)
717
718end subroutine sp_balances_
719
720!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
721!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
722!-----------------------------------------------------------------------
723!BOP
724!
725! !IROUTINE: allflush_ - print a summary of all PEs.
726!
727! !DESCRIPTION:
728!
729! !INTERFACE:
730
731    subroutine allflush_(comm,root,lu,umask)
732      use m_stdio, only : stderr
733      use m_ioutil, only : luflush
734      use m_die, only : die
735      use m_mpif90,only : MP_wtime,MP_type
736      use m_mpif90,only : MP_comm_size,MP_comm_rank
737      use m_SortingTools,only : IndexSet,IndexSort
738      implicit none
739      integer,intent(in) :: comm
740      integer,intent(in) :: root
741      integer,intent(in) :: lu
742      integer,optional,intent(in) :: umask
743
744! !REVISION HISTORY:
745!       09Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
746!EOP
747!_______________________________________________________________________
748  character(len=*),parameter :: myname_=myname//'::allflush_'
749  integer myID,nPE
750  integer :: imask
751  real*8,dimension(0:5)           :: zts
752  real*8,dimension(0:5,0:1,0:MXN) :: ztbf
753  real*8,dimension(:,:,:,:),allocatable :: ztmp
754  integer,dimension(0:MXN) :: indx_
755  integer :: mnm
756
757  integer :: i,l
758  integer :: nbf,ier
759  integer :: mp_Type_ztbf
760
761  mp_Type_ztbf=MP_type(ztbf(0,0,0))
762
763  imask=MWTIME
764  if(present(umask)) imask=umask
765
766  if(imask==0) return
767
768  call get_zeits(zts(1))
769  zts(0)=MP_wtime()
770
771        ! Update the accounts and prepare for the messages
772
773  mnm=min(MXN,nname)
774  do l=0,mnm
775    do i=0,5
776      ztbf(i,0,l)= zts_l(i,l)
777      ztbf(i,1,l)=szts_l(i,l)
778    end do
779
780    if(level_l(l) /= 0) then
781                ! Update the current accounts.
782      do i=0,5
783        ztbf(i,0,l)=ztbf(i,0,l) + zts(i) - zts_sv(i  )
784        ztbf(i,1,l)=ztbf(i,1,l) + zts(i) -szts_sv(i,l)
785      end do
786    endif
787  end do
788  nbf=size(ztbf(0:5,0:1,0:mnm))
789
790  call MP_comm_rank(comm,myID,ier)
791  if(ier /= 0) then
792    write(stderr,'(2a,i3)') myname_,    &
793        ': MP_comm_rank() error, ier =',ier
794    call die(myname_)
795  endif
796
797        ! An urgent hack for now.  Need to be fixed later.  J.G.
798  indx_(0)=0
799  call IndexSet( nname,indx_(1:mnm))
800  call IndexSort(nname,indx_(1:mnm),name_l(1:mnm))
801
802  if(myID /= root) then
803
804    call MPI_gather((ztbf(0:5,0:1,indx_(0:mnm))),nbf,mp_Type_ztbf, &
805                    ztbf,nbf,mp_Type_ztbf,root,comm,ier )
806    if(ier /= 0) then
807      write(stderr,'(2a,i3)') myname_,  &
808        ': MPI_gather(!root) error, ier =',ier
809      call die(myname_)
810    endif
811
812  else
813
814    call MP_comm_size(comm,nPE,ier)
815    if(ier /= 0) then
816      write(stderr,'(2a,i3)') myname_,  &
817        ': MP_comm_size() error, ier =',ier
818      call die(myname_)
819    endif
820
821    allocate(ztmp(0:5,0:1,0:mnm,0:nPE-1),stat=ier)
822    if(ier /= 0) then
823      write(stderr,'(2a,i4)') myname_,  &
824        ': allocate(zts) error, stat =',ier
825      call die(myname_)
826    endif
827
828    call MPI_gather((ztbf(0:5,0:1,indx_(0:mnm))),nbf,mp_Type_ztbf, &
829                    ztmp,nbf,mp_Type_ztbf,root,comm,ier )
830    if(ier /= 0) then
831      write(stderr,'(2a,i3)') myname_,  &
832        ': MPI_gather(root) error, ier =',ier
833      call die(myname_)
834    endif
835
836        ! write a <newline>
837
838    write(lu,*,iostat=ier)
839    if(ier /= 0) then
840      write(stderr,'(2a,i3)') myname_,': can not write(), unit =',lu
841      call die(myname_)
842    endif
843
844    call luflush(lu)
845
846    do i=0,5
847      if(iand(MASKS(i),imask) /= 0)     &
848        call mp_balances_(lu,i,nPE,ztmp,indx_)
849    end do
850#ifdef  TODO
851    if(iand(UWRATE,imask) /= 0) call mp_rate_(lu,nPE,ztmp)
852#endif
853
854    deallocate(ztmp,stat=ier)
855    if(ier /= 0) then
856      write(stderr,'(2a,i4)') myname_,  &
857          ': deallocate(zts) error, stat =',ier
858      call die(myname_)
859    endif
860  endif
861
862   call luflush(lu)
863end subroutine allflush_
864
865!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
866!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
867!-----------------------------------------------------------------------
868!BOP
869!
870! !IROUTINE: mp_balances_ - summarize the timing data of all PEs
871!
872! !DESCRIPTION:
873!
874! \newcommand{\tb}{\overline{t}}
875!
876!       \verb"mp_balances_"() summarizes the timing data of all PEs
877!   with quantified load balancing measures:
878!   \begin{eqnarray*}
879!       x &=& \frac{\max(t) - \tb}{N\tb}        \times 100\%    \\
880!       i &=& \frac{\max(t) - \tb}{\max(t)}     \times 100\%    \\
881!       r &=& \frac{1}{N\tb} \sum^{t>\tb}{(t-\tb)}
882!               \times 100\%
883!   \end{eqnarray*}
884!   where
885!   \begin{center}
886!     \begin{tabular}{rl}
887!       $t$: & time by any process element                      \\
888!     $\tb$: & mean time by all process elements                \\
889!       $x$: & the ma{\bf x}imum percentage load deviation      \\
890!       $i$: & percentage {\bf i}dle process-time or
891!                                       load {\bf i}mbalance    \\
892!       $r$: & percentage {\bf r}elocatable loads               \\
893!       $N$: & {\bf n}umber of process elements
894!     \end{tabular}
895!   \end{center}
896!
897! !INTERFACE:
898
899    subroutine mp_balances_(lu,itm,nPE,ztmp,indx)
900      implicit none
901      integer,intent(in) :: lu
902      integer,intent(in) :: itm
903      integer,intent(in) :: nPE
904      real*8,dimension(0:,0:,0:,0:),intent(in) :: ztmp
905      integer,dimension(0:),intent(in) :: indx
906
907! !REVISION HISTORY:
908!       10Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
909!       22Jan01 - Jay Larson <larson@mcs.anl.gov> - Minor correction in
910!                 A write statement:  replaced x (single-space) descriptor
911!                 with 1x.  This is apparently strict adherance to the
912!                 f90 standard (though the first of many, many compilers
913!                 where it has arisen).  This was for the SunOS platform.
914!       25Feb01 - R. Jacob <jacob@mcs.anl.gov> change number of
915!                 decimal places from 1 to 4.
916!EOP
917!_______________________________________________________________________
918  character(len=*),parameter :: myname_=myname//'::mp_balances_'
919
920  real*8,parameter :: res=.001  ! (sec)
921
922  integer,parameter :: lnmax=12
923  character(len=max(NSZ,lnmax)) :: name
924  character(len=4) :: num
925
926  integer :: i,k,l,ln,lx
927
928        ! NET times
929  integer :: ix_o
930  real*8  :: zts_o,zta_o,ztm_o,ztr_o
931  integer :: x_o,i_o,r_o
932
933        ! SCOPE times
934  integer :: ix_s
935  real*8  :: zts_s,zta_s,ztm_s,ztr_s
936  integer :: x_s,i_s,r_s
937
938  write(num,'(i4)') nPE
939  write(lu,'(3a,t18,a,t58,a)')  &
940    HEADER(itm),'x',adjustl(num),       &
941    'NET avg        max    imx x% r% i%',       &
942    'SCP avg        max    imx x% r% i%'
943
944!23.|....1....|....2....|....3....|....4....|....5....|....6....|....7..
945
946!MWTIME]x3    NET avg     max imx x% r% i%  SCP avg     max imx x% r% i%
947!-----------------------------------------------------------------------
948!zeit.       333333.3 33333.3 333 33 33 33 333333.3 33333.3 333 33 33 33
949
950write(lu,'(91a)') ('-',i=1,91)
951do l=0,min(MXN,nname)
952
953        ! sum() of all processes
954
955  zts_o=0.
956  zts_s=0.
957
958        ! indices of max() of all processes
959
960  ix_o=0
961  ix_s=0
962  do k=0,nPE-1
963
964    zts_o=zts_o+ztmp(itm,0,l,k)         ! compute sum()
965    zts_s=zts_s+ztmp(itm,1,l,k)         ! compute sum()
966
967    if(ztmp(itm,0,l,ix_o) < ztmp(itm,0,l,k)) ix_o=k
968    if(ztmp(itm,1,l,ix_s) < ztmp(itm,1,l,k)) ix_s=k
969     
970  end do
971
972  zta_o=zts_o/max(1,nPE)                ! compute mean()
973  zta_s=zts_s/max(1,nPE)                ! compute mean()
974
975  ztr_o=0.
976  ztr_s=0.
977  do k=0,nPE-1
978    if(ztmp(itm,0,l,k) > zta_o) ztr_o=ztr_o+ztmp(itm,0,l,k)-zta_o
979    if(ztmp(itm,1,l,k) > zta_s) ztr_s=ztr_s+ztmp(itm,1,l,k)-zta_s
980  end do
981
982  ztm_o=ztmp(itm,0,l,ix_o)
983  ztm_s=ztmp(itm,1,l,ix_s)
984
985  lx=indx(l)
986  name=name_l(lx)
987  ln=max(len_trim(name),lnmax)
988
989  x_o=nint(100.*(ztm_o-zta_o)/max(zts_o,res))
990  r_o=nint(100.* ztr_o       /max(zts_o,res))
991  i_o=nint(100.*(ztm_o-zta_o)/max(ztm_o,res))
992
993  x_s=nint(100.*(ztm_s-zta_s)/max(zts_s,res))
994  r_s=nint(100.* ztr_s       /max(zts_s,res))
995  i_s=nint(100.*(ztm_s-zta_s)/max(ztm_s,res))
996
997  write(lu,'(a,2(3x,f10.6,3x,f10.6,1x,z3.3,3i3,1x))')           &
998        name(1:ln),                             &
999        zta_o,ztm_o,ix_o,x_o,r_o,i_o,           &
1000        zta_s,ztm_s,ix_s,x_s,r_s,i_s
1001
1002end do
1003write(lu,'(91a)') ('-',i=1,91)
1004end subroutine mp_balances_
1005
1006!=======================================================================
1007end module m_zeit
1008!.
Note: See TracBrowser for help on using the repository browser.