source: LMDZ6/branches/Ocean_skin/libf/phylmd/oasis.F90 @ 4036

Last change on this file since 4036 was 4020, checked in by lguez, 3 years ago

Send 3 more fields to the ocean

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