Context Navigation

oasis.F90 @ 3983

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

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

Download in other formats:

Original Format