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

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

Correction de bugs pour portage sur Mercure
File size: 4.8 KB
Line 
1MODULE mod_mpi_buffer_client
2  USE mod_mpi_buffer_parameters
3  USE mpi, ONLY : status_size=>MPI_STATUS_SIZE
4 
5  INTEGER(KIND=8),POINTER :: MPI_Buffer(:)
6 
7  TYPE mpi_requests
8    INTEGER :: request
9    INTEGER :: status(status_size)
10    INTEGER :: Pos
11  END TYPE mpi_requests
12 
13  TYPE(mpi_requests),DIMENSION(max_request) :: pending_request
14 
15  INTEGER :: Buffer_pos
16  INTEGER :: request_pos
17  INTEGER :: buffer_begin
18  INTEGER :: request_begin
19  INTEGER :: nb_request_pending
20  INTEGER,SAVE :: start_pos
21  LOGICAL,SAVE :: ok_new_request
22 
23CONTAINS
24
25  SUBROUTINE Init_mpi_buffer
26  USE mod_global_memory
27  USE mod_pack
28  IMPLICIT NONE
29 
30    CALL allocate_global_memory(mpi_buffer_size,MPI_Buffer)
31    buffer_begin=1
32    request_begin=1
33    Buffer_pos=1
34    nb_request_pending=0
35    Request_pos=1
36    ok_new_request=.TRUE.
37    CALL set_pack_buffer(MPI_Buffer,buffer_begin)
38   
39  END SUBROUTINE Init_mpi_buffer
40 
41
42  SUBROUTINE create_request(request_id)
43  USE mod_pack
44  USE mod_ioclient_para
45  USE mpitrace
46  IMPLICIT NONE
47    INCLUDE 'mpif.h'
48    INTEGER :: request_id
49   
50    CALL VTb(VTprocess_event)
51    IF (ok_new_request) THEN 
52      Pending_request(Request_pos)%Pos = pack_pos
53      ok_new_request=.FALSE.
54    ENDIF
55    start_pos=pack_pos
56    pack_pos=pack_pos+1
57!    PRINT *,"Pos in Buffer",Pending_request(Request_pos)%Pos,"pack_pos",pack_pos
58    CALL pack(request_id)
59  END SUBROUTINE create_request
60 
61 
62  SUBROUTINE Finalize_request
63  USE mod_pack
64  USE mod_ioclient_para
65  USE mpitrace
66  use mod_wait
67  IMPLICIT NONE
68    INCLUDE 'mpif.h'
69    INTEGER :: ierr
70    INTEGER :: message_size
71    INTEGER(KIND=8) :: request_size
72    INTEGER :: buffer_free
73    LOGICAL :: ok_out
74    LOGICAL :: is_Buffer_full
75    request_size=pack_pos-start_pos   
76    pack_buffer(start_pos)=request_size
77    message_size=pack_pos-Pending_request(Request_pos)%Pos
78
79
80!! ICI verifier que le buffer ne se recouvre pas ainsi que les requetes
81   
82    ok_out=.FALSE.
83    is_buffer_full=.FALSE.
84    DO WHILE (.NOT. ok_out)
85      CALL check_request
86   
87      IF ( buffer_begin <= pack_pos) THEN
88        Buffer_free=mpi_buffer_size-pack_pos+1
89      ELSE
90        Buffer_free=buffer_begin-pack_pos
91      ENDIF
92     
93!      Print *,"message_size",message_size,"buffer_free",buffer_free
94!      PRINT *,"Request_pos",request_pos
95!      PRINT *,"Pos in Buffer",Pending_request(Request_pos)%Pos,"pack_pos",pack_pos
96      IF ( nb_request_pending==1 .AND. (buffer_free < MPI_buffer_size * 0.4) ) THEN
97        ok_out=.FALSE.
98        CALL Wait_us(1)
99        IF (.NOT. is_buffer_full) THEN
100          CALL VTb(VTbuffer_full)
101        ENDIF     
102        is_Buffer_full=.TRUE.
103       
104      ELSE
105        ok_out=.TRUE.
106        IF (is_buffer_full) THEN
107          CALL VTe(VTbuffer_full)
108        ENDIF
109        is_buffer_full=.FALSE.
110     
111      ENDIF
112     
113   ENDDO
114   
115   IF (nb_request_pending==0 .OR. (buffer_free < MPI_buffer_size* 0.4 )) THEN
116     
117     CALL MPI_ISSEND(MPI_Buffer(Pending_request(Request_pos)%Pos),message_size,MPI_INTEGER8,     &
118                    server_rank,tag_iocomm,iocomm,Pending_request(Request_pos)%request,ierr )
119   
120!    PRINT *,"Requete envoyï¿œe !!!!"
121!    PRINT *,"Message : ",MPI_Buffer(Pending_request(Request_pos)%Pos:Pending_request(Request_pos)%Pos+message_size-1)             
122      IF ( Pack_Pos > MPI_buffer_size*0.6 ) THEN
123        Pack_Pos=1
124      ENDIF
125   
126      IF (Request_Pos==max_request) THEN
127        Request_Pos=1
128      ELSE
129        Request_Pos=Request_Pos+1
130      ENDIF
131      nb_request_pending=nb_request_pending+1
132   
133      ok_new_request=.TRUE.
134   
135    ENDIF
136    CALL VTe(VTprocess_event)   
137  END SUBROUTINE Finalize_request
138
139
140  SUBROUTINE Check_request
141  IMPLICIT NONE
142  INCLUDE 'mpif.h'
143  LOGICAL :: ok_out
144  LOGICAL :: OK_complete
145  INTEGER :: ierr
146 
147!    PRINT *, 'on entre dans Check_request'
148!    PRINT *, 'nb_request_pending',nb_request_pending
149   
150    IF (nb_request_pending>0) THEN
151      ok_out=.FALSE.
152    ELSE
153      ok_out=.TRUE.
154    ENDIF
155   
156    DO WHILE (.NOT. ok_out)
157   
158!      PRINT *,'Testing_request...'
159!      PRINT *,'request_begin',request_begin
160      CALL MPI_TEST(Pending_request(request_begin)%request,ok_complete,Pending_request(request_begin)%status,ierr)
161!      PRINT *,'Request has been tested...'
162      IF (ok_complete) THEN
163!        PRINT *,"Request_completed"
164        IF (Request_begin==max_request) THEN
165          Request_begin=1
166        ELSE
167          request_begin=request_begin+1
168        ENDIF
169       
170        buffer_begin=Pending_request(request_begin)%Pos
171       
172        nb_request_pending=nb_request_pending-1
173       
174        IF (nb_request_pending==0) THEN
175          ok_out=.TRUE.
176        ELSE
177          ok_out=.FALSE.
178        ENDIF
179      ELSE
180        ok_out=.TRUE.
181      ENDIF
182   
183    ENDDO
184!    PRINT *, 'on sort de Check_request' 
185  END SUBROUTINE Check_Request
186
187END MODULE mod_mpi_buffer_client
Note: See TracBrowser for help on using the repository browser.