Context Navigation

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

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

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

Download in other formats: