Context Navigation

oasis.F90 @ 990

Last change on this file since 990 was 987, checked in by Laurent Fairhead, 16 years ago
Du nettoyage sur le parallelisme, inclusion de nouvelles interfaces pour OPA9 et ORCHIDEE YM LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 15.9 KB

Line
1	!
2	! $Header$
3	!
4	MODULE oasis
5	!
6	! This module contains subroutines for initialization, sending and receiving
7	! towards the coupler OASIS3. It also contains some parameters for the coupling.
8	!
9	! This module should always be compiled. With the coupler OASIS3 available the cpp key
10	! CPP_COUPLE should be set and the entier of this file will then be compiled.
11	! In a forced mode CPP_COUPLE should not be defined and the compilation ends before
12	! the CONTAINS, without compiling the subroutines.
13	!
14	USE dimphy
15	USE mod_phys_lmdz_para
16	USE write_field_phy
17
18	#ifdef CPP_COUPLE
19	USE mod_prism_proto
20	USE mod_prism_def_partition_proto
21	USE mod_prism_get_proto
22	USE mod_prism_put_proto
23	#endif
24
25	IMPLICIT NONE
26
27	! Maximum number of fields exchanged between ocean and atmosphere
28	INTEGER, PARAMETER :: jpmaxfld=40
29	! Number of fields exchanged from atmosphere to ocean via flx.F
30	INTEGER, PARAMETER :: jpflda2o1=13
31	! Number of fields exchanged from atmosphere to ocean via tau.F
32	INTEGER, PARAMETER :: jpflda2o2=6
33	! Number of fields exchanged from ocean to atmosphere
34	INTEGER, PARAMETER :: jpfldo2a=4
35
36	CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE :: cl_read
37	!$OMP THREADPRIVATE(cl_read)
38	CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE :: cl_writ
39	!$OMP THREADPRIVATE(cl_writ)
40
41	INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE :: in_var_id
42	!$OMP THREADPRIVATE(in_var_id)
43	INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
44	!$OMP THREADPRIVATE(out_var_id)
45
46	CHARACTER(LEN=*),PARAMETER :: OPA_version='OPA9'
47
48	#ifdef CPP_COUPLE
49
50	CONTAINS
51
52	SUBROUTINE inicma
53	!************************************************************************************
54	!**** INICMA - Initialize coupled mode communication for atmosphere
55	! and exchange some initial information with Oasis
56	!
57	! Rewrite to take the PRISM/psmile library into account
58	! LF 09/2003
59	!
60	INCLUDE "dimensions.h"
61
62	! Local variables
63	!************************************************************************************
64	INTEGER :: comp_id
65	INTEGER :: ierror, il_commlocal
66	INTEGER :: il_part_id
67	INTEGER, DIMENSION(3) :: ig_paral
68	INTEGER, DIMENSION(2) :: il_var_nodims
69	INTEGER, DIMENSION(4) :: il_var_actual_shape
70	INTEGER :: il_var_type
71	INTEGER :: nuout = 6
72	INTEGER :: jf
73	CHARACTER (len = 6) :: clmodnam
74	CHARACTER (len = 20) :: modname = 'inicma'
75	CHARACTER (len = 80) :: abort_message
76
77	!* 1. Initializations
78	! ---------------
79	!************************************************************************************
80	WRITE(nuout,*) ' '
81	WRITE(nuout,*) ' '
82	WRITE(nuout,*) ' ROUTINE INICMA'
83	WRITE(nuout,) ' *************'
84	WRITE(nuout,*) ' '
85	WRITE(nuout,*) ' '
86
87	!
88	! Define the model name
89	!
90	clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
91	!
92	!************************************************************************************
93	! Here we go: psmile initialisation
94	!************************************************************************************
95	IF (is_sequential) THEN
96	CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
97
98	IF (ierror .NE. PRISM_Ok) THEN
99	abort_message=' Probleme init dans prism_init_comp '
100	CALL abort_gcm(modname,abort_message,1)
101	ELSE
102	WRITE(nuout,*) 'inicma : init psmile ok '
103	ENDIF
104	ENDIF
105
106	CALL prism_get_localcomm_proto (il_commlocal, ierror)
107	!************************************************************************************
108	! Domain decomposition
109	!************************************************************************************
110	ig_paral(1) = 1 ! apple partition for //
111	ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset
112	ig_paral(3) = (jj_endiim+ii_end) - (jj_beginiim+ii_begin) + 1
113
114	IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
115	WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
116
117	ierror=PRISM_Ok
118	CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
119
120	IF (ierror .NE. PRISM_Ok) THEN
121	abort_message=' Probleme dans prism_def_partition '
122	CALL abort_gcm(modname,abort_message,1)
123	ELSE
124	WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
125	ENDIF
126
127	!************************************************************************************
128	! Field Declarations
129	!************************************************************************************
130	! Define symbolic name for fields exchanged from atmos to coupler,
131	! must be the same as (1) of the field definition in namcouple:
132	IF (OPA_version=='OPA9') THEN
133	cl_writ(1)='COTAUXXU'
134	cl_writ(2)='COTAUYYU'
135	cl_writ(3)='COTAUZZU'
136	cl_writ(4)='COTAUXXV'
137	cl_writ(5)='COTAUYYV'
138	cl_writ(6)='COTAUZZV'
139	cl_writ(7)='COWINDSP'
140	cl_writ(8)='COPEFWAT'
141	cl_writ(9)='COPEFICE'
142	cl_writ(10)='COTOSPSU'
143	cl_writ(11)='COICEVAP'
144	cl_writ(12)='COSWFLDO'
145	cl_writ(13)='CONSFLDO'
146	cl_writ(14)='COSHFLIC'
147	cl_writ(15)='CONSFLIC'
148	cl_writ(16)='CODFLXDT'
149	cl_writ(17)='CRWOCEIS'
150	cl_writ(18)='CRWOCERD'
151	cl_writ(19)='CRWOCECD'
152	ELSE IF (OPA_version=='OPA8') THEN
153	cl_writ(1)='COTAUXXU'
154	cl_writ(2)='COTAUYYU'
155	cl_writ(3)='COTAUZZU'
156	cl_writ(4)='COTAUXXV'
157	cl_writ(5)='COTAUYYV'
158	cl_writ(6)='COTAUZZV'
159	cl_writ(7)='COWINDSP'
160	cl_writ(8)='COSHFICE'
161	cl_writ(9)='COSHFOCE'
162	cl_writ(10)='CONSFICE'
163	cl_writ(11)='CONSFOCE'
164	cl_writ(12)='CODFLXDT'
165	cl_writ(13)='COTFSICE'
166	cl_writ(14)='COTFSOCE'
167	cl_writ(15)='COTOLPSU'
168	cl_writ(16)='COTOSPSU'
169	cl_writ(17)='CORUNCOA'
170	cl_writ(18)='CORIVFLU'
171	cl_writ(19)='COCALVIN'
172	ELSE
173	STOP 'Bad OPA version for coupled model'
174	ENDIF
175
176	!
177	! Define symbolic name for fields exchanged from coupler to atmosphere,
178	! must be the same as (2) of the field definition in namcouple:
179	!
180	IF (OPA_version=='OPA9') THEN
181	cl_read(1)='SISUTESW'
182	cl_read(2)='SIICECOV'
183	cl_read(4)='SIICEALW'
184	cl_read(3)='SIICTEMW'
185	ELSE IF (OPA_version=='OPA8') THEN
186	cl_read(1)='SISUTESW'
187	cl_read(2)='SIICECOV'
188	cl_read(3)='SIICEALW'
189	cl_read(4)='SIICTEMW'
190	ELSE
191	STOP 'Bad OPA version for coupled model'
192	ENDIF
193
194	il_var_nodims(1) = 2
195	il_var_nodims(2) = 1
196
197	il_var_actual_shape(1) = 1
198	il_var_actual_shape(2) = iim
199	il_var_actual_shape(3) = 1
200	il_var_actual_shape(4) = jjm+1
201
202	il_var_type = PRISM_Real
203
204	!************************************************************************************
205	! Oceanic Fields
206	!************************************************************************************
207	DO jf=1, jpfldo2a
208	CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
209	il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
210	ierror)
211	IF (ierror .NE. PRISM_Ok) THEN
212	abort_message=' Probleme init dans prism_def_var_proto '
213	CALL abort_gcm(modname,abort_message,1)
214	ENDIF
215	END DO
216
217	!************************************************************************************
218	! Atmospheric Fields
219	!************************************************************************************
220	DO jf=1, jpflda2o1+jpflda2o2
221	CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
222	il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
223	ierror)
224	IF (ierror .NE. PRISM_Ok) THEN
225	abort_message=' Probleme init dans prism_def_var_proto '
226	CALL abort_gcm(modname,abort_message,1)
227	ENDIF
228	END DO
229
230	!************************************************************************************
231	! End definition
232	!************************************************************************************
233	CALL prism_enddef_proto(ierror)
234	IF (ierror .NE. PRISM_Ok) THEN
235	abort_message=' Probleme init dans prism_ endef_proto'
236	CALL abort_gcm(modname,abort_message,1)
237	ELSE
238	WRITE(nuout,*) 'inicma : endef psmile ok '
239	ENDIF
240
241	END SUBROUTINE inicma
242
243	!
244	!************************************************************************************
245	!
246
247	SUBROUTINE fromcpl(ktime, tab_get)
248	! ======================================================================
249	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
250	! and Sea-Ice provided by the coupler. Adaptation to psmile library
251	!======================================================================
252	!
253	INCLUDE "dimensions.h"
254	! Input arguments
255	!************************************************************************************
256	INTEGER, INTENT(IN) :: ktime
257
258	! Output arguments
259	!************************************************************************************
260	REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
261
262	! Local variables
263	!************************************************************************************
264	INTEGER :: nuout = 6 ! listing output unit
265	INTEGER :: ierror, i
266	INTEGER :: istart,iend
267	CHARACTER (len = 20) :: modname = 'fromcpl'
268	CHARACTER (len = 80) :: abort_message
269	REAL, DIMENSION(iim*jj_nb) :: field
270
271	!************************************************************************************
272	WRITE (nuout,*) ' '
273	WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
274	WRITE (nuout,*) ' '
275	CALL flush (nuout)
276
277	istart=ii_begin
278	IF (is_south_pole) THEN
279	iend=(jj_end-jj_begin)*iim+iim
280	ELSE
281	iend=(jj_end-jj_begin)*iim+ii_end
282	ENDIF
283
284	DO i = 1, jpfldo2a
285	field(:) = -99999.
286	CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
287	tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
288
289	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
290	ierror.NE.PRISM_FromRest &
291	.AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
292	.AND. ierror.NE.PRISM_FromRestOut) THEN
293	WRITE (nuout,*) cl_read(i), ktime
294	abort_message=' Probleme dans prism_get_proto '
295	CALL abort_gcm(modname,abort_message,1)
296	ENDIF
297	END DO
298
299
300	END SUBROUTINE fromcpl
301
302	!
303	!************************************************************************************
304	!
305
306	SUBROUTINE intocpl(ktime, last, tab_put)
307	! ======================================================================
308	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
309	! atmospheric coupling fields to the coupler with the psmile library.
310	! IF last time step, writes output fields to binary files.
311	! ======================================================================
312	!
313	!
314	INCLUDE "dimensions.h"
315	! Input arguments
316	!************************************************************************************
317	INTEGER, INTENT(IN) :: ktime
318	LOGICAL, INTENT(IN) :: last
319	REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
320
321	! Local variables
322	!************************************************************************************
323	LOGICAL :: checkout
324	INTEGER :: istart,iend
325	INTEGER :: wstart,wend
326	INTEGER, PARAMETER :: nuout = 6
327	INTEGER :: ierror, i
328	REAL, DIMENSION(iim*jj_nb) :: field
329	CHARACTER (len = 20),PARAMETER :: modname = 'intocpl'
330	CHARACTER (len = 80) :: abort_message
331
332	!************************************************************************************
333	checkout=.FALSE.
334
335	WRITE(nuout,*) ' '
336	WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
337	WRITE(nuout,*) 'last ', last
338	WRITE(nuout,*)
339
340
341	istart=ii_begin
342	IF (is_south_pole) THEN
343	iend=(jj_end-jj_begin)*iim+iim
344	ELSE
345	iend=(jj_end-jj_begin)*iim+ii_end
346	ENDIF
347
348	IF (checkout) THEN
349	wstart=istart
350	wend=iend
351	IF (is_north_pole) wstart=istart+iim-1
352	IF (is_south_pole) wend=iend-iim+1
353
354	field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
355	CALL writeField_phy("fsolice",field(wstart:wend),1)
356	field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
357	CALL writeField_phy("fsolwat",field(wstart:wend),1)
358	field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
359	CALL writeField_phy("fnsolice",field(wstart:wend),1)
360	field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
361	CALL writeField_phy("fnsolwat",field(wstart:wend),1)
362	field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
363	CALL writeField_phy("fnsicedt",field(wstart:wend),1)
364	field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
365	CALL writeField_phy("evice",field(wstart:wend),1)
366	field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
367	CALL writeField_phy("evwat",field(wstart:wend),1)
368	field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
369	CALL writeField_phy("lpre",field(wstart:wend),1)
370	field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
371	CALL writeField_phy("spre",field(wstart:wend),1)
372	field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
373	CALL writeField_phy("dirunoff",field(wstart:wend),1)
374	field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
375	CALL writeField_phy("rivrunoff",field(wstart:wend),1)
376	field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
377	CALL writeField_phy("calving",field(wstart:wend),1)
378	field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
379	CALL writeField_phy("tauxx_u",field(wstart:wend),1)
380	field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
381	CALL writeField_phy("tauyy_u",field(wstart:wend),1)
382	field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
383	CALL writeField_phy("tauzz_u",field(wstart:wend),1)
384	field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
385	CALL writeField_phy("tauxx_v",field(wstart:wend),1)
386	field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
387	CALL writeField_phy("tauyy_v",field(wstart:wend),1)
388	field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
389	CALL writeField_phy("tauzz_v",field(wstart:wend),1)
390	field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
391	CALL writeField_phy("windsp",field(wstart:wend),1)
392	ENDIF
393
394	!************************************************************************************
395	! PRISM_PUT
396	!************************************************************************************
397
398	DO i = 1, jpflda2o1+jpflda2o2
399	field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
400	CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
401
402	IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
403	.AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
404	ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
405	WRITE (nuout,*) cl_writ(i), ktime
406	abort_message=' Probleme dans prism_put_proto '
407	CALL abort_gcm(modname,abort_message,1)
408	ENDIF
409
410	END DO
411
412	!************************************************************************************
413	! Finalize PSMILE for the case is_sequential, if parallel finalization is done
414	! from Finalize_parallel in dyn3dpar/parallel.F90
415	!************************************************************************************
416
417	IF (last) THEN
418	IF (is_sequential) THEN
419	CALL prism_terminate_proto(ierror)
420	IF (ierror .NE. PRISM_Ok) THEN
421	abort_message=' Probleme dans prism_terminate_proto '
422	CALL abort_gcm(modname,abort_message,1)
423	ENDIF
424	ENDIF
425	ENDIF
426
427
428	END SUBROUTINE intocpl
429
430	#endif
431
432	END MODULE oasis

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

Download in other formats:

Original Format