source: LMDZ5/branches/testing/libf/phylmd/oasis.F90 @ 3978

Last change on this file since 3978 was 2886, checked in by Laurent Fairhead, 8 years ago

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