Context Navigation

oasis.F90 @ 5791

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

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

Download in other formats:

Original Format