Context Navigation

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

Last change on this file since 6574 was 6574, checked in by acosce, 12 months ago
update with last version of ORCA1_LIM3_PISCES + fix typo error in SOURCES/LMDZ
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	#endif
366
367
368	!AC! Now, if also coupling CPL with INCA, initialize here fields to be exchanged.
369	!AC#ifdef CPP_CPLOCNINCA
370	!AC DO jf=1,maxrcv
371	!AC IF (inforcv(jf)%action) THEN
372	!AC CALL prism_def_var_proto(inforcv(jf)%nid, inforcv(jf)%name, il_part_id, &
373	!AC il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
374	!AC ierror)
375	!AC IF (ierror .NE. PRISM_Ok) THEN
376	!AC WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
377	!AC inforcv(jf)%name
378	!AC abort_message=' Problem in call to prism_def_var_proto for fields to receive'
379	!AC CALL abort_physic(modname,abort_message,1)
380	!AC ENDIF
381	!AC ENDIF
382	!AC END DO
383	!AC#endif
384
385	!************************************************************************************
386	! Atmospheric Fields to send
387	! Loop over all possible variables
388	!************************************************************************************
389	DO jf=1,maxsend
390	IF (infosend(jf)%action) THEN
391	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
392	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
393	ierror)
394	IF (ierror .NE. PRISM_Ok) THEN
395	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
396	infosend(jf)%name
397	abort_message=' Problem in call to prism_def_var_proto for fields to send'
398	CALL abort_physic(modname,abort_message,1)
399	ENDIF
400	ENDIF
401	END DO
402
403	!************************************************************************************
404	! End definition
405	!************************************************************************************
406	#ifdef CPP_XIOS
407	CALL xios_oasis_enddef()
408	#endif
409	CALL prism_enddef_proto(ierror)
410	IF (ierror .NE. PRISM_Ok) THEN
411	abort_message=' Problem in call to prism_endef_proto'
412	CALL abort_physic(modname,abort_message,1)
413	ELSE
414	WRITE(lunout,*) 'inicma : endef psmile ok '
415	ENDIF
416
417	#ifdef CPP_XIOS
418	! CALL wxios_context_init()
419	#endif
420
421	!$OMP END MASTER
422
423	END SUBROUTINE inicma
424
425	!
426	!************************************************************************************
427	!
428
429	SUBROUTINE fromcpl(ktime, tab_get)
430	! ======================================================================
431	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
432	! and Sea-Ice provided by the coupler. Adaptation to psmile library
433	!======================================================================
434	!
435	USE print_control_mod, ONLY: lunout
436	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
437	! Input arguments
438	!************************************************************************************
439	INTEGER, INTENT(IN) :: ktime
440
441	! Output arguments
442	!************************************************************************************
443	REAL, DIMENSION(nbp_lon, jj_nb,maxrecv_phys), INTENT(OUT) :: tab_get
444
445	! Local variables
446	!************************************************************************************
447	INTEGER :: ierror, i
448	INTEGER :: istart,iend
449	CHARACTER (len = 20) :: modname = 'fromcpl'
450	CHARACTER (len = 80) :: abort_message
451	REAL, DIMENSION(nbp_lon*jj_nb) :: field
452
453	!************************************************************************************
454	WRITE (lunout,*) ' '
455	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
456	WRITE (lunout,*) ' '
457
458	istart=ii_begin
459	IF (is_south_pole_dyn) THEN
460	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
461	ELSE
462	iend=(jj_end-jj_begin)*nbp_lon+ii_end
463	ENDIF
464
465	DO i = 1, maxrecv_phys
466	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
467	field(:) = -99999.
468	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
469	tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
470
471	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
472	ierror.NE.PRISM_FromRest &
473	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
474	.AND. ierror.NE.PRISM_FromRestOut) THEN
475	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
476	abort_message=' Problem in prism_get_proto '
477	CALL abort_physic(modname,abort_message,1)
478	ENDIF
479	ENDIF
480	END DO
481
482
483	END SUBROUTINE fromcpl
484
485	!
486	!************************************************************************************
487	!
488
489	SUBROUTINE intocpl(ktime, last, tab_put)
490	! ======================================================================
491	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
492	! atmospheric coupling fields to the coupler with the psmile library.
493	! IF last time step, writes output fields to binary files.
494	! ======================================================================
495	!
496	!
497	USE print_control_mod, ONLY: lunout
498	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
499	! Input arguments
500	!************************************************************************************
501	INTEGER, INTENT(IN) :: ktime
502	LOGICAL, INTENT(IN) :: last
503	REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
504
505	! Local variables
506	!************************************************************************************
507	LOGICAL :: checkout
508	INTEGER :: istart,iend
509	INTEGER :: wstart,wend
510	INTEGER :: ierror, i
511	REAL, DIMENSION(nbp_lon*jj_nb) :: field
512	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
513	CHARACTER (len = 80) :: abort_message
514
515	!************************************************************************************
516	checkout=.FALSE.
517
518	WRITE(lunout,*) ' '
519	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
520	WRITE(lunout,*) 'last = ', last
521	WRITE(lunout,*)
522
523
524	istart=ii_begin
525	IF (is_south_pole_dyn) THEN
526	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
527	ELSE
528	iend=(jj_end-jj_begin)*nbp_lon+ii_end
529	ENDIF
530
531	IF (checkout) THEN
532	wstart=istart
533	wend=iend
534	IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
535	IF (is_south_pole_dyn) wend=iend-nbp_lon+1
536
537	DO i = 1, maxsend
538	IF (infosend(i)%action) THEN
539	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
540	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
541	END IF
542	END DO
543	END IF
544
545	!************************************************************************************
546	! PRISM_PUT
547	!************************************************************************************
548
549	DO i = 1, maxsend
550	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
551	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
552	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
553
554	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
555	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
556	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
557	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
558	abort_message=' Problem in prism_put_proto '
559	CALL abort_physic(modname,abort_message,1)
560	ENDIF
561	ENDIF
562	END DO
563
564	!************************************************************************************
565	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
566	! from Finalize_parallel in dyn3dpar/parallel.F90
567	!************************************************************************************
568
569	IF (last) THEN
570	IF (is_sequential) THEN
571	CALL prism_terminate_proto(ierror)
572	IF (ierror .NE. PRISM_Ok) THEN
573	abort_message=' Problem in prism_terminate_proto '
574	CALL abort_physic(modname,abort_message,1)
575	ENDIF
576	ENDIF
577	ENDIF
578
579
580	END SUBROUTINE intocpl
581
582	#endif
583
584	END MODULE oasis

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

Download in other formats: