Context Navigation

oasis.F90 @ 1264

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

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

Download in other formats:

Original Format