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

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

Merged trunk changes r2541:2545 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.4 KB
RevLine 
[782]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
[1999]17! Use of Oasis-MCT coupler
18#if defined CPP_OMCT
19  USE mod_prism
20! Use of Oasis3 coupler
21#else
[782]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
[1999]27#endif
[782]28 
29  IMPLICIT NONE
[1279]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
[2546]57  INTEGER, PARAMETER :: maxsend    = 25  ! Maximum number of fields to send
[1279]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 
[782]70
[1279]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
[782]76
[1279]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)
[782]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!
[1067]95    USE IOIPSL
[996]96    USE surface_data, ONLY : version_ocean
[1279]97    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
[2056]98#ifdef CPP_XIOS
99    USE wxios, ONLY : wxios_context_init
100#endif
[2408]101    USE print_control_mod, ONLY: lunout
102    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[1279]103
[782]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
[1999]117    LOGICAL, SAVE                      :: cpl_current_omp
[782]118
119!*    1. Initializations
120!        ---------------
121!************************************************************************************
[1279]122    WRITE(lunout,*) ' '
123    WRITE(lunout,*) ' '
124    WRITE(lunout,*) ' ROUTINE INICMA'
125    WRITE(lunout,*) ' **************'
126    WRITE(lunout,*) ' '
127    WRITE(lunout,*) ' '
[782]128
129!
130! Define the model name
131!
[2056]132    clmodnam = 'LMDZ'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
[1067]133
[1279]134
[782]135!************************************************************************************
[1067]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
[1279]144    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]145
146!************************************************************************************
[1279]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!************************************************************************************
[782]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 '
[2408]218          CALL abort_physic(modname,abort_message,1)
[782]219       ELSE
[1279]220          WRITE(lunout,*) 'inicma : init psmile ok '
[782]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 //
[2408]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
[782]231
[2408]232    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
[1279]233    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]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 '
[2408]240       CALL abort_physic(modname,abort_message,1)
[782]241    ELSE
[1279]242       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]243    ENDIF
244
245    il_var_nodims(1) = 2
246    il_var_nodims(2) = 1
247
248    il_var_actual_shape(1) = 1
[2408]249    il_var_actual_shape(2) = nbp_lon
[782]250    il_var_actual_shape(3) = 1
[2408]251    il_var_actual_shape(4) = nbp_lat
[782]252   
253    il_var_type = PRISM_Real
254
255!************************************************************************************
[1279]256! Oceanic Fields to receive
257! Loop over all possible variables
[782]258!************************************************************************************
[1279]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'
[2408]268             CALL abort_physic(modname,abort_message,1)
[1279]269          ENDIF
[782]270       ENDIF
271    END DO
[1279]272   
[782]273!************************************************************************************
[1279]274! Atmospheric Fields to send
275! Loop over all possible variables
[782]276!************************************************************************************
[1279]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'
[2408]286             CALL abort_physic(modname,abort_message,1)
[1279]287          ENDIF
[782]288       ENDIF
289    END DO
[1279]290   
[782]291!************************************************************************************
292! End definition
293!************************************************************************************
294    CALL prism_enddef_proto(ierror)
295    IF (ierror .NE. PRISM_Ok) THEN
[1279]296       abort_message=' Problem in call to prism_endef_proto'
[2408]297       CALL abort_physic(modname,abort_message,1)
[782]298    ELSE
[1279]299       WRITE(lunout,*) 'inicma : endef psmile ok '
[782]300    ENDIF
[1279]301
[2056]302#ifdef CPP_XIOS
303    CALL wxios_context_init()
304#endif
305
[1279]306!$OMP END MASTER
[782]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!
[2408]320    USE print_control_mod, ONLY: lunout
321    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]322! Input arguments
323!************************************************************************************
324    INTEGER, INTENT(IN)                               ::  ktime
325
326! Output arguments
327!************************************************************************************
[2408]328    REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get
[782]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
[2408]336    REAL, DIMENSION(nbp_lon*jj_nb)    :: field
[782]337
338!************************************************************************************
[1279]339    WRITE (lunout,*) ' '
340    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
341    WRITE (lunout,*) ' '
[782]342   
343    istart=ii_begin
[2435]344    IF (is_south_pole_dyn) THEN
[2408]345       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]346    ELSE
[2408]347       iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]348    ENDIF
349   
[1279]350    DO i = 1, maxrecv
[1999]351      IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
[1279]352          field(:) = -99999.
353          CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
[2408]354          tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
[782]355       
[1279]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 '
[2408]362              CALL abort_physic(modname,abort_message,1)
[1279]363          ENDIF
364      ENDIF
[782]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!
[2408]382    USE print_control_mod, ONLY: lunout
383    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]384! Input arguments
385!************************************************************************************
[1279]386    INTEGER, INTENT(IN)                              :: ktime
387    LOGICAL, INTENT(IN)                              :: last
[2408]388    REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
[782]389
390! Local variables
391!************************************************************************************
[987]392    LOGICAL                          :: checkout
393    INTEGER                          :: istart,iend
394    INTEGER                          :: wstart,wend
395    INTEGER                          :: ierror, i
[2408]396    REAL, DIMENSION(nbp_lon*jj_nb)       :: field
[987]397    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
398    CHARACTER (len = 80)             :: abort_message
[782]399
400!************************************************************************************
[987]401    checkout=.FALSE.
[782]402
[1279]403    WRITE(lunout,*) ' '
404    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
405    WRITE(lunout,*) 'last = ', last
406    WRITE(lunout,*)
[782]407
408
409    istart=ii_begin
[2435]410    IF (is_south_pole_dyn) THEN
[2408]411       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]412    ELSE
[2408]413       iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]414    ENDIF
415   
416    IF (checkout) THEN   
417       wstart=istart
418       wend=iend
[2435]419       IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
420       IF (is_south_pole_dyn) wend=iend-nbp_lon+1
[782]421       
[1279]422       DO i = 1, maxsend
423          IF (infosend(i)%action) THEN
[2408]424             field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]425             CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
426          END IF
427       END DO
428    END IF
429
[782]430!************************************************************************************
431! PRISM_PUT
432!************************************************************************************
433
[1279]434    DO i = 1, maxsend
[1999]435      IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
[2408]436          field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]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 '
[2408]444              CALL abort_physic(modname,abort_message,1)
[1279]445          ENDIF
446      ENDIF
[782]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
[1279]458             abort_message=' Problem in prism_terminate_proto '
[2408]459             CALL abort_physic(modname,abort_message,1)
[782]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.