Context Navigation

oasis.psmile @ 558

Last change on this file since 558 was 544, checked in by lmdzadmin, 20 years ago
Incorporation des modifications necessaires a l'utilisation de la librairie Psmile/PRISM, et creation d'un tag IPSL-CM4_PSMILE, selon M.-E. Demory LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 17.6 KB

Line
1	! $Header$
2
3	MODULE oasis
4
5	! Module contenant les routines pour l'initialisation du couplage, la
6	! lecture et l'ecriture des champs venant/transmis au coupleur
7	!
8
9	IMPLICIT none
10
11	PRIVATE
12	PUBLIC :: inicma, fromcpl, intocpl
13
14	INTERFACE inicma
15	module procedure inicma
16	END INTERFACE
17
18	#include "param_cou.h"
19
20	integer, dimension(jpfldo2a), save :: in_var_id
21	integer, dimension(jpflda2o1+jpflda2o2), save :: il_out_var_id
22	CHARACTER (len=8), dimension(jpmaxfld), public, save :: cl_writ, cl_read
23	CHARACTER (len=8), dimension(jpmaxfld), save :: cl_f_writ, cl_f_read
24
25	CONTAINS
26
27	!****
28	!
29	!**** INICMA - Initialize coupled mode communication for atmosphere
30	! and exchange some initial information with Oasis
31	!
32	! Rewrite to take the PRISM/psmile library into account
33	! LF 09/2003
34	!
35	! Input:
36	! -----
37	! im, jm: size of grid passed between gcm and coupler
38	!
39	! -----------------------------------------------------------
40	!
41	SUBROUTINE inicma(im, jm)
42
43	use mod_prism_proto
44	use mod_prism_def_partition_proto
45
46	implicit none
47
48	#include "param_cou.h"
49
50	!
51	! parameters
52	!
53	integer :: im, jm
54	!
55	! local variables
56	!
57	! integers
58	!
59	integer :: comp_id
60	integer :: ierror, il_commlocal
61	integer :: il_part_id
62	integer, dimension(:), allocatable :: ig_paral
63	! integer, dimension(jpfldo2a) :: in_var_id
64	! integer, dimension(jpflda2o1+jpflda2o2) :: il_out_var_id
65	integer, dimension(2) :: il_var_nodims
66	integer, dimension(4) :: il_var_actual_shape
67	integer :: il_var_type
68	integer :: nuout = 6
69	integer :: jf
70	! characters
71	!
72	character (len = 6) :: clmodnam
73	character (len = 20),save :: modname = 'inicma'
74	character (len = 80) :: abort_message
75
76	!
77	! -----------------------------------------------------------
78	!
79	!* 1. Initializations
80	! ---------------
81	!
82	WRITE(nuout,*) ' '
83	WRITE(nuout,*) ' '
84	WRITE(nuout,*) ' ROUTINE INICMA'
85	WRITE(nuout,) ' *************'
86	WRITE(nuout,*) ' '
87	WRITE(nuout,*) ' '
88	!
89	! Define the model name
90	!
91	clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
92	!
93	!
94	! Here we go: psmile initialisation
95	!
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
105	! PSMILe attribution of local communicator
106	!
107	call prism_get_localcomm_proto (il_commlocal, ierror)
108	!
109	! and domain decomposition
110	!
111	! monoproc case
112	!
113	! allocate(ig_paral(3))
114	! ig_paral(1) = 0
115	! ig_paral(2) = 0
116	! ig_paral(3) = im * jm
117	allocate(ig_paral(5))
118	ig_paral (1) = 2
119	ig_paral (2) = 0
120	ig_paral (3) = im
121	ig_paral (4) = jm
122	ig_paral (5) = im
123	call prism_def_partition_proto (il_part_id, ig_paral, ierror)
124	deallocate(ig_paral)
125	!
126	IF (ierror .ne. PRISM_Ok) THEN
127	abort_message=' Probleme dans prism_def_partition '
128	call abort_gcm(modname,abort_message,1)
129	ELSE
130	WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
131	ENDIF
132
133	!
134	! Field Declarations
135	!
136	! Define symbolic name for fields exchanged from atmos to coupler,
137	! must be the same as (1) of the field definition in namcouple:
138	!
139	cl_writ(1)='COSHFICE'
140	cl_writ(2)='COSHFOCE'
141	cl_writ(3)='CONSFICE'
142	cl_writ(4)='CONSFOCE'
143	cl_writ(5)='CODFLXDT'
144	cl_writ(6)='COTFSICE'
145	cl_writ(7)='COTFSOCE'
146	cl_writ(8)='COTOLPSU'
147	cl_writ(9)='COTOSPSU'
148	cl_writ(10)='CORUNCOA'
149	cl_writ(11)='CORIVFLU'
150	cl_writ(12)='COCALVIN'
151	cl_writ(13)='COTAUXXU'
152	cl_writ(14)='COTAUYYU'
153	cl_writ(15)='COTAUZZU'
154	cl_writ(16)='COTAUXXV'
155	cl_writ(17)='COTAUYYV'
156	cl_writ(18)='COTAUZZV'
157	!
158	! Define symbolic name for fields exchanged from coupler to atmosphere,
159	! must be the same as (2) of the field definition in namcouple:
160	!
161	cl_read(1)='SISUTESW'
162	cl_read(2)='SIICECOV'
163	cl_read(3)='SIICEALW'
164	cl_read(4)='SIICTEMW'
165
166	il_var_nodims(1) = 2
167	il_var_nodims(2) = 1
168
169	il_var_actual_shape(1) = 1
170	il_var_actual_shape(2) = im
171	il_var_actual_shape(3) = 1
172	il_var_actual_shape(4) = jm
173
174	il_var_type = PRISM_Real
175	!
176	! Oceanic Fields
177	!
178	DO jf=1, jpfldo2a
179	call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
180	& il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
181	& ierror)
182	IF (ierror .ne. PRISM_Ok) THEN
183	abort_message=' Probleme init dans prism_def_var_proto '
184	call abort_gcm(modname,abort_message,1)
185	ENDIF
186	END DO
187	!
188	! Atmospheric Fields
189	!
190	DO jf=1, jpflda2o1+jpflda2o2
191	call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, &
192	& il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
193	& ierror)
194	IF (ierror .ne. PRISM_Ok) THEN
195	abort_message=' Probleme init dans prism_def_var_proto '
196	call abort_gcm(modname,abort_message,1)
197	ENDIF
198	END DO
199	!
200	! End
201	!
202	call prism_enddef_proto(ierror)
203	IF (ierror .ne. PRISM_Ok) THEN
204	abort_message=' Probleme init dans prism_ endef_proto'
205	call abort_gcm(modname,abort_message,1)
206	ELSE
207	WRITE(nuout,*) 'inicma : endef psmile ok '
208	ENDIF
209
210	END SUBROUTINE inicma
211
212	SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo)
213	! ======================================================================
214	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
215	! and Sea-Ice provided by the coupler. Adaptation to psmile library
216	!======================================================================
217
218	use mod_prism_proto
219	use mod_prism_get_proto
220
221	IMPLICIT none
222
223	!
224	! parametres
225	!
226	integer :: im, jm, kt
227	real, dimension(im, jm) :: sst ! sea-surface-temperature
228	real, dimension(im, jm) :: gla ! sea-ice
229	real, dimension(im, jm) :: tice ! temp glace
230	real, dimension(im, jm) :: albedo ! albedo glace
231	!
232	! local variables
233	!
234	integer :: nuout = 6 ! listing output unit
235	integer :: ierror
236	character (len = 20),save :: modname = 'fromcpl'
237	character (len = 80) :: abort_message
238	!
239	#include "param_cou.h"
240	!
241	!
242	WRITE (nuout,*) ' '
243	WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
244	WRITE (nuout,*) ' '
245	CALL flush (nuout)
246
247	call prism_get_proto(in_var_id(1), kt, sst, ierror)
248	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
249	& ierror.ne.PRISM_FromRest &
250	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
251	& .and. ierror.ne.PRISM_FromRestOut ) THEN
252	WRITE (nuout,*) cl_read(1), kt
253	abort_message=' Probleme dans prism_get_proto '
254	call abort_gcm(modname,abort_message,1)
255	endif
256	call prism_get_proto(in_var_id(2), kt, gla, ierror)
257	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
258	& ierror.ne.PRISM_FromRest &
259	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
260	& .and. ierror.ne.PRISM_FromRestOut ) THEN
261	WRITE (nuout,*) cl_read(2), kt
262	abort_message=' Probleme dans prism_get_proto '
263	call abort_gcm(modname,abort_message,1)
264	endif
265	call prism_get_proto(in_var_id(3), kt, albedo, ierror)
266	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
267	& ierror.ne.PRISM_FromRest &
268	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
269	& .and. ierror.ne.PRISM_FromRestOut ) THEN
270	WRITE (nuout,*) cl_read(3), kt
271	abort_message=' Probleme dans prism_get_proto '
272	call abort_gcm(modname,abort_message,1)
273	endif
274	call prism_get_proto(in_var_id(4), kt, tice, ierror)
275	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
276	& ierror.ne.PRISM_FromRest &
277	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
278	& .and. ierror.ne.PRISM_FromRestOut ) THEN
279	WRITE (nuout,*) cl_read(4), kt
280	abort_message=' Probleme dans prism_get_proto '
281	call abort_gcm(modname,abort_message,1)
282	endif
283
284	!
285	RETURN
286	END SUBROUTINE fromcpl
287
288	SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
289	& fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, &
290	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v &
291	& , last)
292	! ======================================================================
293	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
294	! atmospheric coupling fields to the coupler with the psmile library.
295	! IF last time step, writes output fields to binary files.
296	! ======================================================================
297
298	use mod_prism_proto
299	use mod_prism_put_proto
300
301	IMPLICIT NONE
302
303	!
304	! parametres
305	!
306	integer :: kt, im, jm
307	real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice
308	real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre
309	real, dimension(im, jm) :: dirunoff, rivrunoff, calving
310	real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u
311	real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v
312	logical :: last
313	!
314	! local
315	!
316	integer, parameter :: nuout = 6
317	integer :: ierror
318	character (len = 20),save :: modname = 'intocpl'
319	character (len = 80) :: abort_message
320	!
321	!
322	WRITE(nuout,*) ' '
323	WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
324	WRITE(nuout,*) 'last ', last
325	WRITE(nuout,*)
326
327	call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror)
328	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
329	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
330	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
331	WRITE (nuout,*) cl_writ(1), kt
332	abort_message=' Probleme dans prism_put_proto '
333	call abort_gcm(modname,abort_message,1)
334	endif
335	call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror)
336	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
337	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
338	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
339	WRITE (nuout,*) cl_writ(2), kt
340	abort_message=' Probleme dans prism_put_proto '
341	call abort_gcm(modname,abort_message,1)
342	endif
343	call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror)
344	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
345	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
346	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
347	WRITE (nuout,*) cl_writ(3), kt
348	abort_message=' Probleme dans prism_put_proto '
349	call abort_gcm(modname,abort_message,1)
350	endif
351	call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror)
352	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
353	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
354	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
355	WRITE (nuout,*) cl_writ(4), kt
356	abort_message=' Probleme dans prism_put_proto '
357	call abort_gcm(modname,abort_message,1)
358	endif
359	call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror)
360	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
361	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
362	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
363	WRITE (nuout,*) cl_writ(5), kt
364	abort_message=' Probleme dans prism_put_proto '
365	call abort_gcm(modname,abort_message,1)
366	endif
367	call prism_put_proto(il_out_var_id(6), kt, evice, ierror)
368	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
369	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
370	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
371	WRITE (nuout,*) cl_writ(6), kt
372	abort_message=' Probleme dans prism_put_proto '
373	call abort_gcm(modname,abort_message,1)
374	endif
375	call prism_put_proto(il_out_var_id(7), kt, evwat, ierror)
376	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
377	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
378	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
379	WRITE (nuout,*) cl_writ(7), kt
380	abort_message=' Probleme dans prism_put_proto '
381	call abort_gcm(modname,abort_message,1)
382	endif
383	call prism_put_proto(il_out_var_id(8), kt, lpre, ierror)
384	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
385	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
386	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
387	WRITE (nuout,*) cl_writ(8), kt
388	abort_message=' Probleme dans prism_put_proto '
389	call abort_gcm(modname,abort_message,1)
390	endif
391	call prism_put_proto(il_out_var_id(9), kt, spre, ierror)
392	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
393	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
394	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
395	WRITE (nuout,*) cl_writ(9), kt
396	abort_message=' Probleme dans prism_put_proto '
397	call abort_gcm(modname,abort_message,1)
398	endif
399	call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror)
400	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
401	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
402	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
403	WRITE (nuout,*) cl_writ(10), kt
404	abort_message=' Probleme dans prism_put_proto '
405	call abort_gcm(modname,abort_message,1)
406	endif
407	call prism_put_proto(il_out_var_id(11), kt, rivrunoff, ierror)
408	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
409	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
410	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
411	WRITE (nuout,*) cl_writ(11), kt
412	abort_message=' Probleme dans prism_put_proto '
413	call abort_gcm(modname,abort_message,1)
414	endif
415	call prism_put_proto(il_out_var_id(12), kt, calving, ierror)
416	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
417	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
418	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
419	WRITE (nuout,*) cl_writ(12), kt
420	abort_message=' Probleme dans prism_put_proto '
421	call abort_gcm(modname,abort_message,1)
422	endif
423	call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror)
424	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
425	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
426	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
427	WRITE (nuout,*) cl_writ(13), kt
428	abort_message=' Probleme dans prism_put_proto '
429	call abort_gcm(modname,abort_message,1)
430	endif
431	call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror)
432	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
433	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
434	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
435	WRITE (nuout,*) cl_writ(14), kt
436	abort_message=' Probleme dans prism_put_proto '
437	call abort_gcm(modname,abort_message,1)
438	endif
439	call prism_put_proto(il_out_var_id(15), kt, tauzz_u, ierror)
440	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
441	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
442	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
443	WRITE (nuout,*) cl_writ(15), kt
444	abort_message=' Probleme dans prism_put_proto '
445	call abort_gcm(modname,abort_message,1)
446	endif
447	call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror)
448	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
449	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
450	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
451	WRITE (nuout,*) cl_writ(16), kt
452	abort_message=' Probleme dans prism_put_proto '
453	call abort_gcm(modname,abort_message,1)
454	endif
455	call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror)
456	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
457	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
458	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
459	WRITE (nuout,*) cl_writ(17), kt
460	abort_message=' Probleme dans prism_put_proto '
461	call abort_gcm(modname,abort_message,1)
462	endif
463	call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror)
464	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
465	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
466	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut ) THEN
467	WRITE (nuout,*) cl_writ(18), kt
468	abort_message=' Probleme dans prism_put_proto '
469	call abort_gcm(modname,abort_message,1)
470	endif
471
472	if (last) then
473	call prism_terminate_proto(ierror)
474	IF (ierror .ne. PRISM_Ok) THEN
475	WRITE (nuout,*) cl_writ(18), kt
476	abort_message=' Probleme dans prism_terminate_proto '
477	call abort_gcm(modname,abort_message,1)
478	endif
479	endif
480
481
482	RETURN
483	END SUBROUTINE intocpl
484
485	END MODULE oasis

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

Download in other formats:

Original Format