Context Navigation

oasis.F90 @ 3628

Last change on this file since 3628 was 3628, checked in by lguez, 5 years ago
If the ocean skin parameterization is working actively (`activate_ocean_skin == 2`) and we are coupled to the ocean then send ocean-air interface salinity to the ocean. New dummy argument `s_int` of procedures `ocean_cpl_noice` and `cpl_send_ocean_fields`. We can only send interface salinity from the previous time-step since communication with the ocean is before the call to bulk_flux. So make `s_int` a state variable: move `s_int` from `phys_output_var_mod` to `phys_state_var_mod`. Still, we only read `s_int` from startphy, define it before the call to `surf_ocean` and write it to restartphy if `activate_ocean_skin == 2` and `type_ocean == 'couple'`. In procedure `pbl_surface`, for clarity, move the definition of output variables `t_int`, dter, dser, tkt, tks, rf, taur to `missing_val` to after the call to `surf_ocean`, with the definition of `s_int`, `ds_ns`, `dt_ns` to `missing_val`. This does not change anything for `t_int`, dter, dser, tkt, tks, rf, taur. In `pbl_surface_newfrac`, we choose to set `s_int` to 35 for an appearing ocean point, this is questionable. In `surf_ocean`, change the intent of `s_int` from out to inout.
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: 20.8 KB

Line
1	!
2	MODULE 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_t_int = 30, ids_s_int = 31
62
63	INTEGER, PARAMETER :: maxsend = 31 ! 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
76	INTEGER, PARAMETER :: idr_sss = 9
77	! bulk salinity of the surface layer of the ocean, in ppt
78
79	INTEGER, PARAMETER :: maxrecv = 9 ! Maximum number of fields to receive
80
81
82	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
83	CHARACTER(len = 8) :: name ! Name of the coupling field
84	LOGICAL :: action ! To be exchanged or not
85	INTEGER :: nid ! Id of the field
86	END TYPE FLD_CPL
87
88	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
89	!$OMP THREADPRIVATE(infosend)
90	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
91	!$OMP THREADPRIVATE(inforecv)
92
93	LOGICAL,SAVE :: cpl_current
94	!$OMP THREADPRIVATE(cpl_current)
95
96	#ifdef CPP_COUPLE
97
98	CONTAINS
99
100	SUBROUTINE inicma
101	!************************************************************************************
102	!**** INICMA - Initialize coupled mode communication for atmosphere
103	! and exchange some initial information with Oasis
104	!
105	! Rewrite to take the PRISM/psmile library into account
106	! LF 09/2003
107	!
108	USE IOIPSL
109	USE surface_data, ONLY : version_ocean
110	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
111	#ifdef CPP_XIOS
112	USE wxios, ONLY : wxios_context_init
113	USE xios
114	#endif
115	USE print_control_mod, ONLY: lunout
116	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
117	USE geometry_mod, ONLY: ind_cell_glo
118	USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
119
120
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_t_int)%action = .TRUE.
194	infosend(ids_t_int)%name = 'T_int'
195	infosend(ids_s_int)%action = .TRUE.
196	infosend(ids_s_int)%name = 'S_int'
197	end if
198
199	IF (version_ocean=='nemo') THEN
200	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
201	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
202	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
203	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
204	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
205	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
206	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
207	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
208	IF (carbon_cycle_cpl) THEN
209	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
210	ENDIF
211	infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
212	infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
213	infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
214	infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
215
216	ELSE IF (version_ocean=='opa8') THEN
217	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
218	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
219	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
220	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
221	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
222	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
223	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
224	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
225	ENDIF
226
227	! Oceanic variables to receive
228
229	inforecv(:)%action = .FALSE.
230
231	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
232	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
233	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
234	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
235
236	if (activate_ocean_skin >= 1) then
237	inforecv(idr_sss)%action = .TRUE.
238	inforecv(idr_sss)%name = 'salinity'
239	end if
240
241	IF (cpl_current ) THEN
242	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
243	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
244	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
245	ENDIF
246
247	IF (carbon_cycle_cpl ) THEN
248	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
249	ENDIF
250
251	!************************************************************************************
252	! Here we go: psmile initialisation
253	!************************************************************************************
254	IF (is_sequential) THEN
255	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
256
257	IF (ierror .NE. PRISM_Ok) THEN
258	abort_message=' Probleme init dans prism_init_comp '
259	CALL abort_physic(modname,abort_message,1)
260	ELSE
261	WRITE(lunout,*) 'inicma : init psmile ok '
262	ENDIF
263	ENDIF
264
265	CALL prism_get_localcomm_proto (il_commlocal, ierror)
266	!************************************************************************************
267	! Domain decomposition
268	!************************************************************************************
269	IF (grid_type==unstructured) THEN
270
271	ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
272
273	ig_paral(1) = 4 ! points partition for //
274	ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells
275
276	DO jf=1, klon_mpi_para_nb(mpi_rank)
277	ig_paral(2+jf) = ind_cell_glo(jf)
278	ENDDO
279
280	ELSE IF (grid_type==regular_lonlat) THEN
281
282	ALLOCATE( ig_paral(3) )
283
284	ig_paral(1) = 1 ! apple partition for //
285	ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset
286	ig_paral(3) = (jj_endnbp_lon+ii_end) - (jj_beginnbp_lon+ii_begin) + 1
287
288	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
289	ELSE
290	abort_message='Pb : type of grid unknown'
291	CALL abort_physic(modname,abort_message,1)
292	ENDIF
293
294
295	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
296
297	ierror=PRISM_Ok
298	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
299
300	IF (ierror .NE. PRISM_Ok) THEN
301	abort_message=' Probleme dans prism_def_partition '
302	CALL abort_physic(modname,abort_message,1)
303	ELSE
304	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
305	ENDIF
306
307	il_var_nodims(1) = 2 ! rank of field array (1d or 2d)
308	il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18
309
310	il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1)
311	il_var_actual_shape(2) = nbp_lon ! max of 1st dimension
312	il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1)
313	il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension
314
315	il_var_type = PRISM_Real
316
317	!************************************************************************************
318	! Oceanic Fields to receive
319	! Loop over all possible variables
320	!************************************************************************************
321	DO jf=1, maxrecv
322	IF (inforecv(jf)%action) THEN
323	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
324	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
325	ierror)
326	IF (ierror .NE. PRISM_Ok) THEN
327	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
328	inforecv(jf)%name
329	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
330	CALL abort_physic(modname,abort_message,1)
331	ENDIF
332	ENDIF
333	END DO
334
335	!************************************************************************************
336	! Atmospheric Fields to send
337	! Loop over all possible variables
338	!************************************************************************************
339	DO jf=1,maxsend
340	IF (infosend(jf)%action) THEN
341	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
342	il_var_nodims, PRISM_Out, 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	infosend(jf)%name
347	abort_message=' Problem in call to prism_def_var_proto for fields to send'
348	CALL abort_physic(modname,abort_message,1)
349	ENDIF
350	ENDIF
351	END DO
352
353	!************************************************************************************
354	! End definition
355	!************************************************************************************
356	#ifdef CPP_XIOS
357	CALL xios_oasis_enddef()
358	#endif
359	CALL prism_enddef_proto(ierror)
360	IF (ierror .NE. PRISM_Ok) THEN
361	abort_message=' Problem in call to prism_endef_proto'
362	CALL abort_physic(modname,abort_message,1)
363	ELSE
364	WRITE(lunout,*) 'inicma : endef psmile ok '
365	ENDIF
366
367	#ifdef CPP_XIOS
368	! CALL wxios_context_init()
369	#endif
370
371	!$OMP END MASTER
372
373	END SUBROUTINE inicma
374
375	!
376	!************************************************************************************
377	!
378
379	SUBROUTINE fromcpl(ktime, tab_get)
380	! ======================================================================
381	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
382	! and Sea-Ice provided by the coupler. Adaptation to psmile library
383	!======================================================================
384	!
385	USE print_control_mod, ONLY: lunout
386	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
387	! Input arguments
388	!************************************************************************************
389	INTEGER, INTENT(IN) :: ktime
390
391	! Output arguments
392	!************************************************************************************
393	REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get
394
395	! Local variables
396	!************************************************************************************
397	INTEGER :: ierror, i
398	INTEGER :: istart,iend
399	CHARACTER (len = 20) :: modname = 'fromcpl'
400	CHARACTER (len = 80) :: abort_message
401	REAL, DIMENSION(nbp_lon*jj_nb) :: field
402
403	!************************************************************************************
404	WRITE (lunout,*) ' '
405	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
406	WRITE (lunout,*) ' '
407
408	istart=ii_begin
409	IF (is_south_pole_dyn) THEN
410	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
411	ELSE
412	iend=(jj_end-jj_begin)*nbp_lon+ii_end
413	ENDIF
414
415	DO i = 1, maxrecv
416	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
417	field(:) = -99999.
418	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
419	tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
420
421	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
422	ierror.NE.PRISM_FromRest &
423	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
424	.AND. ierror.NE.PRISM_FromRestOut) THEN
425	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
426	abort_message=' Problem in prism_get_proto '
427	CALL abort_physic(modname,abort_message,1)
428	ENDIF
429	ENDIF
430	END DO
431
432
433	END SUBROUTINE fromcpl
434
435	!
436	!************************************************************************************
437	!
438
439	SUBROUTINE intocpl(ktime, last, tab_put)
440	! ======================================================================
441	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
442	! atmospheric coupling fields to the coupler with the psmile library.
443	! IF last time step, writes output fields to binary files.
444	! ======================================================================
445	!
446	!
447	USE print_control_mod, ONLY: lunout
448	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
449	! Input arguments
450	!************************************************************************************
451	INTEGER, INTENT(IN) :: ktime
452	LOGICAL, INTENT(IN) :: last
453	REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
454
455	! Local variables
456	!************************************************************************************
457	LOGICAL :: checkout
458	INTEGER :: istart,iend
459	INTEGER :: wstart,wend
460	INTEGER :: ierror, i
461	REAL, DIMENSION(nbp_lon*jj_nb) :: field
462	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
463	CHARACTER (len = 80) :: abort_message
464
465	!************************************************************************************
466	checkout=.FALSE.
467
468	WRITE(lunout,*) ' '
469	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
470	WRITE(lunout,*) 'last = ', last
471	WRITE(lunout,*)
472
473
474	istart=ii_begin
475	IF (is_south_pole_dyn) THEN
476	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
477	ELSE
478	iend=(jj_end-jj_begin)*nbp_lon+ii_end
479	ENDIF
480
481	IF (checkout) THEN
482	wstart=istart
483	wend=iend
484	IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
485	IF (is_south_pole_dyn) wend=iend-nbp_lon+1
486
487	DO i = 1, maxsend
488	IF (infosend(i)%action) THEN
489	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
490	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
491	END IF
492	END DO
493	END IF
494
495	!************************************************************************************
496	! PRISM_PUT
497	!************************************************************************************
498
499	DO i = 1, maxsend
500	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
501	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
502	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
503
504	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
505	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
506	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
507	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
508	abort_message=' Problem in prism_put_proto '
509	CALL abort_physic(modname,abort_message,1)
510	ENDIF
511	ENDIF
512	END DO
513
514	!************************************************************************************
515	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
516	! from Finalize_parallel in dyn3dpar/parallel.F90
517	!************************************************************************************
518
519	IF (last) THEN
520	IF (is_sequential) THEN
521	CALL prism_terminate_proto(ierror)
522	IF (ierror .NE. PRISM_Ok) THEN
523	abort_message=' Problem in prism_terminate_proto '
524	CALL abort_physic(modname,abort_message,1)
525	ENDIF
526	ENDIF
527	ENDIF
528
529
530	END SUBROUTINE intocpl
531
532	#endif
533
534	END MODULE oasis

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format