SERVER.f

Go to the documentation of this file.

!
      SUBROUTINE server

!
      use ctlblk_mod, only: mpi_comm_inter
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -     
      implicit none
!
      include 'mpif.h'
!
      LOGICAL :: done, newfile
      INTEGER :: status(mpi_status_size)
      INTEGER :: ierr, count, lun,ier
      CHARACTER*255 :: fname
      CHARACTER*1, ALLOCATABLE :: buf(:)
!
!---------------------------------------------------------------------  
!
!     THIS CODE IS EXPECTING THE FOLLOWING MESSAGE STRUCTURE
!
!     VARIABLE     TYPE           DESCRIPTION     TAG
!=====================================================
!     DONE         LOGICAL        ARE WE DONE?    1
!     NEWFILE      LOGICAL        OPEN THE FILE?  2
!     LUN          INTEGER        FORTRAN UNIT #  3
!     FNAME        CHARACTER*255  FILE NAME       4
!     BUF          CHARACTER*1(*) BURF RECORD     5
!
!---------------------------------------------------------------------
!
      print *, ' STARTING UP IO SERVER ...'
      do while (.not. done)
!
!     THE FIRST MESSAGE IS A LOGICAL TO TELL US WHETHER WE ARE
!     FINISHED OR NOT
!
      CALL mpi_recv(done,1,mpi_logical,          &
                    0,1,mpi_comm_inter,status,ierr)
!
      IF ( done ) THEN
         print *, ' SHUTTING DOWN IO SERVER ...'
         RETURN   !    RETURNING TO MAIN
      END IF
!
!     DO WE NEED TO OPEN THE FILE ?
!
      CALL mpi_recv(newfile,1,mpi_logical,       &
                    0,2,mpi_comm_inter,status,ierr)
!
!     FORTRAN UNIT NUMBER
!
      CALL mpi_recv(lun,1,mpi_integer,           &
                    0,3,mpi_comm_inter,status,ierr)
!
!     FILENAME
!
      CALL mpi_recv(fname,255,mpi_character,     &
                    0,4,mpi_comm_inter,status,ierr)
!
!     OPEN THE FILE, IF NECESSARY
!
      IF ( newfile ) THEN
          CLOSE(lun)
          CALL baopenwt(lun,fname,ier)
          print *, ' FILE ',fname,' OPENED AS UNIT ',lun
      END IF
!
!     DETERMINE THE SIZE OF THE BUFR RECORD AND ALLOCATE A BUFFER FOR IT
!
      CALL mpi_probe(0,5,mpi_comm_inter,status,ierr)
      CALL mpi_get_count(status,mpi_character,count,ierr)
      ALLOCATE( buf( count ) )
!   
!     FINALLY, GET THE BUFR RECORD
!
      CALL mpi_recv(buf,count,mpi_character,      &
                    0,5,mpi_comm_inter,status,ierr)
!
!     OUT TO DISK WE GO ...
!
      CALL wryte(lun,count,buf)
      DEALLOCATE(buf)
      enddo !end do while loop 
      END