← Back to branch summary

~ubuntu-branches/ubuntu/saucy/nwchem/saucy

« back to all changes in this revision

Viewing changes to src/tools/ga-5-1/armci/tcgmsg/ipcv4.0/testf.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Michael Banck, Daniel Leidert
  • Date: 2012-02-09 20:02:41 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120209200241-jgk03qfsphal4ug2
Tags: 6.1-1
http://bugs.debian.org/632611
https://launchpad.net/bugs/791308
* New upstream release.

[ Michael Banck ]
* debian/patches/02_makefile_flags.patch: Updated.
* debian/patches/02_makefile_flags.patch: Use internal blas and lapack code.
* debian/patches/02_makefile_flags.patch: Define GCC4 for LINUX and LINUX64
  (Closes: #632611 and LP: #791308).
* debian/control (Build-Depends): Added openssh-client.
* debian/rules (USE_SCALAPACK, SCALAPACK): Removed variables (Closes:
  #654658).
* debian/rules (LIBDIR, USE_MPIF4, ARMCI_NETWORK): New variables.
* debian/TODO: New file.
* debian/control (Build-Depends): Removed libblas-dev, liblapack-dev and
  libscalapack-mpi-dev.
* debian/patches/04_show_testsuite_diff_output.patch: New patch, shows the
  diff output for failed tests.
* debian/patches/series: Adjusted.
* debian/testsuite: Optionally run all tests if "all" is passed as option.
* debian/rules: Run debian/testsuite with "all" if DEB_BUILD_OPTIONS
  contains "checkall".

[ Daniel Leidert ]
* debian/control: Used wrap-and-sort. Added Vcs-Svn and Vcs-Browser fields.
  (Priority): Moved to extra according to policy section 2.5.
  (Standards-Version): Bumped to 3.9.2.
  (Description): Fixed a typo.
* debian/watch: Added.
* debian/patches/03_hurd-i386_define_path_max.patch: Added.
  - Define MAX_PATH if not defines to fix FTBFS on hurd.
* debian/patches/series: Adjusted.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tools/ga-5-1/armci/tcgmsg/ipcv4.0/testf.F
 
1
#if HAVE_CONFIG_H
 
2
#    include "config.fh"
 
3
#endif
 
4
      program main
 
5
      implicit double precision (a-h,o-z)
 
6
c
 
7
c     FORTRAN program to test message passing routines
 
8
c
 
9
c     LOG is the FORTRAN unit number for standard output.
 
10
c
 
11
      parameter (LOG = 6)
 
12
      parameter (MAXLEN = 262144 )
 
13
#include "msgtypesf.h"
 
14
      dimension buf(MAXLEN)
 
15
      integer ibuf(MAXLEN)
 
16
      character*80 fname
 
17
      integer dtype
 
18
c
 
19
c     Always the first thing to do is call pbeginf
 
20
c
 
21
      call pbeginf
 
22
      call setdbg(0)
 
23
      call evon
 
24
c
 
25
c     who am i and how many processes
 
26
c
 
27
      nproc = nnodes()
 
28
      me = nodeid()
 
29
c
 
30
c     now try broadcasting messages from all nodes to every other node
 
31
c     send each process my id as a message
 
32
c     
 
33
      call evbgin('Hello test')
 
34
      itype = 1 + MSGINT
 
35
      
 
36
      do 10 iproc = 0,nproc-1
 
37
         itest = me
 
38
         call brdcst(itype, itest, mitob(1),iproc)
 
39
         if (iproc.ne.me) then
 
40
            write(LOG,1) me, itest
 
41
 1          format(' me=',i3,', itest=',i3)
 
42
         endif
 
43
 10   continue
 
44
      call evend('Hello test')
 
45
      call evbgin('Counter test')
 
46
c
 
47
c     now try using the shared counter
 
48
c
 
49
      mproc = nproc
 
50
      do 20 i = 1,10
 
51
         write(LOG,*) ' process ',me,' got ',nxtval(mproc)
 
52
 20   continue
 
53
      junk = nxtval(-mproc)
 
54
      call evend('Counter test')
 
55
c
 
56
c     now time sending a message round a ring
 
57
c
 
58
      if (nproc.gt.1) then
 
59
        call evbgin('Ring test')
 
60
        itype = 3
 
61
        left = mod(me + nproc - 1, nproc)
 
62
        iright = mod(me + 1, nproc)
 
63
c      
 
64
        lenbuf = 1
 
65
 30     if (me .eq. 0) then
 
66
           start = tcgtime()
 
67
           call snd(itype, buf, lenbuf, left, 1)
 
68
           call rcv(itype, buf, lenbuf, lenmes, iright, node, 1)
 
69
           used = tcgtime() - start
 
70
           if (used.gt.0d0) then
 
71
             rate = 1.0d-6 * dble(nproc * lenbuf) / used
 
72
           else
 
73
             rate = 0.0d0
 
74
           endif
 
75
           write(LOG,31) lenbuf, used, rate
 
76
        else
 
77
           call rcv(itype, buf, lenbuf, lenmes, iright, node, 1)
 
78
           call snd(itype, buf, lenbuf, left, 1)
 
79
        endif
 
80
        lenbuf = lenbuf * 2
 
81
        if (lenbuf .le. mdtob(MAXLEN)) goto 30
 
82
 31   format(' len=',i7,' bytes, used=',f8.2,' cs, rate=',f10.6,' Mb/s')
 
83
        call evend('Ring test')
 
84
      endif
 
85
c
 
86
c     global sums
 
87
c
 
88
      do i=1,MAXLEN
 
89
         ibuf(i) = i*me
 
90
         buf(i) = dble(ibuf(i))
 
91
      enddo
 
92
      dtype=1+MSGDBL
 
93
      call igop(itype, ibuf, MAXLEN, "+")
 
94
      call dgop(dtype, buf, MAXLEN, "+")
 
95
      
 
96
      do i=1,MAXLEN
 
97
         iresult = i*nproc*(nproc-1)/2
 
98
         if (ibuf(i).ne.iresult.or.buf(i).ne.dble(iresult))
 
99
     .      call error('TestGlobals: global sum failed',  i)
 
100
      enddo
 
101
      
 
102
      if (me.eq.0) write(LOG,*) 'global sums OK'
 
103
 
 
104
c
 
105
c
 
106
c     Check that everyone can open, write, read and close
 
107
c     a binary FORTRAN file
 
108
c
 
109
      call pfname('junk',fname)
 
110
      open(9,file=fname,form='unformatted',status='unknown',
 
111
     &  err=1000)
 
112
      write(9,err=1001) buf
 
113
      rewind 9
 
114
      read(9,err=1002) buf
 
115
      close(9,status='delete')
 
116
      call event('Read file OK')
 
117
c
 
118
      if (me.eq.0) call stats
 
119
c
 
120
c     Always the last thing to do is call pend
 
121
c
 
122
      call pend
 
123
c
 
124
c     check that everyone makes it thru after pend .. NODEID
 
125
c     is not actually guaranteed to work outside of pbegin/pend
 
126
c     section ... it may return junk. All you should do is exit
 
127
c     is some FORTRAN supported fashion
 
128
c
 
129
      write(LOG,32) nodeid()
 
130
 32   format(' Process ',i4,' after pend')
 
131
      stop
 
132
c
 
133
c     error returns for FORTRAN I/O
 
134
c
 
135
1000  call error('failed to open fortran binary file',-1)
 
136
1001  call error('failed to write fortran binary file',-1)
 
137
1002  call error('failed to read fortran binary file',-1)
 
138
c
 
139
      end
 
140
      subroutine pfname(name, fname)
 
141
      character*(*) name, fname
 
142
c
 
143
c     construct a unique filename by appending the process
 
144
c     number after the stub name
 
145
c     i.e. <fname> = <name>.<mynode>
 
146
c
 
147
c     find last non-blank character in name
 
148
c
 
149
      do 10 i = len(name),1,-1
 
150
      if (name(i:i).ne.' ') goto 20
 
151
10    continue
 
152
      call error('pfname: name is all blanks!',i)
 
153
c
 
154
c     check that have room to store result and then write result
 
155
c
 
156
20    if (i+4.gt.len(fname))
 
157
     &  call error('pfname: fname too short for name.id',len(fname))
 
158
      fname = name
 
159
      write(fname(i+1:i+4),1) nodeid()
 
160
1     format('.',i3.3)
 
161
c
 
162
      end
 
163
      subroutine error(s,i)
 
164
      parameter (LOG = 6)
 
165
      character*(*) s
 
166
      integer i
 
167
c
 
168
      write(LOG,1) s,i
 
169
 1    format(//
 
170
     $     ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'/
 
171
     $     1x,a,1x,i8/
 
172
     $     ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'/)
 
173
c    $     1x,a,1x,i8/
 
174
c
 
175
      call parerr(i)
 
176
c
 
177
      end