source: LMDZ6/branches/cirrus/libf/phylmd/oasis.F90 @ 5422

Last change on this file since 5422 was 4754, checked in by acozic, 13 months ago

Add possibility to coupled n2o between ocean and atmosphere

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