c-----------------------------------------------------------------------------
c This Program tests most of  the PVM 3 Fortran calls.
c It should be executed from a Unix prompt, not from pvm console:
c 
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-----------------------------------------------------------------------------
      implicit none
      include '../include/fpvm3.h'
      integer mytid, parentid, nproc, nitem, info
      integer i, mbuf, oldbuf, err, stid, msgtag, bytes, ntask 
      integer nhost, narch, nobuf
      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 Fortran Routines'
      print *,' '
c     -------------------
c     Enroll into PVM 3
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     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   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'
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( PVMDATAINPLACE, 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

      
