Context Navigation

oasis.psmile @ 520

Last change on this file since 520 was 500, checked in by (none), 21 years ago
This commit was manufactured by cvs2svn to create branch 'rel-LF'.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 13.2 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), 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
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	!
106	! and domain decomposition
107	!
108	! monoproc case
109	!
110	allocate(ig_paral(3))
111	ig_paral(1) = 0
112	ig_paral(2) = 0
113	ig_paral(3) = im * jm
114
115	call prism_def_partition_proto (il_part_id, ig_paral, ierror)
116	deallocate(ig_paral)
117	!
118	IF (ierror .ne. PRISM_Ok) THEN
119	abort_message=' Probleme dans prism_def_partition '
120	call abort_gcm(modname,abort_message,1)
121	ELSE
122	WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
123	ENDIF
124
125	!
126	! Field Declarations
127	!
128	! Define symbolic name for fields exchanged from atmos to coupler,
129	! must be the same as (1) of the field definition in namcouple:
130	!
131	cl_writ(1)='COSHFICE'
132	cl_writ(2)='COSHFOCE'
133	cl_writ(3)='CONSFICE'
134	cl_writ(4)='CONSFOCE'
135	cl_writ(5)='CODFLXDT'
136	cl_writ(6)='COTFSICE'
137	cl_writ(7)='COTFSOCE'
138	cl_writ(8)='COTOLPSU'
139	cl_writ(9)='COTOSPSU'
140	cl_writ(10)='CORUNCOA'
141	cl_writ(11)='CORIVFLU'
142	cl_writ(12)='COCALVIN'
143	cl_writ(13)='COTAUXXU'
144	cl_writ(14)='COTAUYYU'
145	cl_writ(15)='COTAUZZU'
146	cl_writ(16)='COTAUXXV'
147	cl_writ(17)='COTAUYYV'
148	cl_writ(18)='COTAUZZV'
149	!
150	! Define symbolic name for fields exchanged from coupler to atmosphere,
151	! must be the same as (2) of the field definition in namcouple:
152	!
153	cl_read(1)='SISUTESW'
154	cl_read(2)='SIICECOV'
155	cl_read(3)='SIICEALW'
156	cl_read(4)='SIICTEMW'
157
158	il_var_nodims(1) = 2
159	il_var_nodims(2) = 1
160
161	il_var_actual_shape(1) = 1
162	il_var_actual_shape(2) = im
163	il_var_actual_shape(3) = 1
164	il_var_actual_shape(4) = jm
165
166	il_var_type = PRISM_Real
167	!
168	! Oceanic Fields
169	!
170	DO jf=1, jpfldo2a
171	call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
172	& il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
173	& ierror)
174	IF (ierror .ne. PRISM_Ok) THEN
175	abort_message=' Probleme init dans prism_def_var_proto '
176	call abort_gcm(modname,abort_message,1)
177	ENDIF
178	END DO
179	!
180	! Atmospheric Fields
181	!
182	DO jf=1, jpflda2o1+jpflda2o2
183	call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, &
184	& il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
185	& ierror)
186	IF (ierror .ne. PRISM_Ok) THEN
187	abort_message=' Probleme init dans prism_def_var_proto '
188	call abort_gcm(modname,abort_message,1)
189	ENDIF
190	END DO
191	!
192	! End
193	!
194	call prism_enddef_proto(ierror)
195	IF (ierror .ne. PRISM_Ok) THEN
196	abort_message=' Probleme init dans prism_ endef_proto'
197	call abort_gcm(modname,abort_message,1)
198	ELSE
199	WRITE(nuout,*) 'inicma : endef psmile ok '
200	ENDIF
201
202	END SUBROUTINE inicma
203
204	SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo)
205	! ======================================================================
206	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
207	! and Sea-Ice provided by the coupler. Adaptation to psmile library
208	!======================================================================
209
210	use mod_prism_proto
211	use mod_prism_get_proto
212
213	IMPLICIT none
214
215	!
216	! parametres
217	!
218	integer :: im, jm, kt
219	real, dimension(im, jm) :: sst ! sea-surface-temperature
220	real, dimension(im, jm) :: gla ! sea-ice
221	real, dimension(im, jm) :: tice ! temp glace
222	real, dimension(im, jm) :: albedo ! albedo glace
223	!
224	! local variables
225	!
226	integer :: nuout = 6 ! listing output unit
227	integer :: ierror
228	character (len = 20),save :: modname = 'fromcpl'
229	character (len = 80) :: abort_message
230	!
231	#include "param_cou.h"
232	!
233	!
234	WRITE (nuout,*) ' '
235	WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
236	WRITE (nuout,*) ' '
237	CALL flush (nuout)
238
239	call prism_get_proto(in_var_id(1), kt, sst, ierror)
240	IF (ierror .ne. PRISM_Ok) THEN
241	WRITE (nuout,*) cl_read(1), kt
242	abort_message=' Probleme dans prism_get_proto '
243	call abort_gcm(modname,abort_message,1)
244	endif
245	call prism_get_proto(in_var_id(2), kt, gla, ierror)
246	IF (ierror .ne. PRISM_Ok) THEN
247	WRITE (nuout,*) cl_read(2), kt
248	abort_message=' Probleme dans prism_get_proto '
249	call abort_gcm(modname,abort_message,1)
250	endif
251	call prism_get_proto(in_var_id(3), kt, albedo, ierror)
252	IF (ierror .ne. PRISM_Ok) THEN
253	WRITE (nuout,*) cl_read(3), kt
254	abort_message=' Probleme dans prism_get_proto '
255	call abort_gcm(modname,abort_message,1)
256	endif
257	call prism_get_proto(in_var_id(4), kt, tice, ierror)
258	IF (ierror .ne. PRISM_Ok) THEN
259	WRITE (nuout,*) cl_read(4), kt
260	abort_message=' Probleme dans prism_get_proto '
261	call abort_gcm(modname,abort_message,1)
262	endif
263
264	!
265	RETURN
266	END SUBROUTINE fromcpl
267
268	SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
269	& fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, &
270	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v &
271	& , last)
272	! ======================================================================
273	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
274	! atmospheric coupling fields to the coupler with the psmile library.
275	! IF last time step, writes output fields to binary files.
276	! ======================================================================
277
278	use mod_prism_proto
279	use mod_prism_put_proto
280
281	IMPLICIT NONE
282
283	!
284	! parametres
285	!
286	integer :: kt, im, jm
287	real, dimension(im, jm) :: fsolice, fsolwat, fnsolwat, fnsolice
288	real, dimension(im, jm) :: fnsicedt, evice, evwat, lpre, spre
289	real, dimension(im, jm) :: dirunoff, rivrunoff, calving
290	real, dimension(im, jm) :: tauxx_u, tauxx_v, tauyy_u
291	real, dimension(im, jm) :: tauyy_v, tauzz_u, tauzz_v
292	logical :: last
293	!
294	! local
295	!
296	integer, parameter :: nuout = 6
297	integer :: ierror
298	character (len = 20),save :: modname = 'intocpl'
299	character (len = 80) :: abort_message
300	!
301	!
302	WRITE(nuout,*) ' '
303	WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
304	WRITE(nuout,*) 'last ', last
305	WRITE(nuout,*)
306
307	call prism_put_proto(il_out_var_id(1), kt, fsolice, ierror)
308	IF (ierror .ne. PRISM_Ok) THEN
309	WRITE (nuout,*) cl_writ(1), kt
310	abort_message=' Probleme dans prism_put_proto '
311	call abort_gcm(modname,abort_message,1)
312	endif
313	call prism_put_proto(il_out_var_id(2), kt, fsolwat, ierror)
314	IF (ierror .ne. PRISM_Ok) THEN
315	WRITE (nuout,*) cl_writ(2), kt
316	abort_message=' Probleme dans prism_put_proto '
317	call abort_gcm(modname,abort_message,1)
318	endif
319	call prism_put_proto(il_out_var_id(3), kt, fnsolice, ierror)
320	IF (ierror .ne. PRISM_Ok) THEN
321	WRITE (nuout,*) cl_writ(3), kt
322	abort_message=' Probleme dans prism_put_proto '
323	call abort_gcm(modname,abort_message,1)
324	endif
325	call prism_put_proto(il_out_var_id(4), kt, fnsolwat, ierror)
326	IF (ierror .ne. PRISM_Ok) THEN
327	WRITE (nuout,*) cl_writ(4), kt
328	abort_message=' Probleme dans prism_put_proto '
329	call abort_gcm(modname,abort_message,1)
330	endif
331	call prism_put_proto(il_out_var_id(5), kt, fnsicedt, ierror)
332	IF (ierror .ne. PRISM_Ok) THEN
333	WRITE (nuout,*) cl_writ(5), kt
334	abort_message=' Probleme dans prism_put_proto '
335	call abort_gcm(modname,abort_message,1)
336	endif
337	call prism_put_proto(il_out_var_id(6), kt, evice, ierror)
338	IF (ierror .ne. PRISM_Ok) THEN
339	WRITE (nuout,*) cl_writ(6), 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(7), kt, evwat, ierror)
344	IF (ierror .ne. PRISM_Ok) THEN
345	WRITE (nuout,*) cl_writ(7), kt
346	abort_message=' Probleme dans prism_put_proto '
347	call abort_gcm(modname,abort_message,1)
348	endif
349	call prism_put_proto(il_out_var_id(8), kt, lpre, ierror)
350	IF (ierror .ne. PRISM_Ok) THEN
351	WRITE (nuout,*) cl_writ(8), kt
352	abort_message=' Probleme dans prism_put_proto '
353	call abort_gcm(modname,abort_message,1)
354	endif
355	call prism_put_proto(il_out_var_id(9), kt, spre, ierror)
356	IF (ierror .ne. PRISM_Ok) THEN
357	WRITE (nuout,*) cl_writ(9), kt
358	abort_message=' Probleme dans prism_put_proto '
359	call abort_gcm(modname,abort_message,1)
360	endif
361	call prism_put_proto(il_out_var_id(10), kt, dirunoff, ierror)
362	IF (ierror .ne. PRISM_Ok) THEN
363	WRITE (nuout,*) cl_writ(10), 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(11), kt, rivrunoff, ierror)
368	IF (ierror .ne. PRISM_Ok) THEN
369	WRITE (nuout,*) cl_writ(11), kt
370	abort_message=' Probleme dans prism_put_proto '
371	call abort_gcm(modname,abort_message,1)
372	endif
373	call prism_put_proto(il_out_var_id(12), kt, calving, ierror)
374	IF (ierror .ne. PRISM_Ok) THEN
375	WRITE (nuout,*) cl_writ(12), kt
376	abort_message=' Probleme dans prism_put_proto '
377	call abort_gcm(modname,abort_message,1)
378	endif
379	call prism_put_proto(il_out_var_id(13), kt, tauxx_u, ierror)
380	IF (ierror .ne. PRISM_Ok) THEN
381	WRITE (nuout,*) cl_writ(13), kt
382	abort_message=' Probleme dans prism_put_proto '
383	call abort_gcm(modname,abort_message,1)
384	endif
385	call prism_put_proto(il_out_var_id(14), kt, tauyy_u, ierror)
386	IF (ierror .ne. PRISM_Ok) THEN
387	WRITE (nuout,*) cl_writ(14), 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(15), kt, tauzz_u, ierror)
392	IF (ierror .ne. PRISM_Ok) THEN
393	WRITE (nuout,*) cl_writ(15), kt
394	abort_message=' Probleme dans prism_put_proto '
395	call abort_gcm(modname,abort_message,1)
396	endif
397	call prism_put_proto(il_out_var_id(16), kt, tauxx_v, ierror)
398	IF (ierror .ne. PRISM_Ok) THEN
399	WRITE (nuout,*) cl_writ(16), kt
400	abort_message=' Probleme dans prism_put_proto '
401	call abort_gcm(modname,abort_message,1)
402	endif
403	call prism_put_proto(il_out_var_id(17), kt, tauyy_v, ierror)
404	IF (ierror .ne. PRISM_Ok) THEN
405	WRITE (nuout,*) cl_writ(17), kt
406	abort_message=' Probleme dans prism_put_proto '
407	call abort_gcm(modname,abort_message,1)
408	endif
409	call prism_put_proto(il_out_var_id(18), kt, tauzz_v, ierror)
410	IF (ierror .ne. PRISM_Ok) THEN
411	WRITE (nuout,*) cl_writ(18), kt
412	abort_message=' Probleme dans prism_put_proto '
413	call abort_gcm(modname,abort_message,1)
414	endif
415
416	if (last) then
417	call prism_terminate_proto(ierror)
418	IF (ierror .ne. PRISM_Ok) THEN
419	WRITE (nuout,*) cl_writ(18), kt
420	abort_message=' Probleme dans prism_terminate_proto '
421	call abort_gcm(modname,abort_message,1)
422	endif
423	endif
424
425
426	RETURN
427	END SUBROUTINE intocpl
428
429	END MODULE oasis

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

Download in other formats:

Original Format