c-----------------------------------------------------------------------------
c This Program tests all the PVM 3.0 Fortran calls.
c It should be executed from a Unix prompt, not from pvm console:
c  % testall <RETURN>
c Because the Fortran library is just an interface to the C routines
c this program also tests all of the C routines required by 
c the Fortran interface.
c
c The following C routine features are not available in Fortran 
c   pvm_spawn    using argv
c   pvm_config   returning an array of hostp structures
c   pvm_addhosts adding multiple hosts
c   pvm_delhosts deleting multiple hosts
c   pvm_recvf    changing receive context
c-----------------------------------------------------------------------------
      implicit none
      include '../include/fpvm3.h'
      integer mytid, off, on, prev, parentid, nproc, nitem, info
      integer i, mbuf, oldbuf, err, stid, msgtag, bytes, ntask 
      integer nhost, narch, mstat, pstat, nobuf, j
      integer tids(10), sbuf(3), rbuf(2)
      integer htids(10), speeds(10)
      integer iwhich, ttids(10), ptids(10), flag(10)
      integer*2   i2data(100)
      integer*4   i4data(100)
      real*4      r4data(100)
      real*8      r8data(100)
      complex     c8data(100)
      complex*16  c16data(100)
      character   host*24, arch*8
      character*16  hosts(10)
      character*16  aout(10)
      character*8   archs(10)

      print *,'Testing PVM 3.0 Fortran Routines'
      print *,' '
c     -------------------
c     Enroll into PVM 3.0
c     -------------------
      CALL PVMFMYTID( mytid )

      if( mytid .lt. 0 ) then
         print *,'Error in pvmfmytid error=',mytid
         stop
      else
         print *,'My task id is ',mytid
      endif
c     ---------------------------
c     Turn on auto error checking
c     ---------------------------
c     off = 0
      on  = 1
      CALL PVMFSERROR( on, prev )
      if( prev .lt. 0 ) then
         print *,'Error in pvmfserror error=',prev
      else
         print *,'Activated PVM auto error checking'
         print *,'Errors written to log file /tmp/pvml.nnnnn'
      endif
c     ---------------
c     Test pvmfparent
c     ---------------
      CALL PVMFPARENT( parentid )

      if( parentid .lt. 0 ) then
         if( parentid .eq. PvmNoParent ) then
            print *,'Task ',mytid,' has no parent'
         else
            print *,'Error in pvmfparent error=',parentid
         endif
      else
c        --------------------------------
c         Send slave into simple echo loop
c        --------------------------------
         goto 1111
      endif
c     --------------------------------------
c     Test pvmfspawn with default placement
c     --------------------------------------
      print *,' '
      print *,'Testing spawn of multiple tasks with default placement'
      nproc = 0
      ntask = 4
      CALL PVMFSPAWN( 'testall', PVMDEFAULT, '*', ntask, tids, info) 

      do 100 i=1,ntask
         if( tids(i) .lt. 0 ) then
            print *,'Error in pvmfspawn (tid) error=',tids(i)
         else
            print *,'Spawned slave with tid=',tids(i)
            nproc = nproc+1
         endif
  100 continue
      if( info .lt. 0 ) then
         print *,'Error in pvmfspawn info=',info
         goto 900
      endif
c     ------------------------------------------
c     Test pvmfspawn with architecture specified
c     ------------------------------------------
      print *,' '
      print *,'Testing spawn to specific architecture'
      print *,'Enter desired ARCH in present machine:'
      read (*,'(A)')  arch
      ntask = 1
      CALL PVMFSPAWN( 'testall', PVMARCH, arch,
     >                ntask, tids(nproc+1), info) 

      do 110 i=nproc+1, nproc+ntask
         if( tids(i) .lt. 0 ) then
            print *,'Error in pvmfspawn (arch) error=',tids(i)
         else
            print *,'Spawned slave with tid=',tids(i),' on ', arch
            nproc = nproc+1
         endif
  110    continue
      if( info .lt. 0 ) then
         print *,'Error in pvmfspawn (arch) error=',info
      endif
c     ------------------------------------------
c     Test pvmfspawn with host specified
c     ------------------------------------------
      print *,' '
      print *,'Testing spawn to specific host'
      print *,'Enter desired host:'
      read (*,'(A)') host
      ntask = 1
      CALL PVMFSPAWN('testall', PVMHOST, host,
     >                ntask, tids(nproc+1), info) 

      do 120 i=nproc+1, nproc+ntask
         if( tids(i) .lt. 0 ) then
            print *,'Error in pvmfspawn (host) error=',tids(i)
         else
            print *,'Spawned slave with tid=',tids(i),' on ', host
            nproc = nproc+1
         endif
  120 continue
      if( info .lt. 0 ) then
         print *,'Error in pvmfspawn (host) error=',info
      endif
c     ------------------------------
c     Test adding and deleting hosts
c     ------------------------------
      print *,' '
      print *,'Testing adding hosts to PVM'
      print *,'Enter host to add:'
      read (*,'(A)') host
      CALL PVMFADDHOST( host, info )

      if( info .lt. 0 ) then
         print *,'Error in pvmfaddhost error=',info
      else
         print *,'Added ',host,' to configuration'
         ntask = 1
         CALL PVMFSPAWN('testall',PVMHOST,host,
     >                   ntask,tids(nproc+1),info) 
         if( info .lt. 0 ) then
            print *,'Error in pvmfspawn (host) error=',info
         else
            print *,'Started task ',tids(nproc+1),' on ',host
            nproc = nproc+1
         endif
c        -------------------------
c        Test Information routines
c        -------------------------
         print *,' '
         print *,'Testing Information routines'
         CALL PVMFCONFIG( nhost, narch, htids(1), hosts(1), archs(1), 
     >                    speeds(1), info )
         if( info .lt. 0 ) then
            print *,'Error in pvmfconfig info=',info
         else
            print *,'There are ',nhost, 'hosts' 
            print *,'The present configuration is:'
            print *,'            hostname        ARCH ',
     >              '       pvmd-tid   packet size       speed'
            print *,'        -------------------------',
     >              '-----------------------------------------'
            i = 1
            print *,i, hosts(i), archs(i), htids(i),
     >              speeds(i)
            do 123 i=2, nhost
               CALL PVMFCONFIG( nhost, narch, htids(i), hosts(i),
     >                    archs(i), speeds(i), info )
               print *,i, hosts(i), archs(i), htids(i),
     >                 speeds(i)
  123       continue
            print *,'        -------------------------',
     >              '-----------------------------------------'
         endif
         print *,' '
         iwhich = PVMDEFAULT
         CALL PVMFTASKS( iwhich, ntask, ttids(1), ptids(1), htids(1),
     >                    flag(1), aout(1), info )
         if( info .lt. 0 ) then
            print *,'Error in pvmftasks info=',info
         else

            print *,'There are ',ntask, 'tasks' 
            print *,'Running PVM tasks:'
            print *,'            tasktname            tid ',
     >              '     parent-tid    pvmd-tid      flags'
            print *,'        -------------------------',
     >              '-----------------------------------------'
            i = 1
            print *,i, aout(i), ttids(i), ptids(i), htids(i), flag(i)
            do 234 i=2, ntask
               CALL PVMFTASKS( iwhich, ntask, ttids(i), ptids(i), 
     >                    htids(i), flag(i), aout(i), info )
               print *,i, aout(i),ttids(i),ptids(i),htids(i),flag(i)
  234       continue
            print *,'        -------------------------',
     >              '-----------------------------------------'
         endif
         print *,' '
         print *,' other routines'
         CALL PVMFMSTAT( host, mstat)
         if( mstat .lt. 0 ) then
            print *,'Error in pvmfmstat mstat=',mstat
         else
            print *,'pvmfmstat returns ',mstat
         endif
         CALL PVMFPSTAT( tids(nproc), pstat )
         if( pstat .lt. 0 ) then
            print *,'Error in pvmfpstat pstat=',pstat
         else
            print *,'pvmfpstat returns ',pstat
         endif
c        -----------------------------------------
c        Test killing processes and deleting hosts
c        -----------------------------------------
         print *,' '
         print *,'Testing deleting hosts from PVM'
         CALL PVMFKILL( tids(nproc), info )
         if( info .lt. 0 ) then
             print *,'Error in pvmfkill error=',info
         else
             print *,'Killed task ',tids(nproc),' on ',host
             nproc = nproc-1
         endif
         CALL PVMFDELHOST( host, info )

         if( info .lt. 0 ) then
            print *,'Error in pvmfdelhost error=',info
         else
            print *,'Deleted ',host,' from configuration'
         endif 
      endif
c     ----------------------------
c     Test message buffer routines
c     ----------------------------
      print *,' '
      print *,'Testing message buffer routines'
      CALL PVMFINITSEND( PVMDEFAULT, sbuf(2) )
      if( sbuf(2) .lt. 1 ) then
         print *,'Error in pvmfinitsend (default) error=',sbuf(2)
      endif
      CALL PVMFPACK( INTEGER4, mytid, 1, 1, info )
c     --------------------------------
c     Switch send buffers saving state
c     --------------------------------
      CALL PVMFMKBUF( PVMDEFAULT, sbuf(1) )
      if( sbuf(1) .lt. 1 ) then
         print *,'Error in pvmfmkbuf (default) error=',sbuf(1)
      else
         CALL PVMFSETSBUF( sbuf(1), sbuf(2) )
         if( sbuf(2) .lt. 1 ) then
            print *,'Error in pvmfsetsbuf error=', sbuf(2)
         endif
         CALL PVMFGETSBUF( mbuf )
         if( mbuf .lt. 1 ) then
            print *,'Error in pvmfgetsbuf error=', mbuf
         endif
         CALL PVMFPACK( INTEGER4, oldbuf, 1, 1, info )
         CALL PVMFSEND( tids(1), 55, info )
         CALL PVMFFREEBUF( sbuf(1), info )
         if( info .lt. 0 ) then
            print *,'Error in pvmffreebuf (send) error=', info
         endif
         CALL PVMFRECV( tids(1), 65, oldbuf)
c        ---------------------------------
c        Save recv buffer to unpack later
c        ---------------------------------
         nobuf = 0
         CALL PVMFSETRBUF( nobuf, rbuf(1) )
         if( rbuf(1) .lt. 1 ) then
            print *,'Error in pvmfsetrbuf Error=', rbuf(1)
         endif
      endif      
c     -----------------------------------
c     Switch back to original send buffer
c     -----------------------------------
      CALL PVMFSETSBUF( sbuf(2), info )
      CALL PVMFSEND( tids(1), 55, info )
      CALL PVMFRECV( tids(1), 65, rbuf(2))
      CALL PVMFUNPACK( INTEGER4, oldbuf, 1, 1, info )
c     ---------------------
c     Test encoding options
c     ---------------------
      CALL PVMFMKBUF( PVMRAW, sbuf(2) )
      if( sbuf(2) .lt. 1 ) then
         print *,'Error in pvmfmkbuf (raw) error=',sbuf(2)
      else
         CALL PVMFSETSBUF( sbuf(2), oldbuf )
         CALL PVMFPACK( INTEGER4, oldbuf, 1, 1, info )
         CALL PVMFSEND( tids(2), 55, info )
         CALL PVMFFREEBUF( sbuf(2), info )
         CALL PVMFRECV( tids(2), 65, rbuf(2) )
c        ------------------------------
c        Test destroying receive buffer
c        ------------------------------
         CALL PVMFFREEBUF( rbuf(2), info )
         if( info .lt. 0 ) then
            print *,'Error in pvmffreebuf (recv) error=', info
         endif
      endif      
      CALL PVMFMKBUF( PVMINPLACE, sbuf(3) )
      if( sbuf(3) .lt. 1 ) then
         print *,'Error in pvmfmkbuf using inplace option =',sbuf(3)
      endif      
c     ------------------------------
c     Unpack previous receive buffer
c     ------------------------------
      CALL PVMFSETRBUF( rbuf(1), oldbuf )
      if( oldbuf .lt. 0 ) then
         print *,'Error in pvmfsetrbuf error=', oldbuf
      else
         CALL PVMFUNPACK( INTEGER4, oldbuf, 1, 1, info )
      endif
      print *,'message buffer tests completed'
      print *,' '
      print *,'Testing message packing/unpacking'
c     ----------------------
c     Test packing/unpacking
c     ----------------------
      nitem = 100
      CALL PVMFINITSEND( PVMDEFAULT, mbuf )
      if( mbuf .lt. 1 ) print *,'Error in pvmfinitsend ',mbuf
      CALL PVMFPACK( STRING,  'Pack Test',  9, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (STRING)'
      CALL PVMFPACK( BYTE1,     i4data,    64, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (BYTE1)'
      CALL PVMFPACK( INTEGER2,  i2data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (INTEGER2)'
      CALL PVMFPACK( INTEGER4,  i4data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (INTEGER4)'
      CALL PVMFPACK( REAL4,     r4data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (REAL4)'
      CALL PVMFPACK( COMPLEX8,  c8data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (COMPLEX8)'
      CALL PVMFPACK( REAL8,     r8data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (REAL8)'
      CALL PVMFPACK( COMPLEX16, c16data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfpack (COMPLEX16)'
      
      CALL PVMFSEND( tids(2), 44, info )
      CALL PVMFRECV( tids(2), 44, info )

      CALL PVMFUNPACK( STRING,  'Pack Test',  9, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (STRING)'
      CALL PVMFUNPACK( BYTE1,     i4data,    64, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (BYTE1)'
      CALL PVMFUNPACK( INTEGER2,  i2data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (INTEGER2)'
      CALL PVMFUNPACK( INTEGER4,  i4data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (INTEGER4)'
      CALL PVMFUNPACK( REAL4,     r4data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (REAL4)'
      CALL PVMFUNPACK( COMPLEX8,  c8data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (COMPLEX8)'
      CALL PVMFUNPACK( REAL8,     r8data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (REAL8)'
      CALL PVMFUNPACK( COMPLEX16, c16data, nitem, 1, info )
      if( info .lt. 0 ) print *,'Error in pvmfunpack (COMPLEX16)'
      print *,'message packing tests completed'
      print *,' '
c     --------------
c     Test multicast
c     --------------
      CALL PVMFINITSEND( PVMDEFAULT, mbuf )
      CALL PVMFPACK( INTEGER4, i4data, 1, 1, info )
      CALL PVMFMCAST( nproc, tids, 55, info )
      if( info .lt. 0 ) then
         print *,'Error in pvmfmcast ',info
      else
         print *,'Multicast to ',nproc,' tasks done'
      endif
c     ----------------------------------
c     Test nrecv on echos from multicast
c     ----------------------------------
      do 400 i=1, nproc
 300  continue
      CALL PVMFNRECV( -1, 65, mbuf )
      if( mbuf .lt. 0 ) then
         print*,'Error in pvmfnrecv error=',mbuf
      else if( mbuf .eq. 0 ) then
         goto 300
      else
         CALL PVMFUNPACK( INTEGER4, i4data, 1, 1, info )
         CALL PVMFBUFINFO( mbuf, bytes, msgtag, stid, info )
         if( info .lt. 0 ) then
            print *,'Error in pvmfbufinfo error=',info
         endif
         print *,'Non-blocking receive of multicast echo from ', stid
      endif
 400  continue
c     ---------------
c     Kill all slaves
c     ---------------
      do 800 i=1, nproc
        CALL PVMFKILL( tids(i), info)
 800  continue
      print *,' '
      print *,'All slaves killed'
c     --------------
c     Test pvmfexit
c     --------------
 900  continue
      CALL PVMFEXIT( info )
      if( info .lt. 0 ) then
         print *,'Error in pvmfexit error=',info
      endif
      print *,'Exiting PVM'
      stop 'Test Complete'

1111  continue
c     ---------------
c     Slave echo loop
c     ---------------
      CALL PVMFRECV( -1, -1, mbuf )
      if( info .lt. 0 ) then
         CALL PVMFPERROR('slave trouble', err)
      endif
c     --------------------------------------------
c     Check message tag and echo back same message
c     --------------------------------------------
      CALL PVMFBUFINFO( mbuf, bytes, msgtag, stid, info )

      if( msgtag .eq. 55 ) then
         CALL PVMFUNPACK( INTEGER4, i4data, 1, 1, info )
         CALL PVMFINITSEND( PVMDEFAULT, info )
         CALL PVMFPACK(   INTEGER4, i4data, 1, 1, info )
         CALL PVMFSEND( parentid, 65, info )
      else if( msgtag .eq. 44 ) then
         nitem = 100
         CALL PVMFUNPACK( STRING,  'Pack Test',  9, 1, info )
         CALL PVMFUNPACK( BYTE1,     i4data,    64, 1, info )
         CALL PVMFUNPACK( INTEGER2,  i2data, nitem, 1, info )
         CALL PVMFUNPACK( INTEGER4,  i4data, nitem, 1, info )
         CALL PVMFUNPACK( REAL4,     r4data, nitem, 1, info )
         CALL PVMFUNPACK( COMPLEX8,  c8data, nitem, 1, info )
         CALL PVMFUNPACK( REAL8,     r8data, nitem, 1, info )
         CALL PVMFUNPACK( COMPLEX16, c16data, nitem, 1, info )
      
         CALL PVMFINITSEND( PVMDEFAULT, mbuf )
         CALL PVMFPACK( STRING,  'Pack Test',  9, 1, info )
         CALL PVMFPACK( BYTE1,     i4data,    64, 1, info )
         CALL PVMFPACK( INTEGER2,  i2data, nitem, 1, info )
         CALL PVMFPACK( INTEGER4,  i4data, nitem, 1, info )
         CALL PVMFPACK( REAL4,     r4data, nitem, 1, info )
         CALL PVMFPACK( COMPLEX8,  c8data, nitem, 1, info )
         CALL PVMFPACK( REAL8,     r8data, nitem, 1, info )
         CALL PVMFPACK( COMPLEX16, c16data, nitem, 1, info )
         CALL PVMFSEND( parentid, 44, info )
      else
         print *,'Slave trouble: unknown message tag'
      endif

      goto 1111
      end

      
