source: LMDZ6/trunk/libf/phylmd/oasis.F90 @ 5654

Last change on this file since 5654 was 5654, checked in by acozic, 8 weeks ago

Add possibility to send N2O from atm chemistry (with Inca model - but definition for oasis is done in LMDZ) to NEMO

  • 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:keywords set to Author Date Id Revision
File size: 22.8 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
[1965]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
[1965]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
[2872]57  INTEGER, PARAMETER :: ids_qraioc = 26
58  INTEGER, PARAMETER :: ids_qsnooc = 27
59  INTEGER, PARAMETER :: ids_qraiic = 28
60  INTEGER, PARAMETER :: ids_qsnoic = 29
[4370]61  INTEGER, PARAMETER :: ids_delta_sst = 30, ids_delta_sal = 31, ids_dter = 32, &
62       ids_dser = 33, ids_dt_ds = 34
[5654]63  INTEGER, PARAMETER :: ids_atmn2o = 35
[1279]64 
[5654]65  INTEGER, PARAMETER :: maxsend    = 35  ! Maximum number of fields to send
66  INTEGER, PARAMETER :: maxsend_phys = 34 ! Maximum number of fields to send in LMDZ phys - the last one will be send by Inca
67
[1279]68  ! Id for fields received from ocean
[3815]69
[1279]70  INTEGER, PARAMETER :: idr_sisutw = 1
71  INTEGER, PARAMETER :: idr_icecov = 2
72  INTEGER, PARAMETER :: idr_icealw = 3
73  INTEGER, PARAMETER :: idr_icetem = 4
74  INTEGER, PARAMETER :: idr_curenx = 5
75  INTEGER, PARAMETER :: idr_cureny = 6
76  INTEGER, PARAMETER :: idr_curenz = 7
77  INTEGER, PARAMETER :: idr_oceco2 = 8
[4640]78  ! bulk salinity of the surface layer of the ocean, in ppt
[3815]79  INTEGER, PARAMETER :: idr_sss = 9
[4640]80  INTEGER, PARAMETER :: idr_ocedms = 10
[4754]81  INTEGER, PARAMETER :: idr_ocen2o = 11
[3815]82
[4754]83  INTEGER, PARAMETER :: maxrecv      = 11     ! Maximum number of fields to receive
[4640]84  INTEGER, PARAMETER :: maxrecv_phys = 9      ! Maximum number of fields to receive in physiq (without fields received in INCA model )
85                                              ! will be changed in next version - INCA fields will be received in LMDZ (like for ORCHIDEE fields)
86                                              ! and then send by routine in INCA model
[1279]87 
[782]88
[1279]89  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
90     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
91     LOGICAL            ::   action    ! To be exchanged or not
92     INTEGER            ::   nid       ! Id of the field
93  END TYPE FLD_CPL
[782]94
[1279]95  TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend   ! Information for sending coupling fields
[2916]96!$OMP THREADPRIVATE(infosend)
[1279]97  TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv   ! Information for receiving coupling fields
[2916]98!$OMP THREADPRIVATE(inforecv)
[1279]99 
100  LOGICAL,SAVE :: cpl_current
101!$OMP THREADPRIVATE(cpl_current)
[782]102
103#ifdef CPP_COUPLE
104
105CONTAINS
106
107  SUBROUTINE inicma
108!************************************************************************************
109!**** *INICMA*  - Initialize coupled mode communication for atmosphere
110!                 and exchange some initial information with Oasis
111!
112!     Rewrite to take the PRISM/psmile library into account
113!     LF 09/2003
114!
[1067]115    USE IOIPSL
[996]116    USE surface_data, ONLY : version_ocean
[1279]117    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
[5310]118    use wxios_mod, ONLY : wxios_context_init
[4754]119    USE chemistry_cycle_mod, ONLY : dms_cycle_cpl, n2o_cycle_cpl
[4619]120    USE lmdz_xios 
[2311]121    USE print_control_mod, ONLY: lunout
[3465]122    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
123    USE geometry_mod, ONLY: ind_cell_glo                   
124    USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
[3815]125    use config_ocean_skin_m, only: activate_ocean_skin
[5251]126    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
[1279]127
[782]128! Local variables
129!************************************************************************************
130    INTEGER                            :: comp_id
131    INTEGER                            :: ierror, il_commlocal
132    INTEGER                            :: il_part_id
[3465]133    INTEGER, ALLOCATABLE               :: ig_paral(:)
[782]134    INTEGER, DIMENSION(2)              :: il_var_nodims
135    INTEGER, DIMENSION(4)              :: il_var_actual_shape
136    INTEGER                            :: il_var_type
137    INTEGER                            :: jf
138    CHARACTER (len = 6)                :: clmodnam
139    CHARACTER (len = 20)               :: modname = 'inicma'
140    CHARACTER (len = 80)               :: abort_message
[5582]141    !! WARNING: cpl_current_omp should NOT be put in a THREADPRIVATE statement, it is shared between tasks
[1997]142    LOGICAL, SAVE                      :: cpl_current_omp
[4596]143    INTEGER, DIMENSION(klon_mpi)       :: ind_cell_glo_mpi
[782]144
[5483]145
[782]146!*    1. Initializations
147!        ---------------
148!************************************************************************************
[1279]149    WRITE(lunout,*) ' '
150    WRITE(lunout,*) ' '
151    WRITE(lunout,*) ' ROUTINE INICMA'
152    WRITE(lunout,*) ' **************'
153    WRITE(lunout,*) ' '
154    WRITE(lunout,*) ' '
[782]155
156!
157! Define the model name
158!
[3465]159    IF (grid_type==unstructured) THEN
160        clmodnam = 'icosa'                 ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
161    ELSE IF (grid_type==regular_lonlat) THEN
162        clmodnam = 'LMDZ'                  ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
163    ELSE
164        abort_message='Pb : type of grid unknown'
165        CALL abort_physic(modname,abort_message,1)
166    ENDIF
[1067]167
[1279]168
[782]169!************************************************************************************
[1067]170! Define if coupling ocean currents or not
171!************************************************************************************
172!$OMP MASTER
173    cpl_current_omp = .FALSE.
174    CALL getin('cpl_current', cpl_current_omp)
175!$OMP END MASTER
176!$OMP BARRIER
177    cpl_current = cpl_current_omp
[1279]178    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
[1067]179
180!************************************************************************************
[4596]181! Gather global index to be used for oasis decomposition
182!************************************************************************************
183    CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi)
184
185!************************************************************************************
[1279]186! Define coupling variables
187!************************************************************************************
188
189! Atmospheric variables to send
190
191!$OMP MASTER
192    infosend(:)%action = .FALSE.
193
194    infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
195    infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
196    infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
197    infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
198    infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
199    infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
200    infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
201    infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
202    infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
203    infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
204    infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
205   
[3815]206    if (activate_ocean_skin == 2) then
207       infosend(ids_delta_sst)%action = .TRUE.
208       infosend(ids_delta_sst)%name = 'CODELSST'
209       infosend(ids_delta_sal)%action = .TRUE.
210       infosend(ids_delta_sal)%name = 'CODELSSS'
[4370]211       infosend(ids_dter)%action = .TRUE.
212       infosend(ids_dter)%name = 'CODELTER'
213       infosend(ids_dser)%action = .TRUE.
214       infosend(ids_dser)%name = 'CODELSER'
215       infosend(ids_dt_ds)%action = .TRUE.
216       infosend(ids_dt_ds)%name = 'CODTDS'
[3815]217    end if
218           
[1279]219    IF (version_ocean=='nemo') THEN
220        infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
221        infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
222        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
223        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
224        infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
225        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
226        infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
227        infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
228        IF (carbon_cycle_cpl) THEN
229            infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
230        ENDIF
[5654]231        IF (n2o_cycle_cpl) THEN
232            infosend(ids_atmn2o)%action = .TRUE. ; infosend(ids_atmn2o)%name = 'COATMN2O'
233        ENDIF
[2872]234        infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
235        infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
236        infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
237        infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
[1279]238       
239    ELSE IF (version_ocean=='opa8') THEN
240        infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
241        infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
242        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
243        infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
244        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
245        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
246        infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
247        infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
248   ENDIF
249       
250! Oceanic variables to receive
251
252   inforecv(:)%action = .FALSE.
253
254   inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
255   inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
256   inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
257   inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
[3815]258
259   if (activate_ocean_skin >= 1) then
260      inforecv(idr_sss)%action = .TRUE.
261      inforecv(idr_sss)%name = 'SISUSALW'
262   end if
[1279]263   
264   IF (cpl_current ) THEN
265       inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
266       inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
267       inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
268   ENDIF
269
270   IF (carbon_cycle_cpl ) THEN
271       inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
272   ENDIF
[4640]273   IF (dms_cycle_cpl) THEN
274      inforecv(idr_ocedms)%action = .TRUE. ; inforecv(idr_ocedms)%name = 'SIDMSFLX'
275   ENDIF
[4754]276   IF (n2o_cycle_cpl) THEN
277      inforecv(idr_ocen2o)%action = .TRUE. ; inforecv(idr_ocen2o)%name = 'SIN2OFLX'
278   ENDIF
[4640]279 
[1279]280
281!************************************************************************************
[782]282! Here we go: psmile initialisation
283!************************************************************************************
284    IF (is_sequential) THEN
285       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
286       
287       IF (ierror .NE. PRISM_Ok) THEN
288          abort_message=' Probleme init dans prism_init_comp '
[2311]289          CALL abort_physic(modname,abort_message,1)
[782]290       ELSE
[1279]291          WRITE(lunout,*) 'inicma : init psmile ok '
[782]292       ENDIF
293    ENDIF
294
295    CALL prism_get_localcomm_proto (il_commlocal, ierror)
296!************************************************************************************
297! Domain decomposition
298!************************************************************************************
[3465]299    IF (grid_type==unstructured) THEN
[782]300
[3465]301      ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
302
303      ig_paral(1) = 4                                      ! points partition for //
304      ig_paral(2) = klon_mpi_para_nb(mpi_rank)             ! nb of local cells
305
306      DO jf=1, klon_mpi_para_nb(mpi_rank)
[4596]307        ig_paral(2+jf) = ind_cell_glo_mpi(jf)
[3465]308      ENDDO
309
310    ELSE IF (grid_type==regular_lonlat) THEN
311
312      ALLOCATE( ig_paral(3) )
313
314      ig_paral(1) = 1                            ! apple partition for //
315      ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1  ! offset
316      ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1
317
318      IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
319    ELSE
320      abort_message='Pb : type of grid unknown'
321      CALL abort_physic(modname,abort_message,1)
322    ENDIF
323
324
[1279]325    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[782]326   
327    ierror=PRISM_Ok
328    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
329
330    IF (ierror .NE. PRISM_Ok) THEN
331       abort_message=' Probleme dans prism_def_partition '
[2311]332       CALL abort_physic(modname,abort_message,1)
[782]333    ELSE
[1279]334       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
[782]335    ENDIF
336
[3465]337    il_var_nodims(1) = 2                        ! rank of field array (1d or 2d)
338    il_var_nodims(2) = 1                        ! always 1 in current oasis version" doc oasis3mct p18
[782]339
[3465]340    il_var_actual_shape(1) = 1                  ! min of 1st dimension (always 1)
341    il_var_actual_shape(2) = nbp_lon            ! max of 1st dimension
342    il_var_actual_shape(3) = 1                  ! min of 2nd dimension (always 1)
343    il_var_actual_shape(4) = nbp_lat            ! max of 2nd dimension
[782]344   
345    il_var_type = PRISM_Real
346
347!************************************************************************************
[1279]348! Oceanic Fields to receive
349! Loop over all possible variables
[782]350!************************************************************************************
[1279]351    DO jf=1, maxrecv
352       IF (inforecv(jf)%action) THEN
353          CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
354               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
355               ierror)
356          IF (ierror .NE. PRISM_Ok) THEN
357             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
358                  inforecv(jf)%name
359             abort_message=' Problem in call to prism_def_var_proto for fields to receive'
[2311]360             CALL abort_physic(modname,abort_message,1)
[1279]361          ENDIF
[782]362       ENDIF
363    END DO
[4247]364
365 
[782]366!************************************************************************************
[1279]367! Atmospheric Fields to send
368! Loop over all possible variables
[782]369!************************************************************************************
[1279]370    DO jf=1,maxsend
371       IF (infosend(jf)%action) THEN
372          CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
373               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
374               ierror)
375          IF (ierror .NE. PRISM_Ok) THEN
376             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
377                  infosend(jf)%name
378             abort_message=' Problem in call to prism_def_var_proto for fields to send'
[2311]379             CALL abort_physic(modname,abort_message,1)
[1279]380          ENDIF
[782]381       ENDIF
382    END DO
[1279]383   
[782]384!************************************************************************************
385! End definition
386!************************************************************************************
[4619]387
388    IF (using_xios) CALL xios_oasis_enddef()
389
[782]390    CALL prism_enddef_proto(ierror)
391    IF (ierror .NE. PRISM_Ok) THEN
[1279]392       abort_message=' Problem in call to prism_endef_proto'
[2311]393       CALL abort_physic(modname,abort_message,1)
[782]394    ELSE
[1279]395       WRITE(lunout,*) 'inicma : endef psmile ok '
[782]396    ENDIF
[1279]397
[5654]398
399IF (CPPKEY_INCA) THEN
400    IF (dms_cycle_cpl .OR. n2o_cycle_cpl) THEN
401       CALL init_inca_oasis(inforecv(idr_ocedms:idr_ocen2o),infosend(ids_atmn2o:ids_atmn2o))
402    ENDIF
403END IF
404
[4642]405!$OMP END MASTER
[782]406   
407  END SUBROUTINE inicma
408
409!
410!************************************************************************************
411!
412
413  SUBROUTINE fromcpl(ktime, tab_get)
414! ======================================================================
415! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
416! and Sea-Ice provided by the coupler. Adaptation to psmile library
417!======================================================================
418!
[2311]419    USE print_control_mod, ONLY: lunout
[2371]420    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]421! Input arguments
422!************************************************************************************
423    INTEGER, INTENT(IN)                               ::  ktime
424
425! Output arguments
426!************************************************************************************
[4640]427    REAL, DIMENSION(nbp_lon, jj_nb,maxrecv_phys), INTENT(OUT) :: tab_get
[782]428
429! Local variables
430!************************************************************************************
431    INTEGER                       :: ierror, i
432    INTEGER                       :: istart,iend
433    CHARACTER (len = 20)          :: modname = 'fromcpl'
434    CHARACTER (len = 80)          :: abort_message
[2346]435    REAL, DIMENSION(nbp_lon*jj_nb)    :: field
[782]436
437!************************************************************************************
[1279]438    WRITE (lunout,*) ' '
439    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
440    WRITE (lunout,*) ' '
[782]441   
442    istart=ii_begin
[2429]443    IF (is_south_pole_dyn) THEN
[2346]444       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]445    ELSE
[2346]446       iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]447    ENDIF
448   
[4640]449    DO i = 1, maxrecv_phys
[1965]450      IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
[1279]451          field(:) = -99999.
452          CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
[2346]453          tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
[782]454       
[1279]455          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
456             ierror.NE.PRISM_FromRest &
457             .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
458             .AND. ierror.NE.PRISM_FromRestOut) THEN
459              WRITE (lunout,*)  'Error with receiving filed : ', inforecv(i)%name, ktime   
460              abort_message=' Problem in prism_get_proto '
[2311]461              CALL abort_physic(modname,abort_message,1)
[1279]462          ENDIF
463      ENDIF
[782]464    END DO
465   
466   
467  END SUBROUTINE fromcpl
468
469!
470!************************************************************************************
471!
472
473  SUBROUTINE intocpl(ktime, last, tab_put)
474! ======================================================================
475! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
476! atmospheric coupling fields to the coupler with the psmile library.
477! IF last time step, writes output fields to binary files.
478! ======================================================================
479!
480!
[2311]481    USE print_control_mod, ONLY: lunout
[2371]482    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
[782]483! Input arguments
484!************************************************************************************
[1279]485    INTEGER, INTENT(IN)                              :: ktime
486    LOGICAL, INTENT(IN)                              :: last
[5654]487    REAL, DIMENSION(nbp_lon, jj_nb, maxsend_phys), INTENT(IN) :: tab_put
[782]488
489! Local variables
490!************************************************************************************
[987]491    LOGICAL                          :: checkout
492    INTEGER                          :: istart,iend
493    INTEGER                          :: wstart,wend
494    INTEGER                          :: ierror, i
[2346]495    REAL, DIMENSION(nbp_lon*jj_nb)       :: field
[987]496    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
497    CHARACTER (len = 80)             :: abort_message
[782]498
499!************************************************************************************
[987]500    checkout=.FALSE.
[782]501
[1279]502    WRITE(lunout,*) ' '
503    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
504    WRITE(lunout,*) 'last = ', last
505    WRITE(lunout,*)
[782]506
507
508    istart=ii_begin
[2429]509    IF (is_south_pole_dyn) THEN
[2346]510       iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
[782]511    ELSE
[2346]512       iend=(jj_end-jj_begin)*nbp_lon+ii_end
[782]513    ENDIF
514   
515    IF (checkout) THEN   
516       wstart=istart
517       wend=iend
[2429]518       IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
519       IF (is_south_pole_dyn) wend=iend-nbp_lon+1
[782]520       
[5654]521       DO i = 1, maxsend_phys
[1279]522          IF (infosend(i)%action) THEN
[2346]523             field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]524             CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
525          END IF
526       END DO
527    END IF
528
[782]529!************************************************************************************
530! PRISM_PUT
531!************************************************************************************
532
[5654]533    DO i = 1, maxsend_phys
[1965]534      IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
[2346]535          field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
[1279]536          CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
537         
538          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
539             .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
540             ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
541              WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime   
542              abort_message=' Problem in prism_put_proto '
[2311]543              CALL abort_physic(modname,abort_message,1)
[1279]544          ENDIF
545      ENDIF
[782]546    END DO
547   
548!************************************************************************************
549! Finalize PSMILE for the case is_sequential, if parallel finalization is done
550! from Finalize_parallel in dyn3dpar/parallel.F90
551!************************************************************************************
552
553    IF (last) THEN
554       IF (is_sequential) THEN
555          CALL prism_terminate_proto(ierror)
556          IF (ierror .NE. PRISM_Ok) THEN
[1279]557             abort_message=' Problem in prism_terminate_proto '
[2311]558             CALL abort_physic(modname,abort_message,1)
[782]559          ENDIF
560       ENDIF
561    ENDIF
562   
563   
564  END SUBROUTINE intocpl
565
566#endif
567 
568END MODULE oasis
Note: See TracBrowser for help on using the repository browser.