Context Navigation

oasis.F90 @ 5133

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

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

Download in other formats:

Original Format