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 | !======================================================================= |
---|
211 | contains |
---|
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 | |
---|
310 | end 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 | |
---|
414 | end 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 | |
---|
467 | end 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 | |
---|
526 | end 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 | |
---|
593 | end 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 | |
---|
718 | end 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) |
---|
863 | end 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 | |
---|
950 | write(lu,'(91a)') ('-',i=1,91) |
---|
951 | do 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 | |
---|
1002 | end do |
---|
1003 | write(lu,'(91a)') ('-',i=1,91) |
---|
1004 | end subroutine mp_balances_ |
---|
1005 | |
---|
1006 | !======================================================================= |
---|
1007 | end module m_zeit |
---|
1008 | !. |
---|