Context Navigation

oasis.psmile @ 1258

Last change on this file since 1258 was 628, checked in by Laurent Fairhead, 19 years ago
Modif pour compatibilité avec OASIS3 AC LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 17.4 KB

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

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

Download in other formats:

Original Format