source: LMDZ6/trunk/libf/dyn3dmem/mod_hallo.f90 @ 5425

Last change on this file since 5425 was 5362, checked in by abarral, 3 weeks ago

(fix previous) remove nonexisting imported vars

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 55.3 KB
Line 
1module mod_Hallo
2USE parallel_lmdz
3implicit none
4  logical,save :: use_mpi_alloc
5  integer, parameter :: MaxProc=512
6  integer, parameter :: DefaultMaxBufferSize=1024*1024*100
7  integer, SAVE :: MaxBufferSize=0
8  integer, parameter :: ListSize=1000
9 
10  integer,save       :: MaxBufferSize_Used
11!$OMP THREADPRIVATE( MaxBufferSize_Used)
12
13   real,save,pointer,dimension(:) :: Buffer
14!$OMP THREADPRIVATE(Buffer)
15
16   integer,save,dimension(Listsize) :: Buffer_Pos
17   integer,save :: Index_Pos
18!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
19   
20  type Hallo
21    real, dimension(:,:),pointer :: Field
22    integer :: offset
23    integer :: size
24    integer :: NbLevel
25    integer :: Stride
26  end type Hallo
27 
28  type request_SR
29    integer :: NbRequest=0
30    integer :: NbRequestMax=0
31    integer :: BufferSize
32    integer :: Pos
33    integer :: Index
34    type(Hallo), POINTER :: Hallo(:)
35    integer :: MSG_Request
36  end type request_SR
37
38  type request
39    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
40    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
41    integer :: tag=1
42  end type request
43 
44   TYPE(distrib),SAVE :: distrib_gather
45
46
47  INTERFACE Register_SwapField_u
48    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u, &
49                     Register_SwapField1d_u_bis,Register_SwapField2d_u1d_bis,Register_SwapField3d_u_bis
50  END INTERFACE Register_SwapField_u
51
52  INTERFACE Register_SwapField_v
53    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v,&
54                     Register_SwapField1d_v_bis,Register_SwapField2d_v1d_bis,Register_SwapField3d_v_bis
55  END INTERFACE Register_SwapField_v
56
57  INTERFACE Register_SwapField2d_u
58    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d, &
59                     Register_SwapField1d_u2d_bis,Register_SwapField2d_u2d_bis,Register_SwapField3d_u2d_bis
60  END INTERFACE Register_SwapField2d_u
61
62  INTERFACE Register_SwapField2d_v
63    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d, &
64                     Register_SwapField1d_v2d_bis,Register_SwapField2d_v2d_bis,Register_SwapField3d_v2d_bis
65  END INTERFACE Register_SwapField2d_v
66
67  contains
68
69  subroutine Init_mod_hallo
70    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
71    USE paramet_mod_h
72    USE IOIPSL
73    implicit none
74    integer :: jj_nb_gather(0:mpi_size-1)
75   
76    Index_Pos=1
77    Buffer_Pos(Index_Pos)=1
78    MaxBufferSize_Used=0
79!$OMP MASTER     
80    MaxBufferSize=DefaultMaxBufferSize
81    CALL getin("mpi_buffer_size",MaxBufferSize)
82!$OMP END MASTER
83!$OMP BARRIER
84   
85    IF (use_mpi_alloc .AND. using_mpi) THEN
86      CALL create_global_mpi_buffer
87    ELSE
88      CALL create_standard_mpi_buffer
89    ENDIF
90     
91!$OMP MASTER     
92     jj_nb_gather(:)=0
93     jj_nb_gather(0)=jjp1
94     
95     CALL create_distrib(jj_nb_gather,distrib_gather)
96!$OMP END MASTER
97!$OMP BARRIER
98
99  end subroutine init_mod_hallo
100
101  SUBROUTINE create_standard_mpi_buffer
102  IMPLICIT NONE
103   
104    ALLOCATE(Buffer(MaxBufferSize))
105   
106  END SUBROUTINE create_standard_mpi_buffer
107 
108  SUBROUTINE create_global_mpi_buffer
109  USE lmdz_mpi
110  IMPLICIT NONE
111    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
112    REAL :: MPI_Buffer
113    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS
114    INTEGER :: i,ierr
115
116!  Allocation du buffer MPI
117      Bs=8*MaxBufferSize
118!$OMP CRITICAL (MPI)
119      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
120!$OMP END CRITICAL (MPI)
121      DO i=1,MaxBufferSize
122        MPI_Buffer(i)=i
123      ENDDO
124     
125      CALL  Associate_buffer(MPI_Buffer)
126     
127  CONTAINS
128     
129     SUBROUTINE Associate_buffer(MPI_Buffer)
130     IMPLICIT NONE
131       REAL,DIMENSION(:),target :: MPI_Buffer 
132
133         Buffer=>MPI_Buffer
134 
135      END SUBROUTINE  Associate_buffer
136                                     
137  END SUBROUTINE create_global_mpi_buffer
138 
139     
140  subroutine allocate_buffer(Size,Index,Pos)
141  implicit none
142    integer :: Size
143    integer :: Index
144    integer :: Pos
145
146    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size 
147    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
148      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
149      CALL abort_gcm("mod_hallo","stopped",1)
150    endif
151   
152    if (Index_pos>=ListSize) then
153      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
154      CALL abort_gcm("mod_hallo","stopped",1)
155    endif
156     
157    Pos=Buffer_Pos(Index_Pos)
158    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
159    Index_Pos=Index_Pos+1
160    Index=Index_Pos
161   
162  end subroutine allocate_buffer
163     
164  subroutine deallocate_buffer(Index)
165  implicit none
166    integer :: Index
167   
168    Buffer_Pos(Index)=-1
169   
170    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
171      Index_Pos=Index_Pos-1
172    end do
173
174  end subroutine deallocate_buffer 
175 
176  subroutine SetTag(a_request,tag)
177  implicit none
178    type(request):: a_request
179    integer :: tag
180   
181    a_request%tag=tag
182  end subroutine SetTag
183 
184 
185  subroutine New_Hallo(Field,Stride,NbLevel,offset,size,Ptr_request)
186    integer :: Stride
187    integer :: NbLevel
188    integer :: size
189    integer :: offset
190    real, dimension(Stride,NbLevel),target :: Field
191    type(request_SR),pointer :: Ptr_request
192    type(Hallo),POINTER :: NewHallos(:),HalloSwitch(:), NewHallo
193   
194    Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
195    IF(Ptr_Request%NbRequestMax==0) THEN
196       Ptr_Request%NbRequestMax=10
197       ALLOCATE(Ptr_Request%Hallo(Ptr_Request%NbRequestMax))
198    ELSE IF ( Ptr_Request%NbRequest > Ptr_Request%NbRequestMax) THEN
199      Ptr_Request%NbRequestMax=INT(Ptr_Request%NbRequestMax*1.2)
200      ALLOCATE(NewHallos(Ptr_Request%NbRequestMax))
201      NewHallos(1:Ptr_Request%NbRequest-1)=Ptr_Request%hallo(1:Ptr_Request%NbRequest-1)
202      HalloSwitch=>Ptr_Request%hallo
203      Ptr_Request%hallo=>NewHallos
204      DEALLOCATE(HalloSwitch)
205    ENDIF
206   
207    NewHallo=>Ptr_Request%hallo(Ptr_Request%NbRequest)
208         
209    NewHallo%Field=>Field
210    NewHallo%Stride=Stride
211    NewHallo%NbLevel=NbLevel
212    NewHallo%size=size
213    NewHallo%offset=offset
214   
215  end subroutine New_Hallo
216 
217  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
218  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
219  implicit none
220
221   
222      INTEGER :: ij,ll,offset,size,target
223      REAL, dimension(ij,ll) :: Field
224      type(request),target :: a_request
225      type(request_SR),pointer :: Ptr_request
226
227      Ptr_Request=>a_request%RequestSend(target)
228
229      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
230     
231   end subroutine Register_SendField     
232     
233  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
234  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
235  implicit none
236
237   
238      INTEGER :: ij,ll,offset,size,target
239      REAL, dimension(ij,ll) :: Field
240      type(request),target :: a_request
241      type(request_SR),pointer :: Ptr_request
242
243      Ptr_Request=>a_request%RequestRecv(target)
244           
245      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
246
247     
248   end subroutine Register_RecvField     
249 
250  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
251    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
252    USE paramet_mod_h
253      implicit none
254
255   
256    INTEGER :: ij,ll
257    REAL, dimension(ij,ll) :: FieldS
258    REAL, dimension(ij,ll) :: FieldR
259    type(request) :: a_request
260    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
261    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
262   
263    integer ::i,jje,jjb
264   
265    jj_begin_New(0)=1
266    jj_End_New(0)=jj_Nb_New(0)
267    do i=1,MPI_Size-1
268      jj_begin_New(i)=jj_end_New(i-1)+1
269      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
270    enddo
271   
272    do i=0,MPI_Size-1
273      if (i /= MPI_Rank) then
274        jjb=max(jj_begin_new(i),jj_begin)
275        jje=min(jj_end_new(i),jj_end)
276       
277        if (ij==ip1jm .and. jje==jjp1) jje=jjm
278       
279        if (jje >= jjb) then
280          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
281        endif
282       
283        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
284        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
285       
286        if (ij==ip1jm .and. jje==jjp1) jje=jjm
287       
288        if (jje >= jjb) then
289          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
290        endif
291       
292      endif
293    enddo
294   
295  end subroutine Register_SwapField   
296 
297
298 
299  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
300    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
301    USE paramet_mod_h
302      implicit none
303   
304    INTEGER :: ij,ll,Up,Down
305    REAL, dimension(ij,ll) :: FieldS
306    REAL, dimension(ij,ll) :: FieldR
307    type(request) :: a_request
308    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
309    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
310   
311    integer ::i,jje,jjb
312   
313    jj_begin_New(0)=1
314    jj_End_New(0)=jj_Nb_New(0)
315    do i=1,MPI_Size-1
316      jj_begin_New(i)=jj_end_New(i-1)+1
317      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
318    enddo
319   
320    do i=0,MPI_Size-1
321      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
322      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
323    enddo
324   
325    do i=0,MPI_Size-1
326      if (i /= MPI_Rank) then
327        jjb=max(jj_begin_new(i),jj_begin)
328        jje=min(jj_end_new(i),jj_end)
329       
330        if (ij==ip1jm .and. jje==jjp1) jje=jjm
331       
332        if (jje >= jjb) then
333          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request)
334        endif
335       
336        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
337        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
338       
339        if (ij==ip1jm .and. jje==jjp1) jje=jjm
340       
341        if (jje >= jjb) then
342          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request)
343        endif
344       
345      endif
346    enddo
347   
348  end subroutine Register_SwapFieldHallo
349
350
351
352  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,up,down)
353  USE parallel_lmdz
354  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
355      IMPLICIT NONE
356   
357    TYPE(distrib),INTENT(IN)          :: new_dist
358    REAL, DIMENSION(current_dist%ijb_u:),INTENT(IN)     :: FieldS
359    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
360    INTEGER,OPTIONAL,INTENT(IN)       :: up
361    INTEGER,OPTIONAL,INTENT(IN)       :: down     
362    TYPE(request),INTENT(INOUT)         :: a_request
363
364    INTEGER                           :: halo_up
365    INTEGER                           :: halo_down
366   
367   
368    halo_up=0
369    halo_down=0
370    IF (PRESENT(up))   halo_up=up
371    IF (PRESENT(down)) halo_down=down
372
373    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
374       
375  END SUBROUTINE  Register_SwapField1d_u
376
377  SUBROUTINE Register_SwapField1d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
378  USE parallel_lmdz
379  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
380      IMPLICIT NONE
381   
382    TYPE(distrib),INTENT(IN)          :: new_dist
383    TYPE(distrib),INTENT(IN)          :: old_dist
384    REAL, DIMENSION(old_dist%ijb_u:),INTENT(IN)     :: FieldS
385    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
386    INTEGER,OPTIONAL,INTENT(IN)       :: up
387    INTEGER,OPTIONAL,INTENT(IN)       :: down     
388    TYPE(request),INTENT(INOUT)         :: a_request
389
390    INTEGER                           :: halo_up
391    INTEGER                           :: halo_down
392   
393   
394    halo_up=0
395    halo_down=0
396    IF (PRESENT(up))   halo_up=up
397    IF (PRESENT(down)) halo_down=down
398
399    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
400       
401  END SUBROUTINE  Register_SwapField1d_u_bis
402
403
404  SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,up,down)
405  USE parallel_lmdz
406  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
407    IMPLICIT NONE
408   
409    TYPE(distrib),INTENT(IN)          :: new_dist
410    REAL, DIMENSION(current_dist%ijb_u:,:),INTENT(IN)     :: FieldS
411    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
412    INTEGER,OPTIONAL,INTENT(IN)       :: up
413    INTEGER,OPTIONAL,INTENT(IN)       :: down     
414    TYPE(request),INTENT(INOUT)         :: a_request
415
416    INTEGER                           :: halo_up
417    INTEGER                           :: halo_down
418    INTEGER                           :: ll
419       
420   
421    halo_up=0
422    halo_down=0
423    IF (PRESENT(up))   halo_up=up
424    IF (PRESENT(down)) halo_down=down
425   
426    ll=size(FieldS,2)
427   
428    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
429   
430  END SUBROUTINE  Register_SwapField2d_u1d
431
432  SUBROUTINE Register_SwapField2d_u1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
433  USE parallel_lmdz
434  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
435    IMPLICIT NONE
436   
437    TYPE(distrib),INTENT(IN)          :: new_dist
438    TYPE(distrib),INTENT(IN) :: old_dist
439    REAL, DIMENSION(old_dist%ijb_u:,:),INTENT(IN)     :: FieldS
440    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
441    INTEGER,OPTIONAL,INTENT(IN)       :: up
442    INTEGER,OPTIONAL,INTENT(IN)       :: down     
443    TYPE(request),INTENT(INOUT)         :: a_request
444
445    INTEGER                           :: halo_up
446    INTEGER                           :: halo_down
447    INTEGER                           :: ll
448       
449   
450    halo_up=0
451    halo_down=0
452    IF (PRESENT(up))   halo_up=up
453    IF (PRESENT(down)) halo_down=down
454   
455    ll=size(FieldS,2)
456   
457    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
458   
459  END SUBROUTINE  Register_SwapField2d_u1d_bis
460   
461
462  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,up,down)
463  USE parallel_lmdz
464  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
465      IMPLICIT NONE
466   
467    TYPE(distrib),INTENT(IN)          :: new_dist
468    REAL, DIMENSION(current_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
469    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
470    INTEGER,OPTIONAL,INTENT(IN)       :: up
471    INTEGER,OPTIONAL,INTENT(IN)       :: down     
472    TYPE(request),INTENT(INOUT)         :: a_request
473
474    INTEGER                           :: halo_up
475    INTEGER                           :: halo_down
476    INTEGER                           :: ll
477       
478   
479    halo_up=0
480    halo_down=0
481    IF (PRESENT(up))   halo_up=up
482    IF (PRESENT(down)) halo_down=down
483   
484    ll=size(FieldS,2)*size(FieldS,3)
485   
486    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
487   
488  END SUBROUTINE  Register_SwapField3d_u
489
490  SUBROUTINE Register_SwapField3d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
491  USE parallel_lmdz
492  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
493      IMPLICIT NONE
494   
495    TYPE(distrib),INTENT(IN)          :: new_dist
496    TYPE(distrib),INTENT(IN) :: old_dist
497    REAL, DIMENSION(old_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
498    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
499    INTEGER,OPTIONAL,INTENT(IN)       :: up
500    INTEGER,OPTIONAL,INTENT(IN)       :: down     
501    TYPE(request),INTENT(INOUT)         :: a_request
502
503    INTEGER                           :: halo_up
504    INTEGER                           :: halo_down
505    INTEGER                           :: ll
506       
507   
508    halo_up=0
509    halo_down=0
510    IF (PRESENT(up))   halo_up=up
511    IF (PRESENT(down)) halo_down=down
512   
513    ll=size(FieldS,2)*size(FieldS,3)
514   
515    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
516   
517  END SUBROUTINE  Register_SwapField3d_u_bis
518 
519
520
521 SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
522  USE parallel_lmdz
523  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
524      IMPLICIT NONE
525
526    TYPE(distrib),INTENT(IN)          :: new_dist !LF
527    REAL, DIMENSION(current_dist%jjb_u:,:),INTENT(IN)     :: FieldS
528    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
529    INTEGER,OPTIONAL,INTENT(IN)       :: up
530    INTEGER,OPTIONAL,INTENT(IN)       :: down     
531    TYPE(request),INTENT(INOUT)         :: a_request
532
533    INTEGER                           :: halo_up
534    INTEGER                           :: halo_down
535   
536   
537    halo_up=0
538    halo_down=0
539    IF (PRESENT(up))   halo_up=up
540    IF (PRESENT(down)) halo_down=down
541
542    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
543       
544  END SUBROUTINE  Register_SwapField1d_u2d
545
546 SUBROUTINE Register_SwapField1d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
547  USE parallel_lmdz
548  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
549      IMPLICIT NONE
550
551    TYPE(distrib),INTENT(IN)          :: new_dist !LF
552    TYPE(distrib),INTENT(IN)          :: old_dist
553    REAL, DIMENSION(old_dist%jjb_u:,:),INTENT(IN)     :: FieldS
554    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
555    INTEGER,OPTIONAL,INTENT(IN)       :: up
556    INTEGER,OPTIONAL,INTENT(IN)       :: down     
557    TYPE(request),INTENT(INOUT)         :: a_request
558
559    INTEGER                           :: halo_up
560    INTEGER                           :: halo_down
561   
562   
563    halo_up=0
564    halo_down=0
565    IF (PRESENT(up))   halo_up=up
566    IF (PRESENT(down)) halo_down=down
567
568    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
569       
570  END SUBROUTINE  Register_SwapField1d_u2d_bis
571
572
573  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
574  USE parallel_lmdz
575  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
576      IMPLICIT NONE
577   
578    TYPE(distrib),INTENT(IN)          :: new_dist
579    REAL, DIMENSION(current_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
580    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
581    INTEGER,OPTIONAL,INTENT(IN)       :: up
582    INTEGER,OPTIONAL,INTENT(IN)       :: down     
583    TYPE(request),INTENT(INOUT)         :: a_request
584
585    INTEGER                           :: halo_up
586    INTEGER                           :: halo_down
587    INTEGER                           :: ll
588       
589   
590    halo_up=0
591    halo_down=0
592    IF (PRESENT(up))   halo_up=up
593    IF (PRESENT(down)) halo_down=down
594   
595    ll=size(FieldS,3)
596   
597    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
598   
599  END SUBROUTINE  Register_SwapField2d_u2d
600
601  SUBROUTINE Register_SwapField2d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
602  USE parallel_lmdz
603  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
604      IMPLICIT NONE
605   
606    TYPE(distrib),INTENT(IN)          :: new_dist
607    TYPE(distrib),INTENT(IN) :: old_dist
608    REAL, DIMENSION(old_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
609    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
610    INTEGER,OPTIONAL,INTENT(IN)       :: up
611    INTEGER,OPTIONAL,INTENT(IN)       :: down     
612    TYPE(request),INTENT(INOUT)         :: a_request
613
614    INTEGER                           :: halo_up
615    INTEGER                           :: halo_down
616    INTEGER                           :: ll
617       
618   
619    halo_up=0
620    halo_down=0
621    IF (PRESENT(up))   halo_up=up
622    IF (PRESENT(down)) halo_down=down
623   
624    ll=size(FieldS,3)
625   
626    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
627   
628  END SUBROUTINE  Register_SwapField2d_u2d_bis
629   
630
631  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
632  USE parallel_lmdz
633  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
634      IMPLICIT NONE
635   
636    TYPE(distrib),INTENT(IN)          :: new_dist
637    REAL, DIMENSION(current_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
638    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
639    INTEGER,OPTIONAL,INTENT(IN)       :: up
640    INTEGER,OPTIONAL,INTENT(IN)       :: down     
641    TYPE(request),INTENT(INOUT)         :: a_request
642
643    INTEGER                           :: halo_up
644    INTEGER                           :: halo_down
645    INTEGER                           :: ll
646       
647   
648    halo_up=0
649    halo_down=0
650    IF (PRESENT(up))   halo_up=up
651    IF (PRESENT(down)) halo_down=down
652   
653    ll=size(FieldS,3)*size(FieldS,4)
654   
655    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
656   
657  END SUBROUTINE  Register_SwapField3d_u2d
658
659  SUBROUTINE Register_SwapField3d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
660  USE parallel_lmdz
661  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
662      IMPLICIT NONE
663   
664    TYPE(distrib),INTENT(IN)          :: new_dist
665    TYPE(distrib),INTENT(IN) :: old_dist
666    REAL, DIMENSION(old_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
667    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
668    INTEGER,OPTIONAL,INTENT(IN)       :: up
669    INTEGER,OPTIONAL,INTENT(IN)       :: down     
670    TYPE(request),INTENT(INOUT)         :: a_request
671
672    INTEGER                           :: halo_up
673    INTEGER                           :: halo_down
674    INTEGER                           :: ll
675       
676   
677    halo_up=0
678    halo_down=0
679    IF (PRESENT(up))   halo_up=up
680    IF (PRESENT(down)) halo_down=down
681   
682    ll=size(FieldS,3)*size(FieldS,4)
683   
684    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
685   
686  END SUBROUTINE  Register_SwapField3d_u2d_bis
687
688
689
690
691
692
693
694  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,up,down)
695  USE parallel_lmdz
696  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
697      IMPLICIT NONE
698   
699    TYPE(distrib),INTENT(IN)          :: new_dist
700    REAL, DIMENSION(current_dist%ijb_v:),INTENT(IN)     :: FieldS
701    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
702    INTEGER,OPTIONAL,INTENT(IN)       :: up
703    INTEGER,OPTIONAL,INTENT(IN)       :: down     
704    TYPE(request),INTENT(INOUT)         :: a_request
705
706    INTEGER                           :: halo_up
707    INTEGER                           :: halo_down
708   
709   
710    halo_up=0
711    halo_down=0
712    IF (PRESENT(up))   halo_up=up
713    IF (PRESENT(down)) halo_down=down
714
715    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
716       
717  END SUBROUTINE  Register_SwapField1d_v
718
719  SUBROUTINE Register_SwapField1d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
720  USE parallel_lmdz
721  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
722      IMPLICIT NONE
723   
724    TYPE(distrib),INTENT(IN)          :: new_dist
725    TYPE(distrib),INTENT(IN) :: old_dist
726    REAL, DIMENSION(old_dist%ijb_v:),INTENT(IN)     :: FieldS
727    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
728    INTEGER,OPTIONAL,INTENT(IN)       :: up
729    INTEGER,OPTIONAL,INTENT(IN)       :: down     
730    TYPE(request),INTENT(INOUT)         :: a_request
731
732    INTEGER                           :: halo_up
733    INTEGER                           :: halo_down
734   
735   
736    halo_up=0
737    halo_down=0
738    IF (PRESENT(up))   halo_up=up
739    IF (PRESENT(down)) halo_down=down
740
741    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
742       
743  END SUBROUTINE  Register_SwapField1d_v_bis
744
745
746  SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,up,down)
747  USE parallel_lmdz
748  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
749      IMPLICIT NONE
750   
751    TYPE(distrib),INTENT(IN)          :: new_dist
752    REAL, DIMENSION(current_dist%ijb_v:,:),INTENT(IN)     :: FieldS
753    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
754    INTEGER,OPTIONAL,INTENT(IN)       :: up
755    INTEGER,OPTIONAL,INTENT(IN)       :: down     
756    TYPE(request),INTENT(INOUT)         :: a_request
757
758    INTEGER                           :: halo_up
759    INTEGER                           :: halo_down
760    INTEGER                           :: ll
761       
762   
763    halo_up=0
764    halo_down=0
765    IF (PRESENT(up))   halo_up=up
766    IF (PRESENT(down)) halo_down=down
767   
768    ll=size(FieldS,2)
769   
770    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
771   
772  END SUBROUTINE  Register_SwapField2d_v1d
773 
774  SUBROUTINE Register_SwapField2d_v1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
775  USE parallel_lmdz
776  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
777      IMPLICIT NONE
778   
779    TYPE(distrib),INTENT(IN)          :: new_dist
780    TYPE(distrib),INTENT(IN)          :: old_dist
781    REAL, DIMENSION(old_dist%ijb_v:,:),INTENT(IN)     :: FieldS
782    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
783    INTEGER,OPTIONAL,INTENT(IN)       :: up
784    INTEGER,OPTIONAL,INTENT(IN)       :: down     
785    TYPE(request),INTENT(INOUT)         :: a_request
786
787    INTEGER                           :: halo_up
788    INTEGER                           :: halo_down
789    INTEGER                           :: ll
790       
791   
792    halo_up=0
793    halo_down=0
794    IF (PRESENT(up))   halo_up=up
795    IF (PRESENT(down)) halo_down=down
796   
797    ll=size(FieldS,2)
798   
799    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
800   
801  END SUBROUTINE  Register_SwapField2d_v1d_bis
802 
803   
804
805  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,up,down)
806  USE parallel_lmdz
807  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
808      IMPLICIT NONE
809   
810    TYPE(distrib),INTENT(IN)          :: new_dist
811    REAL, DIMENSION(current_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
812    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
813    INTEGER,OPTIONAL,INTENT(IN)       :: up
814    INTEGER,OPTIONAL,INTENT(IN)       :: down     
815    TYPE(request),INTENT(INOUT)         :: a_request
816
817    INTEGER                           :: halo_up
818    INTEGER                           :: halo_down
819    INTEGER                           :: ll
820       
821   
822    halo_up=0
823    halo_down=0
824    IF (PRESENT(up))   halo_up=up
825    IF (PRESENT(down)) halo_down=down
826   
827    ll=size(FieldS,2)*size(FieldS,3)
828   
829    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
830   
831  END SUBROUTINE  Register_SwapField3d_v
832
833  SUBROUTINE Register_SwapField3d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
834  USE parallel_lmdz
835  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
836      IMPLICIT NONE
837   
838    TYPE(distrib),INTENT(IN)          :: new_dist
839    TYPE(distrib),INTENT(IN) :: old_dist
840    REAL, DIMENSION(old_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
841    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
842    INTEGER,OPTIONAL,INTENT(IN)       :: up
843    INTEGER,OPTIONAL,INTENT(IN)       :: down     
844    TYPE(request),INTENT(INOUT)         :: a_request
845
846    INTEGER                           :: halo_up
847    INTEGER                           :: halo_down
848    INTEGER                           :: ll
849       
850   
851    halo_up=0
852    halo_down=0
853    IF (PRESENT(up))   halo_up=up
854    IF (PRESENT(down)) halo_down=down
855   
856    ll=size(FieldS,2)*size(FieldS,3)
857   
858    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
859   
860  END SUBROUTINE  Register_SwapField3d_v_bis
861
862
863
864
865  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
866  USE parallel_lmdz
867  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
868      IMPLICIT NONE
869   
870    TYPE(distrib),INTENT(IN)          :: new_dist !LF
871    REAL, DIMENSION(current_dist%jjb_v:,:),INTENT(IN)     :: FieldS
872    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
873    INTEGER,OPTIONAL,INTENT(IN)       :: up
874    INTEGER,OPTIONAL,INTENT(IN)       :: down     
875    TYPE(request),INTENT(INOUT)         :: a_request
876
877    INTEGER                           :: halo_up
878    INTEGER                           :: halo_down
879   
880   
881    halo_up=0
882    halo_down=0
883    IF (PRESENT(up))   halo_up=up
884    IF (PRESENT(down)) halo_down=down
885
886    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
887       
888  END SUBROUTINE  Register_SwapField1d_v2d
889
890  SUBROUTINE Register_SwapField1d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
891  USE parallel_lmdz
892  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
893      IMPLICIT NONE
894   
895    TYPE(distrib),INTENT(IN)          :: new_dist !LF
896    TYPE(distrib),INTENT(IN) :: old_dist
897    REAL, DIMENSION(old_dist%jjb_v:,:),INTENT(IN)     :: FieldS
898    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
899    INTEGER,OPTIONAL,INTENT(IN)       :: up
900    INTEGER,OPTIONAL,INTENT(IN)       :: down     
901    TYPE(request),INTENT(INOUT)         :: a_request
902
903    INTEGER                           :: halo_up
904    INTEGER                           :: halo_down
905   
906   
907    halo_up=0
908    halo_down=0
909    IF (PRESENT(up))   halo_up=up
910    IF (PRESENT(down)) halo_down=down
911
912    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
913       
914  END SUBROUTINE  Register_SwapField1d_v2d_bis
915
916
917  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
918  USE parallel_lmdz
919  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
920      IMPLICIT NONE
921   
922    TYPE(distrib),INTENT(IN)          :: new_dist
923    REAL, DIMENSION(current_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
924    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
925    INTEGER,OPTIONAL,INTENT(IN)       :: up
926    INTEGER,OPTIONAL,INTENT(IN)       :: down     
927    TYPE(request),INTENT(INOUT)         :: a_request
928
929    INTEGER                           :: halo_up
930    INTEGER                           :: halo_down
931    INTEGER                           :: ll
932       
933   
934    halo_up=0
935    halo_down=0
936    IF (PRESENT(up))   halo_up=up
937    IF (PRESENT(down)) halo_down=down
938   
939    ll=size(FieldS,3)
940   
941    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
942   
943  END SUBROUTINE  Register_SwapField2d_v2d
944   
945  SUBROUTINE Register_SwapField2d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
946  USE parallel_lmdz
947  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
948      IMPLICIT NONE
949   
950    TYPE(distrib),INTENT(IN)          :: new_dist
951    TYPE(distrib),INTENT(IN) :: old_dist
952    REAL, DIMENSION(old_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
953    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
954    INTEGER,OPTIONAL,INTENT(IN)       :: up
955    INTEGER,OPTIONAL,INTENT(IN)       :: down     
956    TYPE(request),INTENT(INOUT)         :: a_request
957
958    INTEGER                           :: halo_up
959    INTEGER                           :: halo_down
960    INTEGER                           :: ll
961       
962   
963    halo_up=0
964    halo_down=0
965    IF (PRESENT(up))   halo_up=up
966    IF (PRESENT(down)) halo_down=down
967   
968    ll=size(FieldS,3)
969   
970    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
971   
972  END SUBROUTINE  Register_SwapField2d_v2d_bis
973   
974
975  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
976  USE parallel_lmdz
977  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
978      IMPLICIT NONE
979   
980    TYPE(distrib),INTENT(IN)          :: new_dist
981    REAL, DIMENSION(current_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
982    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
983    INTEGER,OPTIONAL,INTENT(IN)       :: up
984    INTEGER,OPTIONAL,INTENT(IN)       :: down     
985    TYPE(request),INTENT(INOUT)         :: a_request
986
987    INTEGER                           :: halo_up
988    INTEGER                           :: halo_down
989    INTEGER                           :: ll
990       
991   
992    halo_up=0
993    halo_down=0
994    IF (PRESENT(up))   halo_up=up
995    IF (PRESENT(down)) halo_down=down
996   
997    ll=size(FieldS,3)*size(FieldS,4)
998   
999    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
1000   
1001  END SUBROUTINE  Register_SwapField3d_v2d
1002 
1003  SUBROUTINE Register_SwapField3d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
1004  USE parallel_lmdz
1005  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1006      IMPLICIT NONE
1007   
1008    TYPE(distrib),INTENT(IN)          :: new_dist
1009    TYPE(distrib),INTENT(IN) :: old_dist
1010    REAL, DIMENSION(old_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
1011    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
1012    INTEGER,OPTIONAL,INTENT(IN)       :: up
1013    INTEGER,OPTIONAL,INTENT(IN)       :: down     
1014    TYPE(request),INTENT(INOUT)         :: a_request
1015
1016    INTEGER                           :: halo_up
1017    INTEGER                           :: halo_down
1018    INTEGER                           :: ll
1019       
1020   
1021    halo_up=0
1022    halo_down=0
1023    IF (PRESENT(up))   halo_up=up
1024    IF (PRESENT(down)) halo_down=down
1025   
1026    ll=size(FieldS,3)*size(FieldS,4)
1027   
1028    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
1029   
1030  END SUBROUTINE  Register_SwapField3d_v2d_bis
1031 
1032 
1033
1034  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
1035    USE parallel_lmdz
1036    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1037    USE paramet_mod_h
1038      IMPLICIT NONE
1039   
1040    INTEGER :: ll,Up,Down
1041    TYPE(distrib)  :: old_dist
1042    TYPE(distrib)  :: new_dist
1043    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
1044    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
1045    TYPE(request) :: a_request
1046    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
1047    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1048   
1049    INTEGER ::i,l,jje,jjb,ijb,ije
1050   
1051    DO i=0,MPI_Size-1
1052      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
1053      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
1054    ENDDO
1055   
1056    DO i=0,MPI_Size-1
1057      IF (i /= MPI_Rank) THEN
1058        jjb=max(jj_begin_new(i),old_dist%jj_begin)
1059        jje=min(jj_end_new(i),old_dist%jj_end)
1060       
1061        IF (jje >= jjb) THEN
1062          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request)
1063        ENDIF
1064       
1065        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
1066        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
1067       
1068        IF (jje >= jjb) THEN
1069          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request)
1070        ENDIF
1071      ELSE
1072        jjb=max(jj_begin_new(i),old_dist%jj_begin)
1073        jje=min(jj_end_new(i),old_dist%jj_end)
1074        ijb=(jjb-1)*iip1+1
1075        ije=jje*iip1
1076!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1077        DO l=1,ll
1078          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)             
1079        ENDDO
1080!$OMP END DO NOWAIT
1081      ENDIF
1082    ENDDO
1083   
1084  END SUBROUTINE Register_SwapField_gen_u
1085
1086
1087
1088  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
1089  USE parallel_lmdz
1090  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1091  USE paramet_mod_h
1092    IMPLICIT NONE
1093   
1094    INTEGER :: ll,Up,Down
1095    TYPE(distrib)  :: old_dist
1096    TYPE(distrib)  :: new_dist
1097    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
1098    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
1099    TYPE(request) :: a_request
1100    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
1101    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1102   
1103    INTEGER ::i,l,jje,jjb,ijb,ije
1104   
1105    DO i=0,MPI_Size-1
1106      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
1107      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
1108    ENDDO
1109   
1110    DO i=0,MPI_Size-1
1111      IF (i /= MPI_Rank) THEN
1112        jjb=max(jj_begin_new(i),old_dist%jj_begin)
1113        jje=min(jj_end_new(i),old_dist%jj_end)
1114
1115        IF (jje==jjp1) jje=jjm       
1116
1117        IF (jje >= jjb) THEN
1118          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request)
1119        ENDIF
1120       
1121        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
1122        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
1123
1124        IF (jje==jjp1) jje=jjm
1125       
1126        IF (jje >= jjb) THEN
1127          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request)
1128        ENDIF
1129      ELSE
1130        jjb=max(jj_begin_new(i),old_dist%jj_begin)
1131        jje=min(jj_end_new(i),old_dist%jj_end)
1132        IF (jje==jjp1) jje=jjm
1133        ijb=(jjb-1)*iip1+1
1134        ije=jje*iip1
1135!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1136        DO l=1,ll
1137          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
1138        ENDDO             
1139!$OMP END DO NOWAIT
1140      ENDIF
1141    ENDDO
1142   
1143  END SUBROUTINE Register_SwapField_gen_v
1144
1145
1146 
1147
1148 
1149  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
1150  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1151  USE lmdz_mpi
1152      implicit none
1153
1154      INTEGER :: ij,ll
1155      REAL, dimension(ij,ll) :: Field
1156      INTEGER :: Sup,Sdown,rup,rdown
1157      type(request) :: a_request
1158      type(Hallo),pointer :: PtrHallo
1159      LOGICAL :: SendUp,SendDown
1160      LOGICAL :: RecvUp,RecvDown
1161   
1162 
1163      SendUp=.TRUE.
1164      SendDown=.TRUE.
1165      RecvUp=.TRUE.
1166      RecvDown=.TRUE.
1167       
1168      IF (pole_nord) THEN
1169        SendUp=.FALSE.
1170        RecvUp=.FALSE.
1171      ENDIF
1172 
1173      IF (pole_sud) THEN
1174        SendDown=.FALSE.
1175        RecvDown=.FALSE.
1176      ENDIF
1177     
1178      if (Sup.eq.0) then
1179        SendUp=.FALSE.
1180       endif
1181     
1182      if (Sdown.eq.0) then
1183        SendDown=.FALSE.
1184      endif
1185
1186      if (Rup.eq.0) then
1187        RecvUp=.FALSE.
1188      endif
1189     
1190      if (Rdown.eq.0) then
1191        RecvDown=.FALSE.
1192      endif
1193     
1194      IF (SendUp) THEN
1195        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
1196      ENDIF
1197 
1198      IF (SendDown) THEN
1199        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
1200      ENDIF
1201   
1202 
1203      IF (RecvUp) THEN
1204        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
1205      ENDIF
1206 
1207      IF (RecvDown) THEN
1208        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
1209      ENDIF
1210 
1211    end subroutine Register_Hallo
1212
1213
1214  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
1215  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1216  USE lmdz_mpi
1217      implicit none
1218      INTEGER :: ll
1219      REAL, dimension(ijb_u:ije_u,ll) :: Field
1220      INTEGER :: Sup,Sdown,rup,rdown
1221      type(request) :: a_request
1222      type(Hallo),pointer :: PtrHallo
1223      LOGICAL :: SendUp,SendDown
1224      LOGICAL :: RecvUp,RecvDown
1225   
1226 
1227      SendUp=.TRUE.
1228      SendDown=.TRUE.
1229      RecvUp=.TRUE.
1230      RecvDown=.TRUE.
1231       
1232      IF (pole_nord) THEN
1233        SendUp=.FALSE.
1234        RecvUp=.FALSE.
1235      ENDIF
1236 
1237      IF (pole_sud) THEN
1238        SendDown=.FALSE.
1239        RecvDown=.FALSE.
1240      ENDIF
1241     
1242      if (Sup.eq.0) then
1243        SendUp=.FALSE.
1244       endif
1245     
1246      if (Sdown.eq.0) then
1247        SendDown=.FALSE.
1248      endif
1249
1250      if (Rup.eq.0) then
1251        RecvUp=.FALSE.
1252      endif
1253     
1254      if (Rdown.eq.0) then
1255        RecvDown=.FALSE.
1256      endif
1257     
1258      IF (SendUp) THEN
1259        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
1260      ENDIF
1261 
1262      IF (SendDown) THEN
1263        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
1264      ENDIF
1265   
1266 
1267      IF (RecvUp) THEN
1268        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
1269      ENDIF
1270 
1271      IF (RecvDown) THEN
1272        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
1273      ENDIF
1274 
1275    end subroutine Register_Hallo_u
1276
1277  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
1278  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1279  USE lmdz_mpi
1280      implicit none
1281      INTEGER :: ll
1282      REAL, dimension(ijb_v:ije_v,ll) :: Field
1283      INTEGER :: Sup,Sdown,rup,rdown
1284      type(request) :: a_request
1285      type(Hallo),pointer :: PtrHallo
1286      LOGICAL :: SendUp,SendDown
1287      LOGICAL :: RecvUp,RecvDown
1288   
1289 
1290      SendUp=.TRUE.
1291      SendDown=.TRUE.
1292      RecvUp=.TRUE.
1293      RecvDown=.TRUE.
1294       
1295      IF (pole_nord) THEN
1296        SendUp=.FALSE.
1297        RecvUp=.FALSE.
1298      ENDIF
1299 
1300      IF (pole_sud) THEN
1301        SendDown=.FALSE.
1302        RecvDown=.FALSE.
1303      ENDIF
1304     
1305      if (Sup.eq.0) then
1306        SendUp=.FALSE.
1307       endif
1308     
1309      if (Sdown.eq.0) then
1310        SendDown=.FALSE.
1311      endif
1312
1313      if (Rup.eq.0) then
1314        RecvUp=.FALSE.
1315      endif
1316     
1317      if (Rdown.eq.0) then
1318        RecvDown=.FALSE.
1319      endif
1320     
1321      IF (SendUp) THEN
1322        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
1323      ENDIF
1324 
1325      IF (SendDown) THEN
1326        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
1327      ENDIF
1328   
1329 
1330      IF (RecvUp) THEN
1331        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
1332      ENDIF
1333 
1334      IF (RecvDown) THEN
1335        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
1336      ENDIF
1337 
1338    end subroutine Register_Hallo_v
1339   
1340    subroutine SendRequest(a_Request)
1341    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1342    USE paramet_mod_h
1343    USE lmdz_mpi
1344      implicit none
1345
1346      type(request),target :: a_request
1347      type(request_SR),pointer :: Req
1348      type(Hallo),pointer :: PtrHallo
1349      integer :: SizeBuffer
1350      integer :: i,rank,l,ij,Pos,ierr
1351      integer :: offset
1352      real,dimension(:,:),pointer :: Field
1353      integer :: Nb
1354       
1355      do rank=0,MPI_SIZE-1
1356     
1357        Req=>a_Request%RequestSend(rank)
1358       
1359        SizeBuffer=0
1360        do i=1,Req%NbRequest
1361          PtrHallo=>Req%Hallo(i)
1362!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1363          DO l=1,PtrHallo%NbLevel
1364            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
1365          ENDDO
1366!$OMP ENDDO NOWAIT         
1367        enddo
1368     
1369         Req%BufferSize=SizeBuffer
1370         if (Req%NbRequest>0) then
1371       
1372          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
1373
1374          Pos=Req%Pos
1375          do i=1,Req%NbRequest
1376            PtrHallo=>Req%Hallo(i)
1377            offset=(PtrHallo%offset-1)*iip1+1
1378            Nb=iip1*PtrHallo%size-1
1379            Field=>PtrHallo%Field
1380
1381!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1382            do l=1,PtrHallo%NbLevel
1383!cdir NODEP
1384              do ij=0,Nb
1385                Buffer(Pos+ij)=Field(Offset+ij,l)
1386              enddo
1387             
1388              Pos=Pos+Nb+1
1389            enddo
1390!$OMP END DO NOWAIT           
1391          enddo
1392   
1393         if (SizeBuffer>0) then
1394!$OMP CRITICAL (MPI)
1395         
1396         call MPI_ISEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
1397                         COMM_LMDZ,Req%MSG_Request,ierr)
1398         IF (.NOT.using_mpi) THEN
1399           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
1400           CALL abort_gcm("mod_hallo","stopped",1)
1401         ENDIF
1402!         PRINT *,"-------------------------------------------------------------------"
1403!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
1404!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
1405!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
1406!         PRINT *,"-------------------------------------------------------------------"
1407!$OMP END CRITICAL (MPI)
1408        endif
1409       endif
1410    enddo
1411   
1412           
1413      do rank=0,MPI_SIZE-1
1414         
1415          Req=>a_Request%RequestRecv(rank)
1416          SizeBuffer=0
1417         
1418          do i=1,Req%NbRequest
1419            PtrHallo=>Req%Hallo(i)
1420
1421!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1422            DO l=1,PtrHallo%NbLevel
1423              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
1424            ENDDO
1425!$OMP ENDDO NOWAIT         
1426          enddo
1427         
1428          Req%BufferSize=SizeBuffer
1429         
1430          if (Req%NbRequest>0) then
1431          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
1432   
1433          if (SizeBuffer>0) then
1434
1435!$OMP CRITICAL (MPI)
1436
1437             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
1438                           COMM_LMDZ,Req%MSG_Request,ierr)
1439
1440             IF (.NOT.using_mpi) THEN
1441               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
1442               CALL abort_gcm("mod_hallo","stopped",1)
1443             ENDIF
1444
1445!         PRINT *,"-------------------------------------------------------------------"
1446!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
1447!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
1448!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
1449!         PRINT *,"-------------------------------------------------------------------"
1450
1451!$OMP END CRITICAL (MPI)
1452          endif
1453        endif
1454     
1455      enddo
1456                       
1457   end subroutine SendRequest
1458   
1459   subroutine WaitRequest(a_Request)
1460   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1461   USE paramet_mod_h
1462   USE lmdz_mpi
1463   implicit none
1464     
1465      type(request),target :: a_request
1466      type(request_SR),pointer :: Req
1467      type(Hallo),pointer :: PtrHallo
1468      integer, dimension(2*mpi_size) :: TabRequest
1469      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
1470      integer :: NbRequest
1471      integer :: i,rank,pos,ij,l,ierr
1472      integer :: offset
1473      integer :: Nb
1474     
1475     
1476      NbRequest=0
1477      do rank=0,MPI_SIZE-1
1478        Req=>a_request%RequestSend(rank)
1479        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
1480          NbRequest=NbRequest+1
1481          TabRequest(NbRequest)=Req%MSG_Request
1482        endif
1483      enddo
1484     
1485      do rank=0,MPI_SIZE-1
1486        Req=>a_request%RequestRecv(rank)
1487        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
1488          NbRequest=NbRequest+1
1489          TabRequest(NbRequest)=Req%MSG_Request
1490        endif
1491      enddo
1492     
1493      if (NbRequest>0) then
1494!$OMP CRITICAL (MPI)
1495!        PRINT *,"-------------------------------------------------------------------"
1496!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1497!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1498        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1499!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1500!        PRINT *,"-------------------------------------------------------------------"
1501!$OMP END CRITICAL (MPI)
1502      endif
1503      do rank=0,MPI_Size-1
1504        Req=>a_request%RequestRecv(rank)
1505        if (Req%NbRequest>0) then
1506          Pos=Req%Pos
1507          do i=1,Req%NbRequest
1508            PtrHallo=>Req%Hallo(i)
1509            offset=(PtrHallo%offset-1)*iip1+1
1510            Nb=iip1*PtrHallo%size-1
1511
1512!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1513            do l=1,PtrHallo%NbLevel
1514!cdir NODEP
1515              do ij=0,Nb
1516                PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
1517              enddo
1518
1519              Pos=Pos+Nb+1
1520            enddo
1521!$OMP ENDDO NOWAIT         
1522          enddo
1523        endif
1524      enddo
1525     
1526      do rank=0,MPI_SIZE-1
1527        Req=>a_request%RequestSend(rank)
1528        if (Req%NbRequest>0) then
1529          call deallocate_buffer(Req%Index)
1530          Req%NbRequest=0
1531        endif
1532      enddo
1533             
1534      do rank=0,MPI_SIZE-1
1535        Req=>a_request%RequestRecv(rank)
1536        if (Req%NbRequest>0) then
1537          call deallocate_buffer(Req%Index)
1538          Req%NbRequest=0
1539        endif
1540      enddo
1541     
1542      a_request%tag=1
1543    end subroutine WaitRequest
1544     
1545   subroutine WaitSendRequest(a_Request)
1546   USE lmdz_mpi
1547   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1548   implicit none
1549   
1550      type(request),target :: a_request
1551      type(request_SR),pointer :: Req
1552      type(Hallo),pointer :: PtrHallo
1553      integer, dimension(mpi_size) :: TabRequest
1554      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
1555      integer :: NbRequest
1556      integer :: i,rank,pos,ij,l,ierr
1557      integer :: offset
1558     
1559     
1560      NbRequest=0
1561      do rank=0,MPI_SIZE-1
1562        Req=>a_request%RequestSend(rank)
1563        if (Req%NbRequest>0) then
1564          NbRequest=NbRequest+1
1565          TabRequest(NbRequest)=Req%MSG_Request
1566        endif
1567      enddo
1568     
1569
1570      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN
1571!$OMP CRITICAL (MPI)     
1572!        PRINT *,"-------------------------------------------------------------------"
1573!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1574!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1575         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1576!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1577!        PRINT *,"-------------------------------------------------------------------"
1578
1579!$OMP END CRITICAL (MPI)
1580      endif     
1581     
1582      do rank=0,MPI_SIZE-1
1583        Req=>a_request%RequestSend(rank)
1584        if (Req%NbRequest>0) then
1585          call deallocate_buffer(Req%Index)
1586          Req%NbRequest=0
1587        endif
1588      enddo
1589             
1590      a_request%tag=1
1591    end subroutine WaitSendRequest
1592   
1593   subroutine WaitRecvRequest(a_Request)
1594   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1595   USE paramet_mod_h
1596   USE lmdz_mpi
1597   implicit none
1598      type(request),target :: a_request
1599      type(request_SR),pointer :: Req
1600      type(Hallo),pointer :: PtrHallo
1601      integer, dimension(mpi_size) :: TabRequest
1602      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
1603      integer :: NbRequest
1604      integer :: i,rank,pos,ij,l,ierr
1605      integer :: offset,Nb
1606     
1607     
1608      NbRequest=0
1609     
1610      do rank=0,MPI_SIZE-1
1611        Req=>a_request%RequestRecv(rank)
1612        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
1613          NbRequest=NbRequest+1
1614          TabRequest(NbRequest)=Req%MSG_Request
1615        endif
1616      enddo
1617     
1618     
1619      if (NbRequest>0) then
1620!$OMP CRITICAL (MPI)     
1621!        PRINT *,"-------------------------------------------------------------------"
1622!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
1623!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
1624         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
1625!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
1626!        PRINT *,"-------------------------------------------------------------------"
1627!$OMP END CRITICAL (MPI)     
1628      endif
1629     
1630      do rank=0,MPI_Size-1
1631        Req=>a_request%RequestRecv(rank)
1632        if (Req%NbRequest>0) then
1633          Pos=Req%Pos
1634          do i=1,Req%NbRequest
1635            PtrHallo=>Req%Hallo(i)
1636            offset=(PtrHallo%offset-1)*iip1+1
1637            Nb=iip1*PtrHallo%size-1
1638!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
1639            do l=1,PtrHallo%NbLevel
1640!cdir NODEP
1641              do ij=0,Nb
1642                PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
1643              enddo
1644                 Pos=Pos+Nb+1
1645            enddo
1646!$OMP END DO NOWAIT
1647          enddo
1648        endif
1649      enddo
1650     
1651           
1652      do rank=0,MPI_SIZE-1
1653        Req=>a_request%RequestRecv(rank)
1654        if (Req%NbRequest>0) then
1655          call deallocate_buffer(Req%Index)
1656          Req%NbRequest=0
1657        endif
1658      enddo
1659     
1660      a_request%tag=1
1661    end subroutine WaitRecvRequest
1662   
1663   
1664   
1665    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
1666    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1667    USE paramet_mod_h
1668      implicit none
1669   
1670    INTEGER :: ij,ll,l
1671    REAL, dimension(ij,ll) :: FieldS
1672    REAL, dimension(ij,ll) :: FieldR
1673    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
1674    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1675   
1676    integer ::i,jje,jjb,ijb,ije
1677   
1678    jj_begin_New(0)=1
1679    jj_End_New(0)=jj_Nb_New(0)
1680    do i=1,MPI_Size-1
1681      jj_begin_New(i)=jj_end_New(i-1)+1
1682      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
1683    enddo
1684   
1685    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
1686    jje=min(jj_end,jj_end_new(MPI_Rank))
1687    if (ij==ip1jm) jje=min(jje,jjm)
1688
1689    if (jje >= jjb) then
1690      ijb=(jjb-1)*iip1+1
1691      ije=jje*iip1
1692
1693!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1694      do l=1,ll
1695        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
1696      enddo
1697!$OMP ENDDO NOWAIT
1698    endif
1699
1700
1701  end subroutine CopyField   
1702
1703  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
1704    USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1705    USE paramet_mod_h
1706      implicit none
1707   
1708    INTEGER :: ij,ll,Up,Down
1709    REAL, dimension(ij,ll) :: FieldS
1710    REAL, dimension(ij,ll) :: FieldR
1711    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
1712    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
1713
1714    integer ::i,jje,jjb,ijb,ije,l
1715
1716     
1717    jj_begin_New(0)=1
1718    jj_End_New(0)=jj_Nb_New(0)
1719    do i=1,MPI_Size-1
1720      jj_begin_New(i)=jj_end_New(i-1)+1
1721      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
1722    enddo
1723
1724       
1725    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
1726    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
1727    if (ij==ip1jm) jje=min(jje,jjm)
1728   
1729   
1730    if (jje >= jjb) then
1731      ijb=(jjb-1)*iip1+1
1732      ije=jje*iip1
1733
1734!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1735      do l=1,ll
1736        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
1737      enddo
1738!$OMP ENDDO NOWAIT
1739
1740    endif
1741   end subroutine CopyFieldHallo       
1742
1743   subroutine Gather_field_u(field_loc,field_glo,ll)
1744   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1745   USE paramet_mod_h
1746   implicit none
1747     integer :: ll
1748     real :: field_loc(ijb_u:ije_u,ll)
1749     real :: field_glo(ip1jmp1,ll)
1750     type(request) :: request_gather
1751     integer       :: l
1752
1753
1754!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1755     DO l=1,ll
1756       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
1757     ENDDO
1758     
1759     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
1760     call SendRequest(request_gather)
1761!$OMP BARRIER
1762     call WaitRequest(request_gather)       
1763!$OMP BARRIER
1764
1765    end subroutine Gather_field_u
1766       
1767   subroutine Gather_field_v(field_loc,field_glo,ll)
1768   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1769   USE paramet_mod_h
1770   implicit none
1771     integer :: ll
1772     real :: field_loc(ijb_v:ije_v,ll)
1773     real :: field_glo(ip1jm,ll)
1774     type(request) :: request_gather
1775     integer :: ijb,ije
1776     integer       :: l
1777     
1778   
1779     ijb=ij_begin
1780     ije=ij_end
1781     if (pole_sud) ije=ij_end-iip1
1782       
1783!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1784     DO l=1,ll
1785       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
1786     ENDDO
1787     
1788     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
1789     call SendRequest(request_gather)
1790!$OMP BARRIER
1791     call WaitRequest(request_gather)       
1792!$OMP BARRIER
1793
1794    end subroutine Gather_field_v
1795     
1796   subroutine Scatter_field_u(field_glo,field_loc,ll)
1797   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1798   USE paramet_mod_h
1799   implicit none
1800     integer :: ll
1801     real :: field_glo(ip1jmp1,ll)
1802     real :: field_loc(ijb_u:ije_u,ll)
1803     type(request) :: request_gather
1804     TYPE(distrib) :: distrib_swap
1805     integer       :: l
1806     
1807!$OMP BARRIER
1808!$OMP MASTER     
1809     call get_current_distrib(distrib_swap)
1810     call set_Distrib(distrib_gather)
1811!$OMP END MASTER
1812!$OMP BARRIER
1813 
1814     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
1815     call SendRequest(request_gather)
1816!$OMP BARRIER
1817     call WaitRequest(request_gather)       
1818!$OMP BARRIER
1819!$OMP MASTER     
1820     call set_Distrib(distrib_swap)
1821!$OMP END MASTER
1822!$OMP BARRIER
1823
1824!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1825       DO l=1,ll
1826         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
1827       ENDDO
1828
1829    end subroutine Scatter_field_u
1830
1831   subroutine Scatter_field_v(field_glo,field_loc,ll)
1832   USE dimensions_mod, ONLY: iim, jjm, llm, ndm
1833   USE paramet_mod_h
1834   implicit none
1835     integer :: ll
1836     real :: field_glo(ip1jmp1,ll)
1837     real :: field_loc(ijb_v:ije_v,ll)
1838     type(request) :: request_gather
1839     TYPE(distrib) :: distrib_swap
1840     integer       :: ijb,ije,l
1841     
1842
1843!$OMP BARRIER
1844!$OMP MASTER     
1845     call get_current_distrib(distrib_swap)
1846     call set_Distrib(distrib_gather)
1847!$OMP END MASTER
1848!$OMP BARRIER
1849     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
1850     call SendRequest(request_gather)
1851!$OMP BARRIER
1852     call WaitRequest(request_gather)       
1853!$OMP BARRIER
1854!$OMP MASTER
1855     call set_Distrib(distrib_swap)
1856!$OMP END MASTER
1857!$OMP BARRIER
1858     ijb=ij_begin
1859     ije=ij_end
1860     if (pole_sud) ije=ij_end-iip1
1861     
1862!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1863       DO l=1,ll
1864         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
1865       ENDDO
1866
1867    end subroutine Scatter_field_v
1868             
1869end module mod_Hallo
1870   
Note: See TracBrowser for help on using the repository browser.