source: LMDZ6/branches/LMDZ_ECRad/libf/phylmd/oasis.F90 @ 4812

Last change on this file since 4812 was 4727, checked in by idelkadi, 13 months ago

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