source: LMDZ5/trunk/libf/phylmd/oasis.F90 @ 2311

Last change on this file since 2311 was 2311, checked in by Ehouarn Millour, 9 years ago

Further modifications to enforce physics/dynamics separation:

  • moved iniprint.h and misc_mod back to dyn3d_common, as these should only be used by dynamics.
  • created print_control_mod in the physics to store flags prt_level, lunout, debug to be local to physics (should be used rather than iniprint.h)
  • created abort_physic.F90 , which does the same job as abort_gcm() did, but should be used instead when in physics.
  • reactivated inifis (turned it into a module, inifis_mod.F90) to initialize physical constants and print_control_mod flags.

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