Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

oasis.F90 @ 5308

Last change on this file since 5308 was 3331, checked in by acozic, 6 years ago
Add modification for isotopes
Property svn:executable set to ``*
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