Context Navigation

oasis.F90 @ 5248

Last change on this file since 5248 was 4754, checked in by acozic, 13 months ago
Add possibility to coupled n2o between ocean and atmosphere
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 22.3 KB

Line
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_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	INTEGER, PARAMETER :: idr_ocen2o = 11
80
81	INTEGER, PARAMETER :: maxrecv = 11 ! Maximum number of fields to receive
82	INTEGER, PARAMETER :: maxrecv_phys = 9 ! Maximum number of fields to receive in physiq (without fields received in INCA model )
83	! will be changed in next version - INCA fields will be received in LMDZ (like for ORCHIDEE fields)
84	! and then send by routine in INCA model
85
86
87	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
88	CHARACTER(len = 8) :: name ! Name of the coupling field
89	LOGICAL :: action ! To be exchanged or not
90	INTEGER :: nid ! Id of the field
91	END TYPE FLD_CPL
92
93	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
94	!$OMP THREADPRIVATE(infosend)
95	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
96	!$OMP THREADPRIVATE(inforecv)
97
98	LOGICAL,SAVE :: cpl_current
99	!$OMP THREADPRIVATE(cpl_current)
100
101	#ifdef CPP_COUPLE
102
103	CONTAINS
104
105	SUBROUTINE inicma
106	!************************************************************************************
107	!**** INICMA - Initialize coupled mode communication for atmosphere
108	! and exchange some initial information with Oasis
109	!
110	! Rewrite to take the PRISM/psmile library into account
111	! LF 09/2003
112	!
113	USE IOIPSL
114	USE surface_data, ONLY : version_ocean
115	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
116	USE wxios, ONLY : wxios_context_init
117	USE chemistry_cycle_mod, ONLY : dms_cycle_cpl, n2o_cycle_cpl
118	USE lmdz_xios
119	USE print_control_mod, ONLY: lunout
120	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat
121	USE geometry_mod, ONLY: ind_cell_glo
122	USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb
123	use config_ocean_skin_m, only: activate_ocean_skin
124
125	! Local variables
126	!************************************************************************************
127	INTEGER :: comp_id
128	INTEGER :: ierror, il_commlocal
129	INTEGER :: il_part_id
130	INTEGER, ALLOCATABLE :: ig_paral(:)
131	INTEGER, DIMENSION(2) :: il_var_nodims
132	INTEGER, DIMENSION(4) :: il_var_actual_shape
133	INTEGER :: il_var_type
134	INTEGER :: jf
135	CHARACTER (len = 6) :: clmodnam
136	CHARACTER (len = 20) :: modname = 'inicma'
137	CHARACTER (len = 80) :: abort_message
138	LOGICAL, SAVE :: cpl_current_omp
139	INTEGER, DIMENSION(klon_mpi) :: ind_cell_glo_mpi
140
141	!* 1. Initializations
142	! ---------------
143	!************************************************************************************
144	WRITE(lunout,*) ' '
145	WRITE(lunout,*) ' '
146	WRITE(lunout,*) ' ROUTINE INICMA'
147	WRITE(lunout,) ' *************'
148	WRITE(lunout,*) ' '
149	WRITE(lunout,*) ' '
150
151	!
152	! Define the model name
153	!
154	IF (grid_type==unstructured) THEN
155	clmodnam = 'icosa' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
156	ELSE IF (grid_type==regular_lonlat) THEN
157	clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
158	ELSE
159	abort_message='Pb : type of grid unknown'
160	CALL abort_physic(modname,abort_message,1)
161	ENDIF
162
163
164	!************************************************************************************
165	! Define if coupling ocean currents or not
166	!************************************************************************************
167	!$OMP MASTER
168	cpl_current_omp = .FALSE.
169	CALL getin('cpl_current', cpl_current_omp)
170	!$OMP END MASTER
171	!$OMP BARRIER
172	cpl_current = cpl_current_omp
173	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
174
175	!************************************************************************************
176	! Gather global index to be used for oasis decomposition
177	!************************************************************************************
178	CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi)
179
180	!************************************************************************************
181	! Define coupling variables
182	!************************************************************************************
183
184	! Atmospheric variables to send
185
186	!$OMP MASTER
187	infosend(:)%action = .FALSE.
188
189	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
190	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
191	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
192	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
193	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
194	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
195	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
196	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
197	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
198	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
199	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
200
201	if (activate_ocean_skin == 2) then
202	infosend(ids_delta_sst)%action = .TRUE.
203	infosend(ids_delta_sst)%name = 'CODELSST'
204	infosend(ids_delta_sal)%action = .TRUE.
205	infosend(ids_delta_sal)%name = 'CODELSSS'
206	infosend(ids_dter)%action = .TRUE.
207	infosend(ids_dter)%name = 'CODELTER'
208	infosend(ids_dser)%action = .TRUE.
209	infosend(ids_dser)%name = 'CODELSER'
210	infosend(ids_dt_ds)%action = .TRUE.
211	infosend(ids_dt_ds)%name = 'CODTDS'
212	end if
213
214	IF (version_ocean=='nemo') THEN
215	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
216	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
217	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
218	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
219	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
220	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
221	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
222	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
223	IF (carbon_cycle_cpl) THEN
224	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
225	ENDIF
226	infosend(ids_qraioc)%action = .TRUE. ; infosend(ids_qraioc)%name = 'COQRAIOC'
227	infosend(ids_qsnooc)%action = .TRUE. ; infosend(ids_qsnooc)%name = 'COQSNOOC'
228	infosend(ids_qraiic)%action = .TRUE. ; infosend(ids_qraiic)%name = 'COQRAIIC'
229	infosend(ids_qsnoic)%action = .TRUE. ; infosend(ids_qsnoic)%name = 'COQSNOIC'
230
231	ELSE IF (version_ocean=='opa8') THEN
232	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
233	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
234	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
235	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
236	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
237	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
238	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
239	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
240	ENDIF
241
242	! Oceanic variables to receive
243
244	inforecv(:)%action = .FALSE.
245
246	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
247	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
248	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
249	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
250
251	if (activate_ocean_skin >= 1) then
252	inforecv(idr_sss)%action = .TRUE.
253	inforecv(idr_sss)%name = 'SISUSALW'
254	end if
255
256	IF (cpl_current ) THEN
257	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
258	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
259	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
260	ENDIF
261
262	IF (carbon_cycle_cpl ) THEN
263	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
264	ENDIF
265	IF (dms_cycle_cpl) THEN
266	inforecv(idr_ocedms)%action = .TRUE. ; inforecv(idr_ocedms)%name = 'SIDMSFLX'
267	ENDIF
268	IF (n2o_cycle_cpl) THEN
269	inforecv(idr_ocen2o)%action = .TRUE. ; inforecv(idr_ocen2o)%name = 'SIN2OFLX'
270	ENDIF
271
272
273	!************************************************************************************
274	! Here we go: psmile initialisation
275	!************************************************************************************
276	IF (is_sequential) THEN
277	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
278
279	IF (ierror .NE. PRISM_Ok) THEN
280	abort_message=' Probleme init dans prism_init_comp '
281	CALL abort_physic(modname,abort_message,1)
282	ELSE
283	WRITE(lunout,*) 'inicma : init psmile ok '
284	ENDIF
285	ENDIF
286
287	CALL prism_get_localcomm_proto (il_commlocal, ierror)
288	!************************************************************************************
289	! Domain decomposition
290	!************************************************************************************
291	IF (grid_type==unstructured) THEN
292
293	ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) )
294
295	ig_paral(1) = 4 ! points partition for //
296	ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells
297
298	DO jf=1, klon_mpi_para_nb(mpi_rank)
299	ig_paral(2+jf) = ind_cell_glo_mpi(jf)
300	ENDDO
301
302	ELSE IF (grid_type==regular_lonlat) THEN
303
304	ALLOCATE( ig_paral(3) )
305
306	ig_paral(1) = 1 ! apple partition for //
307	ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset
308	ig_paral(3) = (jj_endnbp_lon+ii_end) - (jj_beginnbp_lon+ii_begin) + 1
309
310	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
311	ELSE
312	abort_message='Pb : type of grid unknown'
313	CALL abort_physic(modname,abort_message,1)
314	ENDIF
315
316
317	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
318
319	ierror=PRISM_Ok
320	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
321
322	IF (ierror .NE. PRISM_Ok) THEN
323	abort_message=' Probleme dans prism_def_partition '
324	CALL abort_physic(modname,abort_message,1)
325	ELSE
326	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
327	ENDIF
328
329	il_var_nodims(1) = 2 ! rank of field array (1d or 2d)
330	il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18
331
332	il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1)
333	il_var_actual_shape(2) = nbp_lon ! max of 1st dimension
334	il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1)
335	il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension
336
337	il_var_type = PRISM_Real
338
339	!************************************************************************************
340	! Oceanic Fields to receive
341	! Loop over all possible variables
342	!************************************************************************************
343	DO jf=1, maxrecv
344	IF (inforecv(jf)%action) THEN
345	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
346	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
347	ierror)
348	IF (ierror .NE. PRISM_Ok) THEN
349	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
350	inforecv(jf)%name
351	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
352	CALL abort_physic(modname,abort_message,1)
353	ENDIF
354	ENDIF
355	END DO
356
357
358	#ifdef INCA
359	IF (dms_cycle_cpl .OR. n2o_cycle_cpl) THEN
360	CALL init_inca_oasis(inforecv(idr_ocedms:idr_ocen2o))
361	ENDIF
362	#endif
363
364	!************************************************************************************
365	! Atmospheric Fields to send
366	! Loop over all possible variables
367	!************************************************************************************
368	DO jf=1,maxsend
369	IF (infosend(jf)%action) THEN
370	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
371	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
372	ierror)
373	IF (ierror .NE. PRISM_Ok) THEN
374	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
375	infosend(jf)%name
376	abort_message=' Problem in call to prism_def_var_proto for fields to send'
377	CALL abort_physic(modname,abort_message,1)
378	ENDIF
379	ENDIF
380	END DO
381
382	!************************************************************************************
383	! End definition
384	!************************************************************************************
385
386	IF (using_xios) CALL xios_oasis_enddef()
387
388	CALL prism_enddef_proto(ierror)
389	IF (ierror .NE. PRISM_Ok) THEN
390	abort_message=' Problem in call to prism_endef_proto'
391	CALL abort_physic(modname,abort_message,1)
392	ELSE
393	WRITE(lunout,*) 'inicma : endef psmile ok '
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
559	END MODULE oasis

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

Download in other formats:

Original Format