source: LMDZ5/branches/IPSLCM6.0.11.rc1/libf/phylmd/oasis.F90 @ 4188

Last change on this file since 4188 was 2916, checked in by acaubel, 7 years ago

Added OMP THREADPRIVATE for infosend and inforecv variables.
  • 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
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 18.9 KB
Line 
1!
2MODULE oasis
3!
4! This module contains subroutines for initialization, sending and receiving
5! towards the coupler OASIS3. It also contains some parameters for the coupling.
6!
7! This module should always be compiled. With the coupler OASIS3 available the cpp key
8! CPP_COUPLE should be set and the entier of this file will then be compiled.
9! In a forced mode CPP_COUPLE should not be defined and the compilation ends before
10! the CONTAINS, without compiling the subroutines.
11!
12  USE dimphy
13  USE mod_phys_lmdz_para
14  USE write_field_phy
15
16#ifdef CPP_COUPLE
17! Use of Oasis-MCT coupler
18#if defined CPP_OMCT
19  USE mod_prism
20! Use of Oasis3 coupler
21#else
22  USE mod_prism_proto
23  USE mod_prism_def_partition_proto
24  USE mod_prism_get_proto
25  USE mod_prism_put_proto
26#endif
27#endif
28 
29  IMPLICIT NONE
30 
31  ! Id for fields sent to ocean
32  INTEGER, PARAMETER :: ids_tauxxu = 1
33  INTEGER, PARAMETER :: ids_tauyyu = 2
34  INTEGER, PARAMETER :: ids_tauzzu = 3
35  INTEGER, PARAMETER :: ids_tauxxv = 4
36  INTEGER, PARAMETER :: ids_tauyyv = 5
37  INTEGER, PARAMETER :: ids_tauzzv = 6
38  INTEGER, PARAMETER :: ids_windsp = 7
39  INTEGER, PARAMETER :: ids_shfice = 8
40  INTEGER, PARAMETER :: ids_shfoce = 9
41  INTEGER, PARAMETER :: ids_shftot = 10
42  INTEGER, PARAMETER :: ids_nsfice = 11
43  INTEGER, PARAMETER :: ids_nsfoce = 12
44  INTEGER, PARAMETER :: ids_nsftot = 13
45  INTEGER, PARAMETER :: ids_dflxdt = 14
46  INTEGER, PARAMETER :: ids_totrai = 15
47  INTEGER, PARAMETER :: ids_totsno = 16
48  INTEGER, PARAMETER :: ids_toteva = 17
49  INTEGER, PARAMETER :: ids_icevap = 18
50  INTEGER, PARAMETER :: ids_ocevap = 19
51  INTEGER, PARAMETER :: ids_calvin = 20
52  INTEGER, PARAMETER :: ids_liqrun = 21
53  INTEGER, PARAMETER :: ids_runcoa = 22
54  INTEGER, PARAMETER :: ids_rivflu = 23
55  INTEGER, PARAMETER :: ids_atmco2 = 24
56  INTEGER, PARAMETER :: ids_taumod = 25
57  INTEGER, PARAMETER :: ids_qraioc = 26
58  INTEGER, PARAMETER :: ids_qsnooc = 27
59  INTEGER, PARAMETER :: ids_qraiic = 28
60  INTEGER, PARAMETER :: ids_qsnoic = 29
61  INTEGER, PARAMETER :: maxsend    = 29  ! Maximum number of fields to send
62 
63  ! Id for fields received from ocean
64  INTEGER, PARAMETER :: idr_sisutw = 1
65  INTEGER, PARAMETER :: idr_icecov = 2
66  INTEGER, PARAMETER :: idr_icealw = 3
67  INTEGER, PARAMETER :: idr_icetem = 4
68  INTEGER, PARAMETER :: idr_curenx = 5
69  INTEGER, PARAMETER :: idr_cureny = 6
70  INTEGER, PARAMETER :: idr_curenz = 7
71  INTEGER, PARAMETER :: idr_oceco2 = 8
72  INTEGER, PARAMETER :: maxrecv    = 8  ! Maximum number of fields to receive
73 
74
75  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
76     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
77     LOGICAL            ::   action    ! To be exchanged or not
78     INTEGER            ::   nid       ! Id of the field
79  END TYPE FLD_CPL
80
81  TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend   ! Information for sending coupling fields
82!$OMP THREADPRIVATE(infosend)
83  TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv   ! Information for receiving coupling fields
84!$OMP THREADPRIVATE(inforecv)
85 
86  LOGICAL,SAVE :: cpl_current
87!$OMP THREADPRIVATE(cpl_current)
88
89#ifdef CPP_COUPLE
90
91CONTAINS
92
93  SUBROUTINE inicma
94!************************************************************************************
95!**** *INICMA*  - Initialize coupled mode communication for atmosphere
96!                 and exchange some initial information with Oasis
97!
98!     Rewrite to take the PRISM/psmile library into account
99!     LF 09/2003
100!
101    USE IOIPSL
102    USE surface_data, ONLY : version_ocean
103    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
104#ifdef CPP_XIOS
105    USE wxios, ONLY : wxios_context_init
106#endif
107    USE print_control_mod, ONLY: lunout
108    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
109
110! Local variables
111!************************************************************************************
112    INTEGER                            :: comp_id
113    INTEGER                            :: ierror, il_commlocal
114    INTEGER                            :: il_part_id
115    INTEGER, DIMENSION(3)              :: ig_paral
116    INTEGER, DIMENSION(2)              :: il_var_nodims
117    INTEGER, DIMENSION(4)              :: il_var_actual_shape
118    INTEGER                            :: il_var_type
119    INTEGER                            :: jf
120    CHARACTER (len = 6)                :: clmodnam
121    CHARACTER (len = 20)               :: modname = 'inicma'
122    CHARACTER (len = 80)               :: abort_message
123    LOGICAL, SAVE                      :: cpl_current_omp
124
125!*    1. Initializations
126!        ---------------
127!************************************************************************************
128    WRITE(lunout,*) ' '
129    WRITE(lunout,*) ' '
130    WRITE(lunout,*) ' ROUTINE INICMA'
131    WRITE(lunout,*) ' **************'
132    WRITE(lunout,*) ' '
133    WRITE(lunout,*) ' '
134
135!
136! Define the model name
137!
138    clmodnam = 'LMDZ'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
139
140
141!************************************************************************************
142! Define if coupling ocean currents or not
143!************************************************************************************
144!$OMP MASTER
145    cpl_current_omp = .FALSE.
146    CALL getin('cpl_current', cpl_current_omp)
147!$OMP END MASTER
148!$OMP BARRIER
149    cpl_current = cpl_current_omp
150    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
151
152!************************************************************************************
153! Define coupling variables
154!************************************************************************************
155
156! Atmospheric variables to send
157
158!$OMP MASTER
159    infosend(:)%action = .FALSE.
160
161    infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
162    infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
163    infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
164    infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
165    infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
166    infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
167    infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
168    infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
169    infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
170    infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
171    infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
172   
173    IF (version_ocean=='nemo') THEN
174        infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
175        infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
176        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
177        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
178        infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
179        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
180        infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
181        infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
182        IF (carbon_cycle_cpl) THEN
183            infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
184        ENDIF
185        infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
186        infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
187        infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
188        infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
189       
190    ELSE IF (version_ocean=='opa8') THEN
191        infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
192        infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
193        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
194        infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
195        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
196        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
197        infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
198        infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
199   ENDIF
200       
201! Oceanic variables to receive
202
203   inforecv(:)%action = .FALSE.
204
205   inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
206   inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
207   inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
208   inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
209   
210   IF (cpl_current ) THEN
211       inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
212       inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
213       inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
214   ENDIF
215
216   IF (carbon_cycle_cpl ) THEN
217       inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
218   ENDIF
219
220!************************************************************************************
221! Here we go: psmile initialisation
222!************************************************************************************
223    IF (is_sequential) THEN
224       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
225       
226       IF (ierror .NE. PRISM_Ok) THEN
227          abort_message=' Probleme init dans prism_init_comp '
228          CALL abort_physic(modname,abort_message,1)
229       ELSE
230          WRITE(lunout,*) 'inicma : init psmile ok '
231       ENDIF
232    ENDIF
233
234    CALL prism_get_localcomm_proto (il_commlocal, ierror)
235!************************************************************************************
236! Domain decomposition
237!************************************************************************************
238    ig_paral(1) = 1                            ! apple partition for //
239    ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1  ! offset
240    ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1
241
242    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
243    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
244   
245    ierror=PRISM_Ok
246    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
247
248    IF (ierror .NE. PRISM_Ok) THEN
249       abort_message=' Probleme dans prism_def_partition '
250       CALL abort_physic(modname,abort_message,1)
251    ELSE
252       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
253    ENDIF
254
255    il_var_nodims(1) = 2
256    il_var_nodims(2) = 1
257
258    il_var_actual_shape(1) = 1
259    il_var_actual_shape(2) = nbp_lon
260    il_var_actual_shape(3) = 1
261    il_var_actual_shape(4) = nbp_lat
262   
263    il_var_type = PRISM_Real
264
265!************************************************************************************
266! Oceanic Fields to receive
267! Loop over all possible variables
268!************************************************************************************
269    DO jf=1, maxrecv
270       IF (inforecv(jf)%action) THEN
271          CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
272               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
273               ierror)
274          IF (ierror .NE. PRISM_Ok) THEN
275             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
276                  inforecv(jf)%name
277             abort_message=' Problem in call to prism_def_var_proto for fields to receive'
278             CALL abort_physic(modname,abort_message,1)
279          ENDIF
280       ENDIF
281    END DO
282   
283!************************************************************************************
284! Atmospheric Fields to send
285! Loop over all possible variables
286!************************************************************************************
287    DO jf=1,maxsend
288       IF (infosend(jf)%action) THEN
289          CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
290               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
291               ierror)
292          IF (ierror .NE. PRISM_Ok) THEN
293             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
294                  infosend(jf)%name
295             abort_message=' Problem in call to prism_def_var_proto for fields to send'
296             CALL abort_physic(modname,abort_message,1)
297          ENDIF
298       ENDIF
299    END DO
300   
301!************************************************************************************
302! End definition
303!************************************************************************************
304    CALL prism_enddef_proto(ierror)
305    IF (ierror .NE. PRISM_Ok) THEN
306       abort_message=' Problem in call to prism_endef_proto'
307       CALL abort_physic(modname,abort_message,1)
308    ELSE
309       WRITE(lunout,*) 'inicma : endef psmile ok '
310    ENDIF
311
312#ifdef CPP_XIOS
313    CALL wxios_context_init()
314#endif
315
316!$OMP END MASTER
317   
318  END SUBROUTINE inicma
319
320!
321!************************************************************************************
322!
323
324  SUBROUTINE fromcpl(ktime, tab_get)
325! ======================================================================
326! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
327! and Sea-Ice provided by the coupler. Adaptation to psmile library
328!======================================================================
329!
330    USE print_control_mod, ONLY: lunout
331    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
332! Input arguments
333!************************************************************************************
334    INTEGER, INTENT(IN)                               ::  ktime
335
336! Output arguments
337!************************************************************************************
338    REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get
339
340! Local variables
341!************************************************************************************
342    INTEGER                       :: ierror, i
343    INTEGER                       :: istart,iend
344    CHARACTER (len = 20)          :: modname = 'fromcpl'
345    CHARACTER (len = 80)          :: abort_message
346    REAL, DIMENSION(nbp_lon*jj_nb)    :: field
347
348!************************************************************************************
349    WRITE (lunout,*) ' '
350    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
351    WRITE (lunout,*) ' '
352   
353    istart=ii_begin
354    IF (is_south_pole_dyn) THEN
355       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
356    ELSE
357       iend=(jj_end-jj_begin)*nbp_lon+ii_end
358    ENDIF
359   
360    DO i = 1, maxrecv
361      IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
362          field(:) = -99999.
363          CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
364          tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
365       
366          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
367             ierror.NE.PRISM_FromRest &
368             .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
369             .AND. ierror.NE.PRISM_FromRestOut) THEN
370              WRITE (lunout,*)  'Error with receiving filed : ', inforecv(i)%name, ktime   
371              abort_message=' Problem in prism_get_proto '
372              CALL abort_physic(modname,abort_message,1)
373          ENDIF
374      ENDIF
375    END DO
376   
377   
378  END SUBROUTINE fromcpl
379
380!
381!************************************************************************************
382!
383
384  SUBROUTINE intocpl(ktime, last, tab_put)
385! ======================================================================
386! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
387! atmospheric coupling fields to the coupler with the psmile library.
388! IF last time step, writes output fields to binary files.
389! ======================================================================
390!
391!
392    USE print_control_mod, ONLY: lunout
393    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
394! Input arguments
395!************************************************************************************
396    INTEGER, INTENT(IN)                              :: ktime
397    LOGICAL, INTENT(IN)                              :: last
398    REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
399
400! Local variables
401!************************************************************************************
402    LOGICAL                          :: checkout
403    INTEGER                          :: istart,iend
404    INTEGER                          :: wstart,wend
405    INTEGER                          :: ierror, i
406    REAL, DIMENSION(nbp_lon*jj_nb)       :: field
407    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
408    CHARACTER (len = 80)             :: abort_message
409
410!************************************************************************************
411    checkout=.FALSE.
412
413    WRITE(lunout,*) ' '
414    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
415    WRITE(lunout,*) 'last = ', last
416    WRITE(lunout,*)
417
418
419    istart=ii_begin
420    IF (is_south_pole_dyn) THEN
421       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
422    ELSE
423       iend=(jj_end-jj_begin)*nbp_lon+ii_end
424    ENDIF
425   
426    IF (checkout) THEN   
427       wstart=istart
428       wend=iend
429       IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
430       IF (is_south_pole_dyn) wend=iend-nbp_lon+1
431       
432       DO i = 1, maxsend
433          IF (infosend(i)%action) THEN
434             field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
435             CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
436          END IF
437       END DO
438    END IF
439
440!************************************************************************************
441! PRISM_PUT
442!************************************************************************************
443
444    DO i = 1, maxsend
445      IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
446          field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
447          CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
448         
449          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
450             .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
451             ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
452              WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime   
453              abort_message=' Problem in prism_put_proto '
454              CALL abort_physic(modname,abort_message,1)
455          ENDIF
456      ENDIF
457    END DO
458   
459!************************************************************************************
460! Finalize PSMILE for the case is_sequential, if parallel finalization is done
461! from Finalize_parallel in dyn3dpar/parallel.F90
462!************************************************************************************
463
464    IF (last) THEN
465       IF (is_sequential) THEN
466          CALL prism_terminate_proto(ierror)
467          IF (ierror .NE. PRISM_Ok) THEN
468             abort_message=' Problem in prism_terminate_proto '
469             CALL abort_physic(modname,abort_message,1)
470          ENDIF
471       ENDIF
472    ENDIF
473   
474   
475  END SUBROUTINE intocpl
476
477#endif
478 
479END MODULE oasis
Note: See TracBrowser for help on using the repository browser.