source: LMDZ5/branches/IPSLCM5A2.1_ISO/libf/phylmd/oasis.F90 @ 5361

Last change on this file since 5361 was 2545, checked in by Laurent Fairhead, 9 years ago

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