Context Navigation

oasis.F90 @ 5456

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

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

Download in other formats:

Original Format