Context Navigation

oasis.F90 @ 4350

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

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

Download in other formats:

Original Format