source: LMDZ6/branches/Amaury_dev/libf/phylmd/oasis.F90 @ 5202

Last change on this file since 5202 was 5158, checked in by abarral, 3 months ago

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