UPP (develop)
Loading...
Searching...
No Matches
SERVER.f
Go to the documentation of this file.
1
2!
36 SUBROUTINE server
37
38!
39 use ctlblk_mod, only: mpi_comm_inter
40!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
41 implicit none
42!
43 include 'mpif.h'
44!
45 LOGICAL :: DONE, NEWFILE
46 INTEGER :: STATUS(MPI_STATUS_SIZE)
47 INTEGER :: IERR, COUNT, LUN,IER
48 CHARACTER*255 :: FNAME
49 CHARACTER*1, ALLOCATABLE :: BUF(:)
50!
51!---------------------------------------------------------------------
52!
53! THIS CODE IS EXPECTING THE FOLLOWING MESSAGE STRUCTURE
54!
55! VARIABLE TYPE DESCRIPTION TAG
56!=====================================================
57! DONE LOGICAL ARE WE DONE? 1
58! NEWFILE LOGICAL OPEN THE FILE? 2
59! LUN INTEGER FORTRAN UNIT # 3
60! FNAME CHARACTER*255 FILE NAME 4
61! BUF CHARACTER*1(*) BURF RECORD 5
62!
63!---------------------------------------------------------------------
64!
65 print *, ' STARTING UP IO SERVER ...'
66 do while (.not. done)
67!
68! THE FIRST MESSAGE IS A LOGICAL TO TELL US WHETHER WE ARE
69! FINISHED OR NOT
70!
71 CALL mpi_recv(done,1,mpi_logical, &
72 0,1,mpi_comm_inter,status,ierr)
73!
74 IF ( done ) THEN
75 print *, ' SHUTTING DOWN IO SERVER ...'
76 RETURN ! RETURNING TO MAIN
77 END IF
78!
79! DO WE NEED TO OPEN THE FILE ?
80!
81 CALL mpi_recv(newfile,1,mpi_logical, &
82 0,2,mpi_comm_inter,status,ierr)
83!
84! FORTRAN UNIT NUMBER
85!
86 CALL mpi_recv(lun,1,mpi_integer, &
87 0,3,mpi_comm_inter,status,ierr)
88!
89! FILENAME
90!
91 CALL mpi_recv(fname,255,mpi_character, &
92 0,4,mpi_comm_inter,status,ierr)
93!
94! OPEN THE FILE, IF NECESSARY
95!
96 IF ( newfile ) THEN
97 CLOSE(lun)
98 CALL baopenwt(lun,fname,ier)
99 print *, ' FILE ',fname,' OPENED AS UNIT ',lun
100 END IF
101!
102! DETERMINE THE SIZE OF THE BUFR RECORD AND ALLOCATE A BUFFER FOR IT
103!
104 CALL mpi_probe(0,5,mpi_comm_inter,status,ierr)
105 CALL mpi_get_count(status,mpi_character,count,ierr)
106 ALLOCATE( buf( count ) )
107!
108! FINALLY, GET THE BUFR RECORD
109!
110 CALL mpi_recv(buf,count,mpi_character, &
111 0,5,mpi_comm_inter,status,ierr)
112!
113! OUT TO DISK WE GO ...
114!
115 CALL wryte(lun,count,buf)
116 DEALLOCATE(buf)
117 enddo !end do while loop
118 END
subroutine server
SUBPROGRAM: SERVER PERFORMS IO TO DISK PRGRMMR: TUCCILLO ORG: IBM.
Definition SERVER.f:37