Context Navigation

oasis.F90 @ 5360

Last change on this file since 5360 was 2429, checked in by Laurent Fairhead, 9 years ago
Correction on the calculation of the surface of the grid at the poles (problem was introduced in r2222). Due to the different distribution of OMP tasks in the dynamics and the physics, had to introduce 2 new logical variables, is_pole_north_phy and is_pole_south_phy, and so decided to rename the old is_north_pole/is_south_pole to is_north_pole_dyn/is_south_pole_dyn to stay coherent and, hopefully, clear things up a bit. LF
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:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 18.4 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	#endif
28
29	IMPLICIT NONE
30
31	! Id for fields sent to ocean
32	INTEGER, PARAMETER :: ids_tauxxu = 1
33	INTEGER, PARAMETER :: ids_tauyyu = 2
34	INTEGER, PARAMETER :: ids_tauzzu = 3
35	INTEGER, PARAMETER :: ids_tauxxv = 4
36	INTEGER, PARAMETER :: ids_tauyyv = 5
37	INTEGER, PARAMETER :: ids_tauzzv = 6
38	INTEGER, PARAMETER :: ids_windsp = 7
39	INTEGER, PARAMETER :: ids_shfice = 8
40	INTEGER, PARAMETER :: ids_shfoce = 9
41	INTEGER, PARAMETER :: ids_shftot = 10
42	INTEGER, PARAMETER :: ids_nsfice = 11
43	INTEGER, PARAMETER :: ids_nsfoce = 12
44	INTEGER, PARAMETER :: ids_nsftot = 13
45	INTEGER, PARAMETER :: ids_dflxdt = 14
46	INTEGER, PARAMETER :: ids_totrai = 15
47	INTEGER, PARAMETER :: ids_totsno = 16
48	INTEGER, PARAMETER :: ids_toteva = 17
49	INTEGER, PARAMETER :: ids_icevap = 18
50	INTEGER, PARAMETER :: ids_ocevap = 19
51	INTEGER, PARAMETER :: ids_calvin = 20
52	INTEGER, PARAMETER :: ids_liqrun = 21
53	INTEGER, PARAMETER :: ids_runcoa = 22
54	INTEGER, PARAMETER :: ids_rivflu = 23
55	INTEGER, PARAMETER :: ids_atmco2 = 24
56	INTEGER, PARAMETER :: ids_taumod = 25
57	INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send
58
59	! Id for fields received from ocean
60	INTEGER, PARAMETER :: idr_sisutw = 1
61	INTEGER, PARAMETER :: idr_icecov = 2
62	INTEGER, PARAMETER :: idr_icealw = 3
63	INTEGER, PARAMETER :: idr_icetem = 4
64	INTEGER, PARAMETER :: idr_curenx = 5
65	INTEGER, PARAMETER :: idr_cureny = 6
66	INTEGER, PARAMETER :: idr_curenz = 7
67	INTEGER, PARAMETER :: idr_oceco2 = 8
68	INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive
69
70
71	TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information
72	CHARACTER(len = 8) :: name ! Name of the coupling field
73	LOGICAL :: action ! To be exchanged or not
74	INTEGER :: nid ! Id of the field
75	END TYPE FLD_CPL
76
77	TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields
78	TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields
79
80	LOGICAL,SAVE :: cpl_current
81	!$OMP THREADPRIVATE(cpl_current)
82
83	#ifdef CPP_COUPLE
84
85	CONTAINS
86
87	SUBROUTINE inicma
88	!************************************************************************************
89	!**** INICMA - Initialize coupled mode communication for atmosphere
90	! and exchange some initial information with Oasis
91	!
92	! Rewrite to take the PRISM/psmile library into account
93	! LF 09/2003
94	!
95	USE IOIPSL
96	USE surface_data, ONLY : version_ocean
97	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
98	#ifdef CPP_XIOS
99	USE wxios, ONLY : wxios_context_init
100	#endif
101	USE print_control_mod, ONLY: lunout
102	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
103
104	! Local variables
105	!************************************************************************************
106	INTEGER :: comp_id
107	INTEGER :: ierror, il_commlocal
108	INTEGER :: il_part_id
109	INTEGER, DIMENSION(3) :: ig_paral
110	INTEGER, DIMENSION(2) :: il_var_nodims
111	INTEGER, DIMENSION(4) :: il_var_actual_shape
112	INTEGER :: il_var_type
113	INTEGER :: jf
114	CHARACTER (len = 6) :: clmodnam
115	CHARACTER (len = 20) :: modname = 'inicma'
116	CHARACTER (len = 80) :: abort_message
117	LOGICAL, SAVE :: cpl_current_omp
118
119	!* 1. Initializations
120	! ---------------
121	!************************************************************************************
122	WRITE(lunout,*) ' '
123	WRITE(lunout,*) ' '
124	WRITE(lunout,*) ' ROUTINE INICMA'
125	WRITE(lunout,) ' *************'
126	WRITE(lunout,*) ' '
127	WRITE(lunout,*) ' '
128
129	!
130	! Define the model name
131	!
132	clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
133
134
135	!************************************************************************************
136	! Define if coupling ocean currents or not
137	!************************************************************************************
138	!$OMP MASTER
139	cpl_current_omp = .FALSE.
140	CALL getin('cpl_current', cpl_current_omp)
141	!$OMP END MASTER
142	!$OMP BARRIER
143	cpl_current = cpl_current_omp
144	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
145
146	!************************************************************************************
147	! Define coupling variables
148	!************************************************************************************
149
150	! Atmospheric variables to send
151
152	!$OMP MASTER
153	infosend(:)%action = .FALSE.
154
155	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
156	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
157	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
158	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
159	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
160	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
161	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
162	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
163	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
164	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
165	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
166
167	IF (version_ocean=='nemo') THEN
168	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
169	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
170	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
171	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
172	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
173	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
174	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
175	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
176	IF (carbon_cycle_cpl) THEN
177	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
178	ENDIF
179
180	ELSE IF (version_ocean=='opa8') THEN
181	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
182	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
183	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
184	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
185	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
186	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
187	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
188	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
189	ENDIF
190
191	! Oceanic variables to receive
192
193	inforecv(:)%action = .FALSE.
194
195	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
196	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
197	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
198	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
199
200	IF (cpl_current ) THEN
201	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
202	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
203	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
204	ENDIF
205
206	IF (carbon_cycle_cpl ) THEN
207	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
208	ENDIF
209
210	!************************************************************************************
211	! Here we go: psmile initialisation
212	!************************************************************************************
213	IF (is_sequential) THEN
214	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
215
216	IF (ierror .NE. PRISM_Ok) THEN
217	abort_message=' Probleme init dans prism_init_comp '
218	CALL abort_physic(modname,abort_message,1)
219	ELSE
220	WRITE(lunout,*) 'inicma : init psmile ok '
221	ENDIF
222	ENDIF
223
224	CALL prism_get_localcomm_proto (il_commlocal, ierror)
225	!************************************************************************************
226	! Domain decomposition
227	!************************************************************************************
228	ig_paral(1) = 1 ! apple partition for //
229	ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset
230	ig_paral(3) = (jj_endnbp_lon+ii_end) - (jj_beginnbp_lon+ii_begin) + 1
231
232	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1
233	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
234
235	ierror=PRISM_Ok
236	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
237
238	IF (ierror .NE. PRISM_Ok) THEN
239	abort_message=' Probleme dans prism_def_partition '
240	CALL abort_physic(modname,abort_message,1)
241	ELSE
242	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
243	ENDIF
244
245	il_var_nodims(1) = 2
246	il_var_nodims(2) = 1
247
248	il_var_actual_shape(1) = 1
249	il_var_actual_shape(2) = nbp_lon
250	il_var_actual_shape(3) = 1
251	il_var_actual_shape(4) = nbp_lat
252
253	il_var_type = PRISM_Real
254
255	!************************************************************************************
256	! Oceanic Fields to receive
257	! Loop over all possible variables
258	!************************************************************************************
259	DO jf=1, maxrecv
260	IF (inforecv(jf)%action) THEN
261	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
262	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
263	ierror)
264	IF (ierror .NE. PRISM_Ok) THEN
265	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
266	inforecv(jf)%name
267	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
268	CALL abort_physic(modname,abort_message,1)
269	ENDIF
270	ENDIF
271	END DO
272
273	!************************************************************************************
274	! Atmospheric Fields to send
275	! Loop over all possible variables
276	!************************************************************************************
277	DO jf=1,maxsend
278	IF (infosend(jf)%action) THEN
279	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
280	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
281	ierror)
282	IF (ierror .NE. PRISM_Ok) THEN
283	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
284	infosend(jf)%name
285	abort_message=' Problem in call to prism_def_var_proto for fields to send'
286	CALL abort_physic(modname,abort_message,1)
287	ENDIF
288	ENDIF
289	END DO
290
291	!************************************************************************************
292	! End definition
293	!************************************************************************************
294	CALL prism_enddef_proto(ierror)
295	IF (ierror .NE. PRISM_Ok) THEN
296	abort_message=' Problem in call to prism_endef_proto'
297	CALL abort_physic(modname,abort_message,1)
298	ELSE
299	WRITE(lunout,*) 'inicma : endef psmile ok '
300	ENDIF
301
302	#ifdef CPP_XIOS
303	CALL wxios_context_init()
304	#endif
305
306	!$OMP END MASTER
307
308	END SUBROUTINE inicma
309
310	!
311	!************************************************************************************
312	!
313
314	SUBROUTINE fromcpl(ktime, tab_get)
315	! ======================================================================
316	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
317	! and Sea-Ice provided by the coupler. Adaptation to psmile library
318	!======================================================================
319	!
320	USE print_control_mod, ONLY: lunout
321	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
322	! Input arguments
323	!************************************************************************************
324	INTEGER, INTENT(IN) :: ktime
325
326	! Output arguments
327	!************************************************************************************
328	REAL, DIMENSION(nbp_lon, jj_nb,maxrecv), INTENT(OUT) :: tab_get
329
330	! Local variables
331	!************************************************************************************
332	INTEGER :: ierror, i
333	INTEGER :: istart,iend
334	CHARACTER (len = 20) :: modname = 'fromcpl'
335	CHARACTER (len = 80) :: abort_message
336	REAL, DIMENSION(nbp_lon*jj_nb) :: field
337
338	!************************************************************************************
339	WRITE (lunout,*) ' '
340	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
341	WRITE (lunout,*) ' '
342
343	istart=ii_begin
344	IF (is_south_pole_dyn) THEN
345	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
346	ELSE
347	iend=(jj_end-jj_begin)*nbp_lon+ii_end
348	ENDIF
349
350	DO i = 1, maxrecv
351	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
352	field(:) = -99999.
353	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
354	tab_get(:,:,i) = RESHAPE(field(:),(/nbp_lon,jj_nb/))
355
356	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
357	ierror.NE.PRISM_FromRest &
358	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
359	.AND. ierror.NE.PRISM_FromRestOut) THEN
360	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
361	abort_message=' Problem in prism_get_proto '
362	CALL abort_physic(modname,abort_message,1)
363	ENDIF
364	ENDIF
365	END DO
366
367
368	END SUBROUTINE fromcpl
369
370	!
371	!************************************************************************************
372	!
373
374	SUBROUTINE intocpl(ktime, last, tab_put)
375	! ======================================================================
376	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
377	! atmospheric coupling fields to the coupler with the psmile library.
378	! IF last time step, writes output fields to binary files.
379	! ======================================================================
380	!
381	!
382	USE print_control_mod, ONLY: lunout
383	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
384	! Input arguments
385	!************************************************************************************
386	INTEGER, INTENT(IN) :: ktime
387	LOGICAL, INTENT(IN) :: last
388	REAL, DIMENSION(nbp_lon, jj_nb, maxsend), INTENT(IN) :: tab_put
389
390	! Local variables
391	!************************************************************************************
392	LOGICAL :: checkout
393	INTEGER :: istart,iend
394	INTEGER :: wstart,wend
395	INTEGER :: ierror, i
396	REAL, DIMENSION(nbp_lon*jj_nb) :: field
397	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
398	CHARACTER (len = 80) :: abort_message
399
400	!************************************************************************************
401	checkout=.FALSE.
402
403	WRITE(lunout,*) ' '
404	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
405	WRITE(lunout,*) 'last = ', last
406	WRITE(lunout,*)
407
408
409	istart=ii_begin
410	IF (is_south_pole_dyn) THEN
411	iend=(jj_end-jj_begin)*nbp_lon+nbp_lon
412	ELSE
413	iend=(jj_end-jj_begin)*nbp_lon+ii_end
414	ENDIF
415
416	IF (checkout) THEN
417	wstart=istart
418	wend=iend
419	IF (is_north_pole_dyn) wstart=istart+nbp_lon-1
420	IF (is_south_pole_dyn) wend=iend-nbp_lon+1
421
422	DO i = 1, maxsend
423	IF (infosend(i)%action) THEN
424	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
425	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
426	END IF
427	END DO
428	END IF
429
430	!************************************************************************************
431	! PRISM_PUT
432	!************************************************************************************
433
434	DO i = 1, maxsend
435	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
436	field = RESHAPE(tab_put(:,:,i),(/nbp_lon*jj_nb/))
437	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
438
439	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
440	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
441	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
442	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
443	abort_message=' Problem in prism_put_proto '
444	CALL abort_physic(modname,abort_message,1)
445	ENDIF
446	ENDIF
447	END DO
448
449	!************************************************************************************
450	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
451	! from Finalize_parallel in dyn3dpar/parallel.F90
452	!************************************************************************************
453
454	IF (last) THEN
455	IF (is_sequential) THEN
456	CALL prism_terminate_proto(ierror)
457	IF (ierror .NE. PRISM_Ok) THEN
458	abort_message=' Problem in prism_terminate_proto '
459	CALL abort_physic(modname,abort_message,1)
460	ENDIF
461	ENDIF
462	ENDIF
463
464
465	END SUBROUTINE intocpl
466
467	#endif
468
469	END MODULE oasis

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

Download in other formats:

Original Format