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

Last change on this file since 36 was 36, checked in by ymipsl, 15 years ago

Les buffers MPI sont maintenant donnes en quantite de memoire totale par serveur et non par client.
La valeur par defaut peut etre redefinie dans la namelist.

YM
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  INTEGER,SAVE :: mpi_buffer_size
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    mpi_buffer_size=global_mpi_buffer_size/nb_client 
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.