source: tags/ORCHIDEE_4_1/ORCHIDEE/src_parallel/mod_orchidee_omp_data.F90 @ 7852

Last change on this file since 7852 was 6190, checked in by josefine.ghattas, 5 years ago

Added more subroutines included in the interfaces for restget/restput/histwrite_p to be able to handle more dimensions.
For more information, see ticket #596

Done by A. Jornet
  • Property svn:keywords set to Date Revision HeadURL
File size: 11.5 KB
Line 
1! ===============================================================================================================================
2! MODULE       : mod_orchidee_omp_data
3!
4! CONTACT      : orchidee-help _at_ listes.ipsl.fr
5!
6! LICENCE      : IPSL (2006)
7! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8!
9!>\BRIEF        Contains initialization and allocation of variables and functions related to OpenMP parallelization.
10!!
11!! \n DESCRIPTION : Contains subroutines for initialization and allocation of variables and functions related to
12!!                  OpenMP parallelization.
13!!
14!! RECENT CHANGE(S): None
15!!
16!! REFERENCES(S)    : None
17!!
18!! SVN              :
19!! $HeadURL$
20!! $Date$
21!! $Revision$
22!! \n
23!_ ================================================================================================================================
24MODULE mod_orchidee_omp_data
25
26!-
27  USE defprec
28  USE ioipsl
29  USE mod_orchidee_para_var
30
31  IMPLICIT NONE
32
33CONTAINS
34
35
36
37!!  =============================================================================================================================
38!! SUBROUTINE:    barrier2_omp
39!!
40!>\BRIEF        this routine call two omp barrier to prevent a specific bug when orchidee is coupled to lmdz
41!!
42!! DESCRIPTION:   this routine call two omp barrier to prevent a specific bug when orchidee is coupled to lmdz
43!!
44!!               
45!! \n
46!_ ==============================================================================================================================
47    SUBROUTINE barrier2_omp()
48
49    IMPLICIT NONE
50
51!$OMP BARRIER
52!$OMP BARRIER
53
54  END SUBROUTINE barrier2_omp
55
56
57
58 
59!!  =============================================================================================================================
60!! SUBROUTINE:   Init_orchidee_omp
61!!
62!>\BRIEF        define the variables is_ok_omp, is_omp_root, omp_size and omp_rank  in the offline case
63!!
64!! DESCRIPTION:   define the variables is_ok_omp, is_omp_root, omp_size and omp_rank  in the offline case
65!!
66!!               
67!! \n
68!_ ==============================================================================================================================
69  SUBROUTINE Init_orchidee_omp
70  IMPLICIT NONE
71 
72#ifdef CPP_OMP
73    IF (is_omp_root) THEN
74        is_ok_omp=.TRUE.
75    ENDIF
76#else   
77    is_ok_omp=.FALSE.
78#endif
79
80
81    IF (is_ok_omp) THEN
82      STOP 'Open MP is not yet implemented for driver'
83    ELSE
84      omp_size=1
85      omp_rank=0
86      is_omp_root=.TRUE.
87    ENDIF
88
89  END SUBROUTINE Init_orchidee_omp
90
91
92!!  =============================================================================================================================
93!! SUBROUTINE:  Init_numout_omp 
94!!
95!>\BRIEF  Define a number for the output file specific to the omp thread.         
96!!
97!! DESCRIPTION:    Define a number for the output file specific to the omp thread.       
98!!
99!!               
100!! \n
101!_ ==============================================================================================================================
102  SUBROUTINE Init_numout_omp(numout)
103    INTEGER, INTENT(in) :: numout
104    numout_omp=numout
105  END SUBROUTINE Init_numout_omp
106
107
108!!  =============================================================================================================================
109!! SUBROUTINE:  Init_orchidee_omp_data 
110!!
111!>\BRIEF          Omp parallelisation in the coupled case.
112!!
113!! DESCRIPTION:    Omp parallelisation in the coupled case. In this routine we will define all omp variables
114!!                 is_omp_root, omp_size, omp_rank, nbp_omp_para_nb, nbp_omp_para_begin, nbp_omp_para_end
115!!                 nbp_omp_begin, nbp_omp_end, nbp_omp
116!!
117!!               
118!! \n
119!_ ==============================================================================================================================
120  SUBROUTINE Init_orchidee_omp_data(arg_omp_size,arg_omp_rank,arg_nbp_omp,kindex, arg_offset_omp,last)
121    IMPLICIT NONE
122    INTEGER, INTENT(IN) :: arg_omp_size
123    INTEGER, INTENT(IN) :: arg_omp_rank
124    INTEGER, INTENT(IN) :: arg_nbp_omp
125    INTEGER, INTENT(IN) :: kindex(arg_nbp_omp)
126    INTEGER, INTENT(IN) :: arg_offset_omp
127    LOGICAL, INTENT(IN) :: last
128   
129    INTEGER    :: i
130   
131   
132    IF (arg_omp_rank==0) THEN
133      is_omp_root=.TRUE.
134    ELSE
135      is_omp_root=.FALSE.
136    ENDIF
137   
138#ifdef CPP_OMP
139    IF (is_omp_root) THEN
140        is_ok_omp=.TRUE.
141    ENDIF
142#else   
143    is_ok_omp=.FALSE.
144#endif
145
146    IF (is_omp_root) omp_size=arg_omp_size
147
148    CALL barrier2_omp()
149
150     omp_rank=arg_omp_rank
151   
152    IF (is_omp_root) THEN
153      ALLOCATE(nbp_omp_para_nb(0:omp_size-1))
154      ALLOCATE(nbp_omp_para_begin(0:omp_size-1))
155      ALLOCATE(nbp_omp_para_end(0:omp_size-1))
156      ALLOCATE(ij_omp_para_nb(0:omp_size-1))
157      ALLOCATE(ij_omp_para_begin(0:omp_size-1))
158      ALLOCATE(ij_omp_para_end(0:omp_size-1))
159    ENDIF
160   
161    CALL barrier2_omp()
162    offset_omp=arg_offset_omp         
163
164    nbp_omp_para_nb(omp_rank)=arg_nbp_omp
165    ij_omp_para_begin(omp_rank)=offset_omp+1
166    IF (last) THEN
167      ij_omp_para_end(omp_rank)=iim_g*jjm_g
168    ELSE
169      ij_omp_para_end(omp_rank)=kindex(arg_nbp_omp)+offset_omp
170    ENDIF
171    ij_omp_para_nb(omp_rank)=ij_omp_para_end(omp_rank)-ij_omp_para_begin(omp_rank)+1
172    CALL barrier2_omp()
173   
174    IF (is_omp_root) THEN
175
176      nbp_omp_para_begin(0)=1
177      nbp_omp_para_end(0)=nbp_omp_para_nb(0)
178
179      DO i=1,omp_size-1
180        nbp_omp_para_begin(i)=nbp_omp_para_end(i-1)+1
181        nbp_omp_para_end(i)=nbp_omp_para_begin(i)+nbp_omp_para_nb(i)-1
182      ENDDO
183       ij_omp_para_begin(:) = ij_omp_para_begin(:)-offset_omp
184       ij_omp_para_end(:) = ij_omp_para_end(:)-offset_omp
185    ENDIF
186
187    CALL barrier2_omp()
188     
189    nbp_omp=nbp_omp_para_nb(omp_rank)
190    nbp_omp_begin=nbp_omp_para_begin(omp_rank)
191    nbp_omp_end=nbp_omp_para_end(omp_rank)
192
193    ij_omp_nb=ij_omp_para_nb(omp_rank)
194    ij_omp_begin=ij_omp_para_begin(omp_rank)
195    ij_omp_end=ij_omp_para_end(omp_rank)
196   
197    offset_omp=arg_offset_omp         
198
199    ! Continental gridcells
200    nbp_para_info%nb_omp = nbp_omp_para_nb(omp_rank) 
201    nbp_para_info%begin_omp = nbp_omp_para_begin(omp_rank)
202
203    ! 2D (Continental + ocean) gridcells
204    ij_para_info%nb_omp = ij_omp_para_nb(omp_rank)
205    ij_para_info%begin_omp = ij_omp_para_begin(omp_rank)
206
207    CALL Print_omp_data
208   
209    CALL Init_synchro_omp()
210   
211  END SUBROUTINE Init_orchidee_omp_data
212
213!!  =============================================================================================================================
214!! SUBROUTINE:    print_omp_data
215!!
216!>\BRIEF         print specific omp parallelisation variables
217!!
218!! DESCRIPTION:          print specific omp parallelisation variables
219!!
220!!               
221!! \n
222!_ ==============================================================================================================================
223  SUBROUTINE print_omp_data
224  IMPLICIT NONE
225
226!$OMP CRITICAL 
227  PRINT *,'--------> ORCHIDEE TASK ',omp_rank
228  PRINT *,'omp_size =',omp_size
229  PRINT *,'omp_rank =',omp_rank
230  PRINT *,'is_omp_root =',is_omp_root
231  PRINT *,'offset_omp',offset_omp
232  PRINT *,'nbp_omp_para_nb =',nbp_omp_para_nb
233  PRINT *,'nbp_omp_para_begin =',nbp_omp_para_begin
234  PRINT *,'nbp_omp_para_end =',nbp_omp_para_end   
235  PRINT *,'nbp_omp =',nbp_omp
236  PRINT *,'nbp_omp_begin =',nbp_omp_begin
237  PRINT *,'nbp_omp_end =',nbp_omp_end   
238!$OMP END CRITICAL
239
240  END SUBROUTINE print_omp_data
241
242!!  =============================================================================================================================
243!! SUBROUTINE:  Init_synchro_omp 
244!!
245!>\BRIEF    initialization of  some variables use for the synchronisation of omp threads
246!!
247!! DESCRIPTION:   initialization of  some variables use for the synchronisation of omp threads
248!!
249!!               
250!! \n
251!_ ==============================================================================================================================
252  SUBROUTINE Init_synchro_omp
253  IMPLICIT NONE
254   
255    IF (is_omp_root) THEN
256      ALLOCATE(proc_synchro_omp(0:omp_size-1))
257      proc_synchro_omp(:)=.FALSE.
258
259      IF ( check_all_transfert ) THEN
260         ALLOCATE(omp_function(0:omp_size-1))
261         omp_function(:)=-1
262      ENDIF
263    ENDIF
264    CALL barrier2_omp()
265
266  END SUBROUTINE Init_Synchro_omp
267 
268!!  =============================================================================================================================
269!! SUBROUTINE:   Synchro_omp
270!!
271!>\BRIEF            routine to make synchronisation of omp threads after a call to a omp routine         
272!!
273!! DESCRIPTION:   routine to make synchronisation of omp threads after a call to a omp routine
274!!                add a control to check the time waited for the synchronisation.
275!!               
276!! \n
277!_ ==============================================================================================================================
278  SUBROUTINE Synchro_omp
279    IMPLICIT NONE
280
281#ifdef CPP_PARA
282    INCLUDE 'mpif.h'
283#endif
284    INTEGER iter
285    LOGICAL, PARAMETER :: check=.TRUE.
286    INTEGER, PARAMETER :: iter_max=1
287    INTEGER, PARAMETER :: print_iter=1
288    INTEGER            :: ierr
289
290    proc_synchro_omp(omp_rank)=.TRUE.
291    CALL barrier2_omp()
292
293    iter=0
294    DO WHILE (.NOT. ALL(proc_synchro_omp))
295       iter=iter+1
296       IF ( mod(iter,print_iter) == 0 ) THEN
297          IF (numout_omp > 0) THEN
298             WRITE(numout_omp,*) "ORCHIDEE SYNCHRO OMP : iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
299          ELSE
300             WRITE(*,*) "ORCHIDEE SYNCHRO OMP : iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
301          ENDIF
302       ENDIF
303       IF (check) THEN
304          IF (iter > iter_max) THEN
305             IF (numout_omp > 0) THEN
306                WRITE(numout_omp,*) "TOO MUCH WAIT in Synchro_Omp !! iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
307                WRITE(numout_omp,*) "We stop here"
308                WRITE(numout_omp,*) "omp_function : ",omp_function(:)
309             ELSE
310                WRITE(*,*) "TOO MUCH WAIT in Synchro_Omp !! iter ",iter," rank ",omp_rank," wait for ",proc_synchro_omp
311                WRITE(*,*) "We stop here"
312                WRITE(*,*) "omp_function : ",omp_function(:)
313             ENDIF
314#ifdef CPP_PARA
315             CALL MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
316#endif     
317             STOP 'Fatal error from ORCHIDEE : Synchro_Omp failed'
318          ENDIF
319       ENDIF
320    CALL barrier2_omp()
321    ENDDO
322    CALL barrier2_omp()
323    proc_synchro_omp(omp_rank)=.FALSE.
324    CALL barrier2_omp()
325
326   END SUBROUTINE Synchro_omp
327
328!!  =============================================================================================================================
329!! SUBROUTINE:    print_omp_function
330!!
331!>\BRIEF         
332!!
333!! DESCRIPTION:   
334!!
335!!               
336!! \n
337!_ ==============================================================================================================================
338   SUBROUTINE print_omp_function ()
339
340     IF ( check_all_transfert ) THEN
341        CALL barrier2_omp()
342        IF (numout_omp > 0) THEN
343           WRITE(numout_omp,*) omp_rank,&
344                " : ",omp_fct_name(omp_previous),'->',omp_fct_name(omp_function(omp_rank))
345           IF (MINVAL(omp_function(:)).LT.MAXVAL(omp_function(:))) &
346                WRITE(numout_omp,*) "!!! OMP ERROR : NO MORE SYNCHRO  !!!  ",omp_function(:)
347        ELSE
348           WRITE(*,*) omp_rank,&
349                " : ",omp_fct_name(omp_previous),'->',omp_fct_name(omp_function(omp_rank))
350           IF (MINVAL(omp_function(:)).LT.MAXVAL(omp_function(:))) &
351                WRITE(*,*) "!!! OMP ERROR : NO MORE SYNCHRO  !!!  ",omp_function(:)
352        ENDIF
353        CALL barrier2_omp()
354     ENDIF
355
356  END SUBROUTINE print_omp_function
357
358
359END MODULE mod_orchidee_omp_data
Note: See TracBrowser for help on using the repository browser.