Context Navigation

source: CONFIG/UNIFORM/v7/IPSLCM7/SOURCES/LMDZ/oasis.F90 @ 6554

Last change on this file since 6554 was 6445, checked in by aclsce, 14 months ago

Modified to be able to work with

LMDZ testing rev 4515
ORCHIDEE rev 7991
ICOSA_LMDZ rev 4501
DYNAMICO rev 3558d704

Removed SOURCES not needed anymore due to the use above revisions.

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

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

Download in other formats: