source: CONFIG/UNIFORM/v6/IPSLCM6.3/SOURCES/LMDZ/oasis.F90

Last change on this file was 6584, checked in by acosce, 11 months ago

update configuration to add coupled experiment with inca(AER) + CO2 in lmdz and pisces + coupling of co2 and dms between oce ant atm

File size: 21.8 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!AC#ifdef CPP_CPLOCNINCA
28!AC  USE incaoasis, ONLY : inforcv
29!AC#endif
30#endif
31 
32  IMPLICIT NONE
33 
34  ! Id for fields sent to ocean
35  INTEGER, PARAMETER :: ids_tauxxu = 1
36  INTEGER, PARAMETER :: ids_tauyyu = 2
37  INTEGER, PARAMETER :: ids_tauzzu = 3
38  INTEGER, PARAMETER :: ids_tauxxv = 4
39  INTEGER, PARAMETER :: ids_tauyyv = 5
40  INTEGER, PARAMETER :: ids_tauzzv = 6
41  INTEGER, PARAMETER :: ids_windsp = 7
42  INTEGER, PARAMETER :: ids_shfice = 8
43  INTEGER, PARAMETER :: ids_shfoce = 9
44  INTEGER, PARAMETER :: ids_shftot = 10
45  INTEGER, PARAMETER :: ids_nsfice = 11
46  INTEGER, PARAMETER :: ids_nsfoce = 12
47  INTEGER, PARAMETER :: ids_nsftot = 13
48  INTEGER, PARAMETER :: ids_dflxdt = 14
49  INTEGER, PARAMETER :: ids_totrai = 15
50  INTEGER, PARAMETER :: ids_totsno = 16
51  INTEGER, PARAMETER :: ids_toteva = 17
52  INTEGER, PARAMETER :: ids_icevap = 18
53  INTEGER, PARAMETER :: ids_ocevap = 19
54  INTEGER, PARAMETER :: ids_calvin = 20
55  INTEGER, PARAMETER :: ids_liqrun = 21
56  INTEGER, PARAMETER :: ids_runcoa = 22
57  INTEGER, PARAMETER :: ids_rivflu = 23
58  INTEGER, PARAMETER :: ids_atmco2 = 24
59  INTEGER, PARAMETER :: ids_taumod = 25
60  INTEGER, PARAMETER :: ids_qraioc = 26
61  INTEGER, PARAMETER :: ids_qsnooc = 27
62  INTEGER, PARAMETER :: ids_qraiic = 28
63  INTEGER, PARAMETER :: ids_qsnoic = 29
64  INTEGER, PARAMETER :: ids_delta_sst = 30, ids_delta_sal = 31, ids_dter = 32, &
65       ids_dser = 33, ids_dt_ds = 34
66 
67  INTEGER, PARAMETER :: maxsend    = 34  ! Maximum number of fields to send
68 
69  ! Id for fields received from ocean
70
71  INTEGER, PARAMETER :: idr_sisutw = 1
72  INTEGER, PARAMETER :: idr_icecov = 2
73  INTEGER, PARAMETER :: idr_icealw = 3
74  INTEGER, PARAMETER :: idr_icetem = 4
75  INTEGER, PARAMETER :: idr_curenx = 5
76  INTEGER, PARAMETER :: idr_cureny = 6
77  INTEGER, PARAMETER :: idr_curenz = 7
78  INTEGER, PARAMETER :: idr_oceco2 = 8
79
80  INTEGER, PARAMETER :: idr_sss = 9
81  INTEGER, PARAMETER :: idr_ocedms = 10
82  ! bulk salinity of the surface layer of the ocean, in ppt
83
84!AC  INTEGER, PARAMETER :: maxrecv    = 9  ! Maximum number of fields to receive
85  INTEGER, PARAMETER :: maxrecv      = 10  ! Maximum number of fields to receive
86  INTEGER, PARAMETER :: maxrecv_phys = 9      ! Maximum number of fields to receive in physiq (without fields receive in inca model)
87 
88
89  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
90     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
91     LOGICAL            ::   action    ! To be exchanged or not
92     INTEGER            ::   nid       ! Id of the field
93  END TYPE FLD_CPL
94
95  TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend   ! Information for sending coupling fields
96!$OMP THREADPRIVATE(infosend)
97  TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv   ! Information for receiving coupling fields
98!$OMP THREADPRIVATE(inforecv)
99 
100  LOGICAL,SAVE :: cpl_current
101!$OMP THREADPRIVATE(cpl_current)
102
103#ifdef CPP_COUPLE
104
105CONTAINS
106
107  SUBROUTINE inicma
108!************************************************************************************
109!**** *INICMA*  - Initialize coupled mode communication for atmosphere
110!                 and exchange some initial information with Oasis
111!
112!     Rewrite to take the PRISM/psmile library into account
113!     LF 09/2003
114!
115    USE IOIPSL
116    USE surface_data, ONLY : version_ocean
117    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
118    USE chemistry_cycle_mod, ONLY : dms_cycle_cpl
119#ifdef CPP_XIOS
120    USE wxios, ONLY : wxios_context_init 
121    USE xios 
122#endif
123    USE print_control_mod, ONLY: lunout
124    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
125    USE geometry_mod, ONLY: ind_cell_glo                   
126    USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
127    use config_ocean_skin_m, only: activate_ocean_skin
128
129! Local variables
130!************************************************************************************
131    INTEGER                            :: comp_id
132    INTEGER                            :: ierror, il_commlocal
133    INTEGER                            :: il_part_id
134    INTEGER, ALLOCATABLE               :: ig_paral(:)
135    INTEGER, DIMENSION(2)              :: il_var_nodims
136    INTEGER, DIMENSION(4)              :: il_var_actual_shape
137    INTEGER                            :: il_var_type
138    INTEGER                            :: jf
139    CHARACTER (len = 6)                :: clmodnam
140    CHARACTER (len = 20)               :: modname = 'inicma'
141    CHARACTER (len = 80)               :: abort_message 
142    LOGICAL, SAVE                      :: cpl_current_omp
143
144!*    1. Initializations
145!        ---------------
146!************************************************************************************
147    WRITE(lunout,*) ' '
148    WRITE(lunout,*) ' '
149    WRITE(lunout,*) ' ROUTINE INICMA'
150    WRITE(lunout,*) ' **************'
151    WRITE(lunout,*) ' '
152    WRITE(lunout,*) ' '
153
154!
155! Define the model name
156!
157    IF (grid_type==unstructured) THEN
158        clmodnam = 'icosa'                 ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
159    ELSE IF (grid_type==regular_lonlat) THEN
160        clmodnam = 'LMDZ'                  ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
161    ELSE
162        abort_message='Pb : type of grid unknown'
163        CALL abort_physic(modname,abort_message,1)
164    ENDIF
165
166
167!************************************************************************************
168! Define if coupling ocean currents or not
169!************************************************************************************
170!$OMP MASTER
171    cpl_current_omp = .FALSE.
172    CALL getin('cpl_current', cpl_current_omp)
173!$OMP END MASTER
174!$OMP BARRIER
175    cpl_current = cpl_current_omp
176    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current 
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 
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(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: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#ifdef CPP_XIOS
382    CALL xios_oasis_enddef()
383#endif
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#ifdef CPP_XIOS
393!    CALL wxios_context_init()
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.