← Back to branch summary

~ubuntu-branches/ubuntu/utopic/nwchem/utopic

« back to all changes in this revision

Viewing changes to src/tools/ga-5-1/global/testing/mir_perf2.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Daniel Leidert, Andreas Tille, Michael Banck
  • Date: 2013-07-04 12:14:55 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130704121455-5tvsx2qabor3nrui
Tags: 6.3-1
http://bugs.debian.org/696361
* New upstream release.
* Fixes anisotropic properties (Closes: #696361).
* New features include:
  + Multi-reference coupled cluster (MRCC) approaches
  + Hybrid DFT calculations with short-range HF 
  + New density-functionals including Minnesota (M08, M11) and HSE hybrid
    functionals
  + X-ray absorption spectroscopy (XAS) with TDDFT
  + Analytical gradients for the COSMO solvation model
  + Transition densities from TDDFT 
  + DFT+U and Electron-Transfer (ET) methods for plane wave calculations
  + Exploitation of space group symmetry in plane wave geometry optimizations
  + Local density of states (LDOS) collective variable added to Metadynamics
  + Various new XC functionals added for plane wave calculations, including
    hybrid and range-corrected ones
  + Electric field gradients with relativistic corrections 
  + Nudged Elastic Band optimization method
  + Updated basis sets and ECPs 

[ Daniel Leidert ]
* debian/watch: Fixed.

[ Andreas Tille ]
* debian/upstream: References

[ Michael Banck ]
* debian/upstream (Name): New field.
* debian/patches/02_makefile_flags.patch: Refreshed.
* debian/patches/06_statfs_kfreebsd.patch: Likewise.
* debian/patches/07_ga_target_force_linux.patch: Likewise.
* debian/patches/05_avoid_inline_assembler.patch: Removed, no longer needed.
* debian/patches/09_backported_6.1.1_fixes.patch: Likewise.
* debian/control (Build-Depends): Added gfortran-4.7 and gcc-4.7.
* debian/patches/10_force_gcc-4.7.patch: New patch, explicitly sets
  gfortran-4.7 and gcc-4.7, fixes test suite hang with gcc-4.8 (Closes:
  #701328, #713262).
* debian/testsuite: Added tests for COSMO analytical gradients and MRCC.
* debian/rules (MRCC_METHODS): New variable, required to enable MRCC methods.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tools/ga-5-1/global/testing/mir_perf2.F
1
 
#if HAVE_CONFIG_H
2
 
#   include "config.fh"
3
 
#endif
4
 
c $Id: mir_perf2.F,v 1.1 2003-02-26 15:33:38 d3g293 Exp $
5
 
c------------------------------------------------------------------------
6
 
c Program perf.x is used to test performance of GA put, get, accumulate  |
7
 
c It has to be executed on four processors.                              |
8
 
c remote operations access data on processes 1,2,3 in the round-robin way|
9
 
c------------------------------------------------------------------------
10
 
c
11
 
#define SLEEP sleep
12
 
      program perf
13
 
      implicit none
14
 
#include "mafdecls.fh"
15
 
#include "global.fh"
16
 
      integer heap
17
 
c
18
 
c***  Intitialize a message passing library
19
 
c
20
 
#include "mp3.fh"
21
 
c
22
 
c***  Intitialize the GA package
23
 
      call ga_initialize()
24
 
      if(ga_nnodes().ne.4 .and. ga_nodeid().eq.0)
25
 
     $   call ga_error('Program requires 4 GA processes',ga_nnodes())
26
 
c
27
 
c***  Initialize the MA package
28
 
      heap = 900000
29
 
      if (.not. ma_init(MT_DBL, heap,heap)) 
30
 
     $     call ga_error('ma init failed',2*heap) 
31
 
c
32
 
c      call test2D()
33
 
      call test1D()
34
 
c
35
 
      if(ga_nodeid().eq.0) print *,'All tests successful '
36
 
c
37
 
      call ga_terminate()
38
 
c
39
 
      call MP_FINALIZE()
40
 
      end
41
 
 
42
 
 
43
 
      subroutine test1D()
44
 
      implicit none
45
 
#include "mafdecls.fh"
46
 
#include "global.fh"
47
 
c     
48
 
c
49
 
      integer n, nn, num_chunks
50
 
      parameter (n = 1024*1024, nn = n/4, num_chunks=16)
51
 
      double precision buf(nn)
52
 
c
53
 
      integer g_a
54
 
      integer ilo, ihi, jlo, jhi
55
 
      integer nproc, me, loop
56
 
      integer chunk(num_chunks)
57
 
      data    chunk /1,9,16,81,256,576,900,2304,4096,8281,
58
 
     $               16384,29241,65536,124609,193600,262144/
59
 
c     
60
 
      nproc = ga_nnodes()
61
 
      me = ga_nodeid()
62
 
c
63
 
c***  Create global array
64
 
      if (.not. ga_create(MT_DBL, n, 1, 'a', 0, 0, g_a))
65
 
     $     call ga_error(' ga_create failed ',1)
66
 
c     
67
 
      do loop=1,nn
68
 
         buf(loop) = .01d0
69
 
      enddo
70
 
      call ga_zero(g_a) 
71
 
c
72
 
      if (me .eq. 0) then
73
 
        write(*,*)' '
74
 
        write(*,*)' '
75
 
        write(*,*)' '
76
 
        write(*,55)n
77
 
55      format(' Performance of GA get, put & acc',
78
 
     $           ' for 1-dimensional sections of array[',i7,']')
79
 
        print *,' '
80
 
      endif
81
 
c
82
 
c     do loop=1,2
83
 
c
84
 
c***  local ops
85
 
c
86
 
      call ga_distribution(g_a, me, ilo, ihi, jlo, jhi)
87
 
      call TestPutGetAcc1
88
 
     &     (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo, jhi, .true.)
89
 
c
90
 
c***  remote ops
91
 
c
92
 
      call TestPutGetAcc1
93
 
     &     (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo, jhi,.false.)
94
 
 
95
 
c     enddo
96
 
      end
97
 
 
98
 
 
99
 
      subroutine TestPutGetAcc1
100
 
     &      (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo,jhi, local)
101
 
      implicit none
102
 
#include "global.fh"
103
 
#include "testutil.fh"
104
 
c
105
 
      integer num_chunks, chunk(num_chunks)
106
 
      integer n, ilo, ihi, jlo,jhi,g_a
107
 
      double precision buf(*), tg, tp, ta
108
 
      double precision time_acc1, time_get1, time_put1
109
 
      logical local
110
 
c
111
 
      integer me
112
 
      integer loop, jump, count, bytes
113
 
c
114
 
      me = ga_nodeid()
115
 
      if (me .eq. 0) then
116
 
        write(6,*)' '
117
 
        if(local) then
118
 
          write(6,'(26X, 25HLocal 1-D Array Section    )') 
119
 
        else
120
 
          write(6,'(26X, 25HRemote 1-D Array Section   )') 
121
 
        endif
122
 
 
123
 
        write(6,*)'    section           get               put',
124
 
     &           '           accumulate'
125
 
        write(6,*)' bytes    dim     sec      MB/s     sec      MB/s',
126
 
     &           '     sec      MB/s'
127
 
        call flush(6)
128
 
      endif
129
 
      call ga_sync()
130
 
c
131
 
      do loop = 1, num_chunks
132
 
        bytes = util_mdtob(1)*chunk(loop) ! how much data is accessed
133
 
        jump  =  n/(6000*loop) ! jump distance between consecutive patches
134
 
        if(loop.eq.num_chunks)jump=0
135
 
c
136
 
c       everybody touches own data 
137
 
        call ga_fill_patch(g_a, 1, n, 1, 1 , 1d0*me*loop)
138
 
        if (me .eq. 0) then
139
 
        tg=time_get1(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count,
140
 
     $               local)
141
 
        else
142
 
          call SLEEP(1)
143
 
        endif
144
 
c
145
 
c       everybody touches own data
146
 
        call ga_fill_patch(g_a, 1, n, 1, 1 , 1d0*me*loop)
147
 
        if (me .eq. 0) then
148
 
        tp=time_put1(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count, 
149
 
     $               local)
150
 
        else
151
 
          call SLEEP(1)
152
 
        endif
153
 
c
154
 
c       everybody touches own data
155
 
        call ga_fill_patch(g_a, 1, n, 1, 1 , 1d0*me*loop)
156
 
        if (me .eq. 0) then
157
 
        ta=time_acc1(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count,
158
 
     $               local)
159
 
        else
160
 
          call SLEEP(1)
161
 
        endif
162
 
c
163
 
        if (me .eq. 0) then
164
 
          write(6,77)bytes, chunk(loop), tg, 
165
 
     &          1d-6*bytes/tg,tp, 1d-6*bytes/tp, ta, 1d-6*bytes/ta
166
 
          call flush(6)
167
 
        endif
168
 
      enddo
169
 
c
170
 
77    format(i7, i7,1x, 3(1x,d8.3,1x,d8.3))
171
 
      end
172
 
 
173
 
 
174
 
 
175
 
      double precision function
176
 
     &   time_acc1(g_a, is, ie, js, je, buf, chunk, jump, count, local)
177
 
c
178
 
      implicit none
179
 
#include "global.fh"
180
 
#include "testutil.fh"
181
 
c
182
 
      integer g_a, chunk, jump, count, is, js, ie, je
183
 
      logical local 
184
 
      integer rows, indx, shifti
185
 
c
186
 
      integer ilo, ihi, jlo, jhi
187
 
      double precision seconds, buf 
188
 
c
189
 
      count = 0
190
 
      rows = ie - is + 1
191
 
      shifti = 2*rows 
192
 
      jlo = js
193
 
      jhi = je
194
 
 
195
 
      seconds = util_timer()
196
 
c
197
 
c       distance between consecutive patches increased by jump
198
 
c       to destroy locality of reference
199
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
200
 
           ihi = ilo + chunk -1
201
 
           count = count + 1
202
 
           if (local) then
203
 
                 call ga_acc(g_a, ilo, ihi, jlo, jhi, buf, chunk, 1d0)
204
 
           else
205
 
                 call ga_acc(g_a, ilo+shifti, ihi+shifti,
206
 
     $                       jlo, jhi,  buf, chunk, 1d0)
207
 
           endif
208
 
        enddo
209
 
      seconds = util_timer() - seconds
210
 
c
211
 
      time_acc1 = seconds/count
212
 
      end
213
 
 
214
 
 
215
 
      double precision function
216
 
     &    time_get1(g_a, is, ie, js, je, buf, chunk, jump, count, local)
217
 
c
218
 
      implicit none
219
 
#include "global.fh"
220
 
#include "testutil.fh"
221
 
c
222
 
      integer g_a, chunk, jump, count, is, js, ie, je
223
 
      integer rows, indx, shifti
224
 
      logical local
225
 
c
226
 
      integer ilo, ihi, jlo, jhi
227
 
      double precision seconds, buf
228
 
c
229
 
      count = 0
230
 
      rows = ie - is + 1
231
 
      shifti = 2*rows
232
 
      jlo = js
233
 
      jhi = je
234
 
 
235
 
      seconds = util_timer()
236
 
c
237
 
c       distance between consecutive patches increased by jump
238
 
c       to destroy locality of reference
239
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
240
 
              ihi = ilo + chunk -1
241
 
              count = count + 1
242
 
              if (local) then
243
 
                 call ga_get(g_a, ilo, ihi, jlo, jhi, buf, chunk)
244
 
              else
245
 
                 call ga_get(g_a, ilo+shifti, ihi+shifti,
246
 
     $                       jlo, jhi,  buf, chunk)
247
 
              endif
248
 
        enddo
249
 
      seconds = util_timer() - seconds
250
 
c
251
 
      time_get1 = seconds/count
252
 
      end
253
 
 
254
 
 
255
 
 
256
 
      double precision function
257
 
     &   time_put1(g_a, is, ie, js, je, buf, chunk, jump, count, local)
258
 
c
259
 
      implicit none
260
 
#include "global.fh"
261
 
#include "testutil.fh"
262
 
c
263
 
      integer g_a, chunk, jump, count, is, js, ie, je
264
 
      integer rows, indx, shifti
265
 
      logical local
266
 
c
267
 
      integer ilo, ihi, jlo, jhi
268
 
      double precision  seconds, buf
269
 
c
270
 
      count = 0
271
 
      rows = ie - is + 1
272
 
      shifti = 2*rows
273
 
      jlo = js
274
 
      jhi = je
275
 
 
276
 
      seconds = util_timer()
277
 
c
278
 
c       distance between consecutive patches increased by jump
279
 
c       to destroy locality of reference
280
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
281
 
              ihi = ilo + chunk -1
282
 
              count = count + 1
283
 
              if (local) then
284
 
                 call ga_put(g_a, ilo, ihi, jlo, jhi, buf, chunk)
285
 
              else
286
 
                 call ga_put(g_a, ilo+shifti, ihi+shifti,
287
 
     $                       jlo, jhi,  buf, chunk)
288
 
              endif
289
 
        enddo
290
 
      seconds = util_timer() - seconds
291
 
c
292
 
      time_put1 = seconds/count
293
 
      end
294
 
 
295
 
 
296
 
 
297
 
c
298
 
c     test for square patches
299
 
c
300
 
      subroutine test2D()
301
 
      implicit none
302
 
#include "mafdecls.fh"
303
 
#include "global.fh"
304
 
c
305
 
      integer n, nn, num_chunks
306
 
      parameter (n = 1024, nn = n*n/4, num_chunks=16)
307
 
      double precision buf(nn)
308
 
c
309
 
      integer g_a
310
 
      integer ilo, ihi, jlo, jhi
311
 
      integer nproc, me, loop
312
 
      integer chunk(num_chunks)
313
 
      data    chunk /1,3,4,9,16,24,30,48,64,91,128,171,256,353,440,512/
314
 
c     
315
 
      nproc = ga_nnodes()
316
 
      me = ga_nodeid()
317
 
c
318
 
c***  Create global array
319
 
      if (.not. ga_create(MT_DBL, n, n, 'a', 0, 0, g_a))
320
 
     $     call ga_error(' ga_create failed ',1)
321
 
c     
322
 
      do loop=1,nn
323
 
         buf(loop) = .01d0
324
 
      enddo
325
 
      call ga_zero(g_a) 
326
 
c
327
 
      if (me .eq. 0) then
328
 
        write(*,*)' '
329
 
        write(*,55)n,n
330
 
55      format(' Performance of GA get, put & acc',
331
 
     $           ' for square sections of array[',i4,',',i4,']')
332
 
        print *,' '
333
 
      endif
334
 
c
335
 
c     do loop=1,2
336
 
c
337
 
c***  local ops
338
 
c
339
 
      call ga_distribution(g_a, me, ilo, ihi, jlo, jhi)
340
 
      call TestPutGetAcc
341
 
     &     (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo, jhi, .true.)
342
 
c
343
 
c***  remote ops
344
 
c
345
 
      call TestPutGetAcc
346
 
     &     (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo, jhi,.false.)
347
 
 
348
 
c     enddo
349
 
      end
350
 
 
351
 
 
352
 
      subroutine TestPutGetAcc
353
 
     &      (g_a, n, chunk, num_chunks, buf, ilo, ihi, jlo,jhi, local)
354
 
      implicit none
355
 
#include "global.fh"
356
 
#include "testutil.fh"
357
 
c
358
 
      integer num_chunks, chunk(num_chunks)
359
 
      integer n, ilo, ihi, jlo,jhi,g_a
360
 
      double precision buf(*), tg, tp, ta
361
 
      double precision time_acc, time_get, time_put
362
 
      logical local
363
 
c
364
 
      integer me
365
 
      integer loop, jump, count, bytes
366
 
c
367
 
      me = ga_nodeid()
368
 
      if (me .eq. 0) then
369
 
        write(6,*)' '
370
 
        if(local) then
371
 
          write(6,'(26X, 25HLocal 2-D Array Section    )') 
372
 
        else
373
 
          write(6,'(26X, 25HRemote 2-D Array Section   )') 
374
 
        endif
375
 
 
376
 
        write(6,*)'    section           get               put',
377
 
     &           '           accumulate'
378
 
        write(6,*)' bytes    dim     sec      MB/s     sec      MB/s',
379
 
     &           '     sec      MB/s'
380
 
        call flush(6)
381
 
      endif
382
 
      call ga_sync()
383
 
c
384
 
      do loop = 1, num_chunks
385
 
        bytes = util_mdtob(1)*chunk(loop)*chunk(loop) !how much data is accessed
386
 
        jump  =  n/(60*loop) ! jump distance between consecutive patches
387
 
        if(loop.eq.num_chunks)jump=0
388
 
c
389
 
c       everybody touches own data 
390
 
        call ga_fill_patch(g_a, 1, n, 1, n , 1d0*me*loop)
391
 
        if (me .eq. 0) then
392
 
        tg=time_get(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count,
393
 
     $               local)
394
 
        else
395
 
          call SLEEP(1)
396
 
        endif
397
 
c
398
 
c       everybody touches own data
399
 
        call ga_fill_patch(g_a, 1, n, 1, n , 1d0*me*loop)
400
 
        if (me .eq. 0) then
401
 
        tp=time_put(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count, 
402
 
     $               local)
403
 
        else
404
 
          call SLEEP(1)
405
 
        endif
406
 
c
407
 
c       everybody touches own data
408
 
        call ga_fill_patch(g_a, 1, n, 1, n , 1d0*me*loop)
409
 
        if (me .eq. 0) then
410
 
        ta=time_acc(g_a,ilo,ihi,jlo,jhi,buf,chunk(loop),jump,count,
411
 
     $               local)
412
 
        else
413
 
          call SLEEP(1)
414
 
        endif
415
 
c
416
 
        if (me .eq. 0) then
417
 
          write(6,77)bytes, chunk(loop), tg, 
418
 
     &          1d-6*bytes/tg,tp, 1d-6*bytes/tp, ta, 1d-6*bytes/ta
419
 
          call flush(6)
420
 
        endif
421
 
      enddo
422
 
c
423
 
77    format(i7, i7,1x, 3(1x,d8.3,1x,d8.3))
424
 
      end
425
 
 
426
 
 
427
 
 
428
 
      double precision function
429
 
     &   time_acc(g_a, is, ie, js, je, buf, chunk, jump, count, local)
430
 
c
431
 
      implicit none
432
 
#include "global.fh"
433
 
#include "testutil.fh"
434
 
c
435
 
      integer g_a, chunk, jump, count, is, js, ie, je
436
 
      logical local 
437
 
      integer rows, cols, indx, shifti(3), shiftj(3)
438
 
c
439
 
      integer ilo, ihi, jlo, jhi
440
 
      double precision  seconds, buf 
441
 
c
442
 
      count = 0
443
 
      rows = ie - is + 1
444
 
      cols = je - js + 1
445
 
      shifti(1) = rows
446
 
      shifti(2) = 0
447
 
      shifti(3) = rows
448
 
      shiftj(1) = 0
449
 
      shiftj(2) = cols
450
 
      shiftj(3) = cols
451
 
 
452
 
      seconds = util_timer()
453
 
c
454
 
c       distance between consecutive patches increased by jump
455
 
c       to destroy locality of reference
456
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
457
 
           ihi = ilo + chunk -1
458
 
           do jlo = js, je -chunk-jump +1, chunk+jump
459
 
              jhi = jlo + chunk -1
460
 
              count = count + 1
461
 
              if (local) then
462
 
                 call ga_acc(g_a, ilo, ihi, jlo, jhi, buf, chunk, 1d0)
463
 
              else
464
 
                 indx = Mod(count,3) + 1 
465
 
                 call ga_acc(g_a, ilo+shifti(indx), ihi+shifti(indx),
466
 
     $                       jlo+shiftj(indx), jhi+shiftj(indx), 
467
 
     $                       buf, chunk, 1d0)
468
 
              endif
469
 
           enddo
470
 
        enddo
471
 
      seconds = util_timer() - seconds
472
 
c
473
 
      time_acc = seconds/count
474
 
      end
475
 
 
476
 
 
477
 
      double precision function
478
 
     &    time_get(g_a, is, ie, js, je, buf, chunk, jump, count, local)
479
 
c
480
 
      implicit none
481
 
#include "global.fh"
482
 
#include "testutil.fh"
483
 
c
484
 
      integer g_a, chunk, jump, count, is, js, ie, je
485
 
      integer rows, cols, indx, shifti(3), shiftj(3)
486
 
      logical local
487
 
c
488
 
      integer ilo, ihi, jlo, jhi
489
 
      double precision  seconds, buf
490
 
c
491
 
      count = 0
492
 
      rows = ie - is + 1
493
 
      cols = je - js + 1
494
 
      shifti(1) = rows
495
 
      shifti(2) = 0
496
 
      shifti(3) = rows
497
 
      shiftj(1) = 0
498
 
      shiftj(2) = cols
499
 
      shiftj(3) = cols
500
 
 
501
 
      seconds = util_timer()
502
 
c
503
 
c       distance between consecutive patches increased by jump
504
 
c       to destroy locality of reference
505
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
506
 
           ihi = ilo + chunk -1
507
 
           do jlo = js, je -chunk-jump +1, chunk+jump
508
 
              jhi = jlo + chunk -1
509
 
              count = count + 1
510
 
              if (local) then
511
 
                 call ga_get(g_a, ilo, ihi, jlo, jhi, buf, chunk)
512
 
              else
513
 
                 indx = Mod(count,3) + 1
514
 
                 call ga_get(g_a, ilo+shifti(indx), ihi+shifti(indx),
515
 
     $                       jlo+shiftj(indx), jhi+shiftj(indx),
516
 
     $                       buf, chunk)
517
 
              endif
518
 
           enddo
519
 
        enddo
520
 
      seconds = util_timer() - seconds
521
 
c
522
 
      time_get = seconds/count
523
 
      end
524
 
 
525
 
 
526
 
 
527
 
      double precision function
528
 
     &   time_put(g_a, is, ie, js, je, buf, chunk, jump, count, local)
529
 
c
530
 
      implicit none
531
 
#include "global.fh"
532
 
#include "testutil.fh"
533
 
c
534
 
      integer g_a, chunk, jump, count, is, js, ie, je
535
 
      integer rows, cols, indx, shifti(3), shiftj(3)
536
 
      logical local
537
 
c
538
 
      integer ilo, ihi, jlo, jhi
539
 
      double precision  seconds, buf
540
 
c
541
 
      count = 0
542
 
      rows = ie - is + 1
543
 
      cols = je - js + 1
544
 
      shifti(1) = rows
545
 
      shifti(2) = 0
546
 
      shifti(3) = rows
547
 
      shiftj(1) = 0
548
 
      shiftj(2) = cols
549
 
      shiftj(3) = cols
550
 
 
551
 
      seconds = util_timer()
552
 
c
553
 
c       distance between consecutive patches increased by jump
554
 
c       to destroy locality of reference
555
 
        do ilo = is, ie -chunk-jump +1, chunk+jump
556
 
           ihi = ilo + chunk -1
557
 
           do jlo = js, je -chunk-jump +1, chunk+jump
558
 
              jhi = jlo + chunk -1
559
 
              count = count + 1
560
 
              if (local) then
561
 
                 call ga_put(g_a, ilo, ihi, jlo, jhi, buf, chunk)
562
 
              else
563
 
                 indx = Mod(count,3) + 1
564
 
                 call ga_put(g_a, ilo+shifti(indx), ihi+shifti(indx),
565
 
     $                       jlo+shiftj(indx), jhi+shiftj(indx),
566
 
     $                       buf, chunk)
567
 
              endif
568
 
           enddo
569
 
        enddo
570
 
      seconds = util_timer() - seconds
571
 
c
572
 
      time_put = seconds/count
573
 
      end
574
 
 
575
 
 
576
 
      subroutine my_sleep(seconds)
577
 
      implicit none
578
 
#include "global.fh"
579
 
#include "testutil.fh"
580
 
c
581
 
      double precision  ts, te, work
582
 
      integer seconds, loop
583
 
      common  /sleep_block/ work
584
 
c
585
 
      ts = util_timer()
586
 
      work = 0.
587
 
100   continue
588
 
         do loop= 1, 500
589
 
            work = work + 1.
590
 
         enddo
591
 
         te = util_timer()
592
 
      if(te - ts .lt. real(seconds)) goto 100
593
 
*     print *, work, ts, te 
594
 
      end