Context Navigation

oasis.F90

Last change on this file was 1997, checked in by acaubel, 11 years ago
SAVE attribute was missing to run on OpenMP mode.
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.0 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
99	INCLUDE "dimensions.h"
100	INCLUDE "iniprint.h"
101
102	! Local variables
103	!************************************************************************************
104	INTEGER :: comp_id
105	INTEGER :: ierror, il_commlocal
106	INTEGER :: il_part_id
107	INTEGER, DIMENSION(3) :: ig_paral
108	INTEGER, DIMENSION(2) :: il_var_nodims
109	INTEGER, DIMENSION(4) :: il_var_actual_shape
110	INTEGER :: il_var_type
111	INTEGER :: jf
112	CHARACTER (len = 6) :: clmodnam
113	CHARACTER (len = 20) :: modname = 'inicma'
114	CHARACTER (len = 80) :: abort_message
115	LOGICAL, SAVE :: cpl_current_omp
116
117	!* 1. Initializations
118	! ---------------
119	!************************************************************************************
120	WRITE(lunout,*) ' '
121	WRITE(lunout,*) ' '
122	WRITE(lunout,*) ' ROUTINE INICMA'
123	WRITE(lunout,) ' *************'
124	WRITE(lunout,*) ' '
125	WRITE(lunout,*) ' '
126
127	!
128	! Define the model name
129	!
130	clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
131
132
133	!************************************************************************************
134	! Define if coupling ocean currents or not
135	!************************************************************************************
136	!$OMP MASTER
137	cpl_current_omp = .FALSE.
138	CALL getin('cpl_current', cpl_current_omp)
139	!$OMP END MASTER
140	!$OMP BARRIER
141	cpl_current = cpl_current_omp
142	WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current
143
144	!************************************************************************************
145	! Define coupling variables
146	!************************************************************************************
147
148	! Atmospheric variables to send
149
150	!$OMP MASTER
151	infosend(:)%action = .FALSE.
152
153	infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
154	infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
155	infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
156	infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
157	infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
158	infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
159	infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
160	infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
161	infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
162	infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
163	infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
164
165	IF (version_ocean=='nemo') THEN
166	infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
167	infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
168	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
169	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
170	infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
171	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
172	infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
173	infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
174	IF (carbon_cycle_cpl) THEN
175	infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
176	ENDIF
177
178	ELSE IF (version_ocean=='opa8') THEN
179	infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
180	infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
181	infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
182	infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
183	infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
184	infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
185	infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
186	infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
187	ENDIF
188
189	! Oceanic variables to receive
190
191	inforecv(:)%action = .FALSE.
192
193	inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
194	inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
195	inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
196	inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
197
198	IF (cpl_current ) THEN
199	inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
200	inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
201	inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
202	ENDIF
203
204	IF (carbon_cycle_cpl ) THEN
205	inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
206	ENDIF
207
208	!************************************************************************************
209	! Here we go: psmile initialisation
210	!************************************************************************************
211	IF (is_sequential) THEN
212	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
213
214	IF (ierror .NE. PRISM_Ok) THEN
215	abort_message=' Probleme init dans prism_init_comp '
216	CALL abort_gcm(modname,abort_message,1)
217	ELSE
218	WRITE(lunout,*) 'inicma : init psmile ok '
219	ENDIF
220	ENDIF
221
222	CALL prism_get_localcomm_proto (il_commlocal, ierror)
223	!************************************************************************************
224	! Domain decomposition
225	!************************************************************************************
226	ig_paral(1) = 1 ! apple partition for //
227	ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset
228	ig_paral(3) = (jj_endiim+ii_end) - (jj_beginiim+ii_begin) + 1
229
230	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
231	WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
232
233	ierror=PRISM_Ok
234	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
235
236	IF (ierror .NE. PRISM_Ok) THEN
237	abort_message=' Probleme dans prism_def_partition '
238	CALL abort_gcm(modname,abort_message,1)
239	ELSE
240	WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
241	ENDIF
242
243	il_var_nodims(1) = 2
244	il_var_nodims(2) = 1
245
246	il_var_actual_shape(1) = 1
247	il_var_actual_shape(2) = iim
248	il_var_actual_shape(3) = 1
249	il_var_actual_shape(4) = jjm+1
250
251	il_var_type = PRISM_Real
252
253	!************************************************************************************
254	! Oceanic Fields to receive
255	! Loop over all possible variables
256	!************************************************************************************
257	DO jf=1, maxrecv
258	IF (inforecv(jf)%action) THEN
259	CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
260	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
261	ierror)
262	IF (ierror .NE. PRISM_Ok) THEN
263	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
264	inforecv(jf)%name
265	abort_message=' Problem in call to prism_def_var_proto for fields to receive'
266	CALL abort_gcm(modname,abort_message,1)
267	ENDIF
268	ENDIF
269	END DO
270
271	!************************************************************************************
272	! Atmospheric Fields to send
273	! Loop over all possible variables
274	!************************************************************************************
275	DO jf=1,maxsend
276	IF (infosend(jf)%action) THEN
277	CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
278	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
279	ierror)
280	IF (ierror .NE. PRISM_Ok) THEN
281	WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
282	infosend(jf)%name
283	abort_message=' Problem in call to prism_def_var_proto for fields to send'
284	CALL abort_gcm(modname,abort_message,1)
285	ENDIF
286	ENDIF
287	END DO
288
289	!************************************************************************************
290	! End definition
291	!************************************************************************************
292	CALL prism_enddef_proto(ierror)
293	IF (ierror .NE. PRISM_Ok) THEN
294	abort_message=' Problem in call to prism_endef_proto'
295	CALL abort_gcm(modname,abort_message,1)
296	ELSE
297	WRITE(lunout,*) 'inicma : endef psmile ok '
298	ENDIF
299
300	!$OMP END MASTER
301
302	END SUBROUTINE inicma
303
304	!
305	!************************************************************************************
306	!
307
308	SUBROUTINE fromcpl(ktime, tab_get)
309	! ======================================================================
310	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
311	! and Sea-Ice provided by the coupler. Adaptation to psmile library
312	!======================================================================
313	!
314	INCLUDE "dimensions.h"
315	INCLUDE "iniprint.h"
316	! Input arguments
317	!************************************************************************************
318	INTEGER, INTENT(IN) :: ktime
319
320	! Output arguments
321	!************************************************************************************
322	REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
323
324	! Local variables
325	!************************************************************************************
326	INTEGER :: ierror, i
327	INTEGER :: istart,iend
328	CHARACTER (len = 20) :: modname = 'fromcpl'
329	CHARACTER (len = 80) :: abort_message
330	REAL, DIMENSION(iim*jj_nb) :: field
331
332	!************************************************************************************
333	WRITE (lunout,*) ' '
334	WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
335	WRITE (lunout,*) ' '
336
337	istart=ii_begin
338	IF (is_south_pole) THEN
339	iend=(jj_end-jj_begin)*iim+iim
340	ELSE
341	iend=(jj_end-jj_begin)*iim+ii_end
342	ENDIF
343
344	DO i = 1, maxrecv
345	IF (inforecv(i)%action .AND. inforecv(i)%nid .NE. -1) THEN
346	field(:) = -99999.
347	CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
348	tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
349
350	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
351	ierror.NE.PRISM_FromRest &
352	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
353	.AND. ierror.NE.PRISM_FromRestOut) THEN
354	WRITE (lunout,*) 'Error with receiving filed : ', inforecv(i)%name, ktime
355	abort_message=' Problem in prism_get_proto '
356	CALL abort_gcm(modname,abort_message,1)
357	ENDIF
358	ENDIF
359	END DO
360
361
362	END SUBROUTINE fromcpl
363
364	!
365	!************************************************************************************
366	!
367
368	SUBROUTINE intocpl(ktime, last, tab_put)
369	! ======================================================================
370	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
371	! atmospheric coupling fields to the coupler with the psmile library.
372	! IF last time step, writes output fields to binary files.
373	! ======================================================================
374	!
375	!
376	INCLUDE "dimensions.h"
377	INCLUDE "iniprint.h"
378	! Input arguments
379	!************************************************************************************
380	INTEGER, INTENT(IN) :: ktime
381	LOGICAL, INTENT(IN) :: last
382	REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
383
384	! Local variables
385	!************************************************************************************
386	LOGICAL :: checkout
387	INTEGER :: istart,iend
388	INTEGER :: wstart,wend
389	INTEGER :: ierror, i
390	REAL, DIMENSION(iim*jj_nb) :: field
391	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
392	CHARACTER (len = 80) :: abort_message
393
394	!************************************************************************************
395	checkout=.FALSE.
396
397	WRITE(lunout,*) ' '
398	WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
399	WRITE(lunout,*) 'last = ', last
400	WRITE(lunout,*)
401
402
403	istart=ii_begin
404	IF (is_south_pole) THEN
405	iend=(jj_end-jj_begin)*iim+iim
406	ELSE
407	iend=(jj_end-jj_begin)*iim+ii_end
408	ENDIF
409
410	IF (checkout) THEN
411	wstart=istart
412	wend=iend
413	IF (is_north_pole) wstart=istart+iim-1
414	IF (is_south_pole) wend=iend-iim+1
415
416	DO i = 1, maxsend
417	IF (infosend(i)%action) THEN
418	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
419	CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
420	END IF
421	END DO
422	END IF
423
424	!************************************************************************************
425	! PRISM_PUT
426	!************************************************************************************
427
428	DO i = 1, maxsend
429	IF (infosend(i)%action .AND. infosend(i)%nid .NE. -1 ) THEN
430	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
431	CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
432
433	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
434	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
435	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
436	WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime
437	abort_message=' Problem in prism_put_proto '
438	CALL abort_gcm(modname,abort_message,1)
439	ENDIF
440	ENDIF
441	END DO
442
443	!************************************************************************************
444	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
445	! from Finalize_parallel in dyn3dpar/parallel.F90
446	!************************************************************************************
447
448	IF (last) THEN
449	IF (is_sequential) THEN
450	CALL prism_terminate_proto(ierror)
451	IF (ierror .NE. PRISM_Ok) THEN
452	abort_message=' Problem in prism_terminate_proto '
453	CALL abort_gcm(modname,abort_message,1)
454	ENDIF
455	ENDIF
456	ENDIF
457
458
459	END SUBROUTINE intocpl
460
461	#endif
462
463	END MODULE oasis

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

Download in other formats:

Original Format