source: XMLIO_SERVER/trunk/src/IOSERVER/mod_mpi_buffer_server.f90 @ 17

Last change on this file since 17 was 17, checked in by ymipsl, 16 years ago

Correction de bugs pour portage sur Mercure
File size: 8.4 KB
Line 
1MODULE mod_mpi_buffer_server
2  USE mod_mpi_buffer_parameters
3
4  TYPE mpi_requests
5    INTEGER :: Pos
6    INTEGER :: size
7  END TYPE mpi_requests
8 
9  TYPE buffer
10    INTEGER(KIND=8),POINTER  :: mpi_buffer(:)
11    INTEGER :: pos
12    INTEGER :: begin
13    TYPE(mpi_requests),POINTER :: request(:)
14    INTEGER :: request_pos
15    INTEGER :: nb_request
16    INTEGER :: request_begin
17    INTEGER :: request_free
18    LOGICAL :: is_posted
19    LOGICAL :: is_terminated
20    INTEGER :: last_request
21  END TYPE buffer
22
23  TYPE(buffer),ALLOCATABLE,SAVE :: buffers(:)
24 
25  INTEGER,SAVE :: current_rank
26 
27 
28CONTAINS
29 
30  SUBROUTINE Init_mpi_buffer
31  USE mod_ioserver_para
32  USE mod_global_memory
33  IMPLICIT NONE
34    INTEGER :: n
35   
36    ALLOCATE(buffers(nb_client))
37   
38    DO n=1,nb_client
39      CALL allocate_global_memory(mpi_buffer_size,buffers(n)%MPI_Buffer)
40      buffers(n)%pos=1
41      buffers(n)%begin=1
42      ALLOCATE(buffers(n)%request(max_request))
43      buffers(n)%nb_request=0
44      buffers(n)%request_free=max_request
45      buffers(n)%request_pos=1
46      buffers(n)%request_begin=1
47      buffers(n)%is_posted=.FALSE.
48      buffers(n)%is_terminated=.FALSE.
49    ENDDO
50
51  END SUBROUTINE Init_mpi_buffer
52
53  SUBROUTINE Check_buffer
54  USE mod_ioserver_para
55  USE mpitrace
56  IMPLICIT NONE
57  INCLUDE 'mpif.h'
58    INTEGER :: n
59    INTEGER :: status(MPI_STATUS_SIZE)
60    LOGICAL :: ok_complete
61    LOGICAL :: ok_out
62    INTEGER :: ierr
63    INTEGER :: message_size
64    INTEGER :: Buffer_space 
65    INTEGER :: request
66   
67    CALL VTb(VTcheck_buffer)
68    DO n=1,nb_client
69      ok_out=.FALSE.
70     
71      DO WHILE (.NOT. ok_out)
72       
73        IF (buffers(n)%is_posted) THEN
74!          PRINT*,"MPI_TEST"
75!          PRINT *,"MPI_TEST LAST_REQUEST (avant)",buffers(n)%last_request,"ok_complete ?",ok_complete
76          CALL MPI_TEST(buffers(n)%last_request,ok_complete,status,ierr)
77!          PRINT *,"MPI_TEST LAST_REQUEST (apres)",buffers(n)%last_request,"ok_complete ?",ok_complete
78
79          IF (ok_complete) THEN
80            CALL MPI_GET_COUNT(status,MPI_INTEGER8,message_size,ierr)
81            CALL Fill_request(n,Buffers(n)%pos,message_size)
82            buffers(n)%is_posted=.FALSE.
83            buffers(n)%pos=buffers(n)%pos+message_size
84         
85!            PRINT *,"buffer_pos",buffers(n)%pos
86!            PRINT *,"Message recu de taille", message_size
87!              PRINT *,"Message : ",buffers(n)%mpi_buffer(buffers(n)%pos:buffers(n)%pos+message_size-1)
88!              PRINT *,"Nouvelle taille buffer_pos",buffers(n)%pos
89              ok_out=.FALSE.
90          ELSE
91              ok_out=.TRUE.
92          ENDIF
93       
94        ELSE  ! (.NOT. is_posted)       
95!          PRINT *,"MPI_IPROBE"
96     
97          CALL MPI_IPROBE(client_rank(n),tag_iocomm,iocomm,ok_complete,status,ierr)
98!          PRINT *,"Ok_complete.. ?",ok_complete
99          IF (ok_complete) THEN
100            CALL MPI_GET_COUNT(status,MPI_INTEGER8,message_size,ierr)
101!            PRINT *,"message_size",message_size
102            IF (buffers(n)%pos >= buffers(n)%begin) THEN
103              IF (buffers(n)%pos+message_size>mpi_buffer_size) THEN
104                buffer_space=buffers(n)%begin-1
105              ELSE
106                buffer_space=mpi_buffer_size-buffers(n)%begin+1
107              ENDIF
108            ELSE
109              buffer_space=buffers(n)%begin-buffers(n)%pos
110            ENDIF
111           
112            IF (buffer_space < message_size .OR. buffers(n)%request_free==0) THEN
113              ok_out=.TRUE.
114!              PRINT *,"BUFFER FULL !!!!"
115!              PRINT *,"buffer_space",buffer_space,"request_free",buffers(n)%request_free
116!              PRINT *,"buffer_pos",buffers(n)%pos,"buffer_begin",buffers(n)%begin
117            ELSE
118             
119              IF (buffers(n)%pos+message_size>mpi_buffer_size) buffers(n)%pos=1
120         
121!              PRINT *,'reception du message'
122              CALL MPI_IRECV(buffers(n)%mpi_buffer(buffers(n)%pos),message_size,MPI_INTEGER8,          &
123                          client_rank(n),tag_iocomm,iocomm,buffers(n)%last_request,ierr)
124                         
125              buffers(n)%is_posted=.TRUE.
126!              PRINT *,"MPI_IRECV LAST_REQUEST",buffers(n)%last_request
127              CALL MPI_TEST(buffers(n)%last_request,ok_complete,status,ierr)
128!              PRINT *,"MPI_TEST LAST_REQUEST",buffers(n)%last_request,"ok_complete ?",ok_complete
129             
130              IF (ok_complete) THEN
131                buffers(n)%is_posted=.FALSE.
132                CALL Fill_request(n,Buffers(n)%pos,message_size)
133
134                buffers(n)%pos=buffers(n)%pos+message_size
135                 
136!                PRINT *,"buffer_pos",buffers(n)%pos
137!                PRINT *,"Message recu de taille", message_size
138!                PRINT *,"Message : ",buffers(n)%mpi_buffer(buffers(n)%pos:buffers(n)%pos+message_size-1)
139!                PRINT *,"Nouvelle taille buffer_pos",buffers(n)%pos
140                ok_out=.FALSE.
141              ELSE
142                ok_out=.TRUE.
143              ENDIF
144         
145            ENDIF
146          ELSE
147            ok_out=.TRUE.
148          ENDIF
149        ENDIF  ! (is_posted)
150        ok_out=.TRUE.
151      ENDDO
152    ENDDO
153
154    CALL VTe(VTcheck_buffer)
155
156  END SUBROUTINE Check_buffer
157 
158  SUBROUTINE Fill_request(n,pos,message_size)
159  USE mpi
160  IMPLICIT NONE
161    INTEGER :: n
162    INTEGER :: pos
163    INTEGER :: message_size
164    INTEGER :: current_size
165    INTEGER :: current_pos
166    INTEGER :: total_size
167    LOGICAL :: ok_out
168    INTEGER :: ierr
169!    PRINT *,'Fill_request!!!'
170!    PRINT *,'Buffer_pos',pos
171!    PRINT *,"First integer",Buffers(n)%mpi_buffer(pos)
172    total_size=0
173    current_pos=pos
174   
175    ok_out=.FALSE.
176    DO WHILE (.NOT. ok_out)
177     
178      IF (Buffers(n)%request_free==0) THEN
179        PRINT *,'Plus de requete disponible !!!!'
180        CALL MPI_ABORT(MPI_COMM_WORLD,-1,ierr)
181      ENDIF
182     
183      current_size=buffers(n)%mpi_buffer(current_pos)
184      Buffers(n)%request(Buffers(n)%request_pos)%pos=current_pos+1
185      Buffers(n)%request(Buffers(n)%request_pos)%size=current_size
186      total_size=total_size+current_size
187     
188      IF (Buffers(n)%request_pos==max_request) THEN
189        Buffers(n)%request_pos=1
190      ELSE
191        Buffers(n)%request_pos=Buffers(n)%request_pos+1
192      ENDIF
193      Buffers(n)%request_free=Buffers(n)%request_free-1
194      Buffers(n)%nb_request=Buffers(n)%nb_request+1
195     
196      IF (total_size==message_size) ok_out=.TRUE.
197      IF (total_size>message_size) THEN
198        PRINT *,"Probleme : la taille du message ne coincide pas avec la taille de l'enveloppe"
199        CALL MPI_ABORT(MPI_COMM_WORLD,-1,ierr)
200      ENDIF
201     
202      current_pos=current_pos+current_size
203    ENDDO
204 
205  END SUBROUTINE Fill_request 
206   
207 
208  SUBROUTINE Process_request(is_terminated)
209  USE mod_event_server
210  USE mod_ioserver_para
211  USE mod_pack
212  USE mpitrace
213  USE mod_wait
214  IMPLICIT NONE
215    LOGICAL  :: is_terminated
216    INTEGER  :: n
217   
218    is_terminated=.FALSE.
219   
220    IF (ALL(buffers(:)%nb_request>0)) THEN
221      DO n=1,nb_client
222!        PRINT *,"nb_request ?",buffers(n)%nb_request
223        IF ( (buffers(n)%nb_request > 0) .AND. (.NOT. buffers(n)%is_terminated)) THEN
224!          PRINT *,"request_pos",buffers(n)%request_begin
225!          PRINT *,"buffer_pos",buffers(n)%request(buffers(n)%request_begin)%pos
226          CALL set_pack_buffer(buffers(n)%mpi_buffer,buffers(n)%request(buffers(n)%request_begin)%pos)
227          CALL VTb(VTprocess_event)
228          current_rank=n
229          CALL process_event(n,buffers(n)%is_terminated)
230          CALL VTe(VTprocess_event)
231          buffers(n)%nb_request=buffers(n)%nb_request-1
232          buffers(n)%request_free=buffers(n)%request_free+1
233       
234       
235          IF (Buffers(n)%request_begin==max_request) THEN
236            Buffers(n)%request_begin=1
237          ELSE
238            buffers(n)%request_begin=Buffers(n)%request_begin+1
239          ENDIF
240         
241          IF (buffers(n)%nb_request > 0) THEN
242            buffers(n)%begin=buffers(n)%request(buffers(n)%request_begin)%pos
243          ELSE
244            buffers(n)%begin=buffers(n)%pos
245          ENDIF
246        ENDIF
247      ENDDO 
248   
249!      PRINT *,"buffers_is_terminated",buffers(1:nb_client)%is_terminated
250!      PRINT *,"buffers_nb_request",buffers(1:nb_client)%nb_request
251      IF (ALL(buffers(1:nb_client)%is_terminated)) THEN
252        IF (ALL(buffers(1:nb_client)%nb_request==0)) THEN
253          is_terminated=.TRUE.
254        ENDIF
255      ENDIF
256    ELSE
257      CALL Wait_us(5)
258    ENDIF     
259  END SUBROUTINE process_request 
260 
261   
262END MODULE mod_mpi_buffer_server
Note: See TracBrowser for help on using the repository browser.