Context Navigation

oasis.psmile @ 735

Last change on this file since 735 was 704, checked in by Laurent Fairhead, 18 years ago
Inclusion des modifs de Y. Meurdesoif pour la version V3 LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 20.3 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	use dimphy
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	!ym call prism_init_comp_proto (comp_id, clmodnam, ierror)
97	!ym
98	!ym IF (ierror .ne. PRISM_Ok) THEN
99	!ym abort_message=' Probleme init dans prism_init_comp '
100	!ym call abort_gcm(modname,abort_message,1)
101	!ym ELSE
102	!ym WRITE(nuout,*) 'inicma : init psmile ok '
103	!ym ENDIF
104	call prism_get_localcomm_proto (il_commlocal, ierror)
105	!
106	! and domain decomposition
107	!
108	! monoproc case
109	!
110	allocate(ig_paral(3))
111	!ym ig_paral(1) = 0
112	!ym ig_paral(2) = 0
113	!ym ig_paral(3) = im * jm
114	ig_paral(1) = 1 ! apple partition for //
115	ig_paral(2) = (jjphy_begin-1)*im+iiphy_begin-1
116	ig_paral(3) = (jjphy_endim+iiphy_end)-(jjphy_beginim+iiphy_begin)+1
117	if (phy_rank==phy_size-1) ig_paral(3)=ig_paral(3)+im-1
118	print *,phy_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
119
120	ierror=PRISM_Ok
121	call prism_def_partition_proto (il_part_id, ig_paral, ierror)
122	deallocate(ig_paral)
123	!
124	IF (ierror .ne. PRISM_Ok) THEN
125	abort_message=' Probleme dans prism_def_partition '
126	call abort_gcm(modname,abort_message,1)
127	ELSE
128	WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
129	ENDIF
130
131	!
132	! Field Declarations
133	!
134	! Define symbolic name for fields exchanged from atmos to coupler,
135	! must be the same as (1) of the field definition in namcouple:
136	!
137	cl_writ(1)='COTAUXXU'
138	cl_writ(2)='COTAUYYU'
139	cl_writ(3)='COTAUZZU'
140	cl_writ(4)='COTAUXXV'
141	cl_writ(5)='COTAUYYV'
142	cl_writ(6)='COTAUZZV'
143	! -- LOOP
144	cl_writ(7)='COWINDSP'
145	! -- LOOP
146	cl_writ(8)='COSHFICE'
147	cl_writ(9)='COSHFOCE'
148	cl_writ(10)='CONSFICE'
149	cl_writ(11)='CONSFOCE'
150	cl_writ(12)='CODFLXDT'
151	cl_writ(13)='COTFSICE'
152	cl_writ(14)='COTFSOCE'
153	cl_writ(15)='COTOLPSU'
154	cl_writ(16)='COTOSPSU'
155	cl_writ(17)='CORUNCOA'
156	cl_writ(18)='CORIVFLU'
157	cl_writ(19)='COCALVIN'
158	!
159	! Define symbolic name for fields exchanged from coupler to atmosphere,
160	! must be the same as (2) of the field definition in namcouple:
161	!
162	cl_read(1)='SISUTESW'
163	cl_read(2)='SIICECOV'
164	cl_read(3)='SIICEALW'
165	cl_read(4)='SIICTEMW'
166
167	il_var_nodims(1) = 2
168	il_var_nodims(2) = 1
169
170	il_var_actual_shape(1) = 1
171	il_var_actual_shape(2) = im
172	il_var_actual_shape(3) = 1
173	il_var_actual_shape(4) = jm
174
175	il_var_type = PRISM_Real
176	!
177	! Oceanic Fields
178	!
179	DO jf=1, jpfldo2a
180	call prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
181	& il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
182	& ierror)
183	IF (ierror .ne. PRISM_Ok) THEN
184	abort_message=' Probleme init dans prism_def_var_proto '
185	call abort_gcm(modname,abort_message,1)
186	ENDIF
187	END DO
188	!
189	! Atmospheric Fields
190	!
191	DO jf=1, jpflda2o1+jpflda2o2
192	call prism_def_var_proto(il_out_var_id(jf), cl_writ(jf), il_part_id, &
193	& il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
194	& ierror)
195	IF (ierror .ne. PRISM_Ok) THEN
196	abort_message=' Probleme init dans prism_def_var_proto '
197	call abort_gcm(modname,abort_message,1)
198	ENDIF
199	END DO
200	!
201	! End
202	!
203	call prism_enddef_proto(ierror)
204	IF (ierror .ne. PRISM_Ok) THEN
205	abort_message=' Probleme init dans prism_ endef_proto'
206	call abort_gcm(modname,abort_message,1)
207	ELSE
208	WRITE(nuout,*) 'inicma : endef psmile ok '
209	ENDIF
210
211	END SUBROUTINE inicma
212
213	SUBROUTINE fromcpl(kt, im, jm, sst, gla, tice, albedo)
214	! ======================================================================
215	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST
216	! and Sea-Ice provided by the coupler. Adaptation to psmile library
217	!======================================================================
218
219	use mod_prism_proto
220	use mod_prism_get_proto
221	use dimphy
222	IMPLICIT none
223
224	!
225	! parametres
226	!
227	integer :: im, jm, kt
228	real, dimension(im*jm) :: sst ! sea-surface-temperature
229	real, dimension(im*jm) :: gla ! sea-ice
230	real, dimension(im*jm) :: tice ! temp glace
231	real, dimension(im*jm) :: albedo ! albedo glace
232	!
233	! local variables
234	!
235	integer :: nuout = 6 ! listing output unit
236	integer :: ierror
237	character (len = 20),save :: modname = 'fromcpl'
238	character (len = 80) :: abort_message
239	integer :: istart,iend
240	!
241	#include "param_cou.h"
242	!
243	!
244	WRITE (nuout,*) ' '
245	WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
246	WRITE (nuout,*) ' '
247	CALL flush (nuout)
248
249	istart=iiphy_begin
250	if (phy_rank==phy_size-1) then
251	iend=(jjphy_end-jjphy_begin)*im+im
252	else
253	iend=(jjphy_end-jjphy_begin)*im+iiphy_end
254	endif
255
256	call prism_get_proto(in_var_id(1), kt, sst(istart:iend), 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(1), 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(2), kt, gla(istart:iend), 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(2), 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(3), kt, albedo(istart:iend), 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(3), kt
280	abort_message=' Probleme dans prism_get_proto '
281	call abort_gcm(modname,abort_message,1)
282	endif
283	call prism_get_proto(in_var_id(4), kt, tice(istart:iend), ierror)
284	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
285	& ierror.ne.PRISM_FromRest &
286	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
287	& .and. ierror.ne.PRISM_FromRestOut) THEN
288	WRITE (nuout,*) cl_read(4), kt
289	abort_message=' Probleme dans prism_get_proto '
290	call abort_gcm(modname,abort_message,1)
291	endif
292
293	!
294	RETURN
295	END SUBROUTINE fromcpl
296
297	SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
298	& fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, &
299	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v, &
300	! -- LOOP
301	& windsp, &
302	! -- LOOP
303	& last)
304	! ======================================================================
305	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
306	! atmospheric coupling fields to the coupler with the psmile library.
307	! IF last time step, writes output fields to binary files.
308	! ======================================================================
309
310	use mod_prism_proto
311	use mod_prism_put_proto
312	use dimphy
313	use write_field_phy
314	IMPLICIT NONE
315
316	!
317	! parametres
318	!
319	integer :: kt, im, jm
320	real, dimension(im* jm) :: fsolice, fsolwat, fnsolwat, fnsolice
321	real, dimension(im* jm) :: fnsicedt, evice, evwat, lpre, spre
322	real, dimension(im* jm) :: dirunoff, rivrunoff, calving
323	real, dimension(im* jm) :: tauxx_u, tauxx_v, tauyy_u
324	real, dimension(im* jm) :: tauyy_v, tauzz_u, tauzz_v
325	real, dimension(im*jm) :: windsp
326	logical :: last
327	logical :: checkout=.FALSE.
328	integer :: istart,iend
329	integer :: wstart,wend
330	!
331	! local
332	!
333	integer, parameter :: nuout = 6
334	integer :: ierror
335	character (len = 20),save :: modname = 'intocpl'
336	character (len = 80) :: abort_message
337	!
338	!
339	WRITE(nuout,*) ' '
340	WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
341	WRITE(nuout,*) 'last ', last
342	WRITE(nuout,*)
343
344	istart=iiphy_begin
345	if (phy_rank==phy_size-1) then
346	iend=(jjphy_end-jjphy_begin)*im+im
347	else
348	iend=(jjphy_end-jjphy_begin)*im+iiphy_end
349	endif
350
351	IF (checkout) THEN
352	wstart=istart
353	wend=iend
354	IF (phy_rank==0) wstart=istart+im-1
355	IF (phy_rank==phy_size-1) wend=iend-im+1
356
357	CALL writeField_phy("fsolice",fsolice(wstart:wend),1)
358	CALL writeField_phy("fsolwat",fsolwat(wstart:wend),1)
359	CALL writeField_phy("fnsolice",fnsolice(wstart:wend),1)
360	CALL writeField_phy("fnsolwat",fnsolwat(wstart:wend),1)
361	CALL writeField_phy("fnsicedt",fnsicedt(wstart:wend),1)
362	CALL writeField_phy("evice",evice(wstart:wend),1)
363	CALL writeField_phy("evwat",evwat(wstart:wend),1)
364	CALL writeField_phy("lpre",lpre(wstart:wend),1)
365	CALL writeField_phy("spre",spre(wstart:wend),1)
366	CALL writeField_phy("dirunoff",dirunoff(wstart:wend),1)
367	CALL writeField_phy("rivrunoff",rivrunoff(wstart:wend),1)
368	CALL writeField_phy("calving",calving(wstart:wend),1)
369	CALL writeField_phy("tauxx_u",tauxx_u(wstart:wend),1)
370	CALL writeField_phy("tauyy_u",tauyy_u(wstart:wend),1)
371	CALL writeField_phy("tauzz_u",tauzz_u(wstart:wend),1)
372	CALL writeField_phy("tauxx_v",tauxx_v(wstart:wend),1)
373	CALL writeField_phy("tauyy_v",tauyy_v(wstart:wend),1)
374	CALL writeField_phy("tauzz_v",tauzz_v(wstart:wend),1)
375	CALL writeField_phy("windsp",windsp(wstart:wend),1)
376	ENDIF
377
378	call prism_put_proto(il_out_var_id(8), kt, fsolice(istart:iend), ierror)
379	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
380	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
381	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
382	WRITE (nuout,*) cl_writ(8), kt
383	abort_message=' Probleme dans prism_put_proto '
384	call abort_gcm(modname,abort_message,1)
385	endif
386	call prism_put_proto(il_out_var_id(9), kt, fsolwat(istart:iend), ierror)
387	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
388	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
389	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
390	WRITE (nuout,*) cl_writ(9), kt
391	abort_message=' Probleme dans prism_put_proto '
392	call abort_gcm(modname,abort_message,1)
393	endif
394	call prism_put_proto(il_out_var_id(10), kt, fnsolice(istart:iend), ierror)
395	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
396	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
397	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
398	WRITE (nuout,*) cl_writ(10), kt
399	abort_message=' Probleme dans prism_put_proto '
400	call abort_gcm(modname,abort_message,1)
401	endif
402	call prism_put_proto(il_out_var_id(11), kt, fnsolwat(istart:iend), ierror)
403	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
404	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
405	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
406	WRITE (nuout,*) cl_writ(11), kt
407	abort_message=' Probleme dans prism_put_proto '
408	call abort_gcm(modname,abort_message,1)
409	endif
410	call prism_put_proto(il_out_var_id(12), kt, fnsicedt(istart:iend), ierror)
411	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
412	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
413	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
414	WRITE (nuout,*) cl_writ(12), kt
415	abort_message=' Probleme dans prism_put_proto '
416	call abort_gcm(modname,abort_message,1)
417	endif
418	call prism_put_proto(il_out_var_id(13), kt, evice(istart:iend), ierror)
419	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
420	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
421	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
422	WRITE (nuout,*) cl_writ(13), kt
423	abort_message=' Probleme dans prism_put_proto '
424	call abort_gcm(modname,abort_message,1)
425	endif
426	call prism_put_proto(il_out_var_id(14), kt, evwat(istart:iend), ierror)
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 (nuout,*) cl_writ(14), kt
431	abort_message=' Probleme dans prism_put_proto '
432	call abort_gcm(modname,abort_message,1)
433	endif
434	call prism_put_proto(il_out_var_id(15), kt, lpre(istart:iend), ierror)
435	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
436	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
437	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
438	WRITE (nuout,*) cl_writ(15), kt
439	abort_message=' Probleme dans prism_put_proto '
440	call abort_gcm(modname,abort_message,1)
441	endif
442	call prism_put_proto(il_out_var_id(16), kt, spre(istart:iend), ierror)
443	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
444	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
445	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
446	WRITE (nuout,*) cl_writ(16), kt
447	abort_message=' Probleme dans prism_put_proto '
448	call abort_gcm(modname,abort_message,1)
449	endif
450	call prism_put_proto(il_out_var_id(17), kt, dirunoff(istart:iend), ierror)
451	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
452	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
453	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
454	WRITE (nuout,*) cl_writ(17), kt
455	abort_message=' Probleme dans prism_put_proto '
456	call abort_gcm(modname,abort_message,1)
457	endif
458	call prism_put_proto(il_out_var_id(18), kt, rivrunoff(istart:iend), ierror)
459	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
460	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
461	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
462	WRITE (nuout,*) cl_writ(18), kt
463	abort_message=' Probleme dans prism_put_proto '
464	call abort_gcm(modname,abort_message,1)
465	endif
466	call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror)
467	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
468	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
469	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
470	WRITE (nuout,*) cl_writ(19), kt
471	abort_message=' Probleme dans prism_put_proto '
472	call abort_gcm(modname,abort_message,1)
473	endif
474	call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror)
475	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
476	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
477	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
478	WRITE (nuout,*) cl_writ(1), kt
479	abort_message=' Probleme dans prism_put_proto '
480	call abort_gcm(modname,abort_message,1)
481	endif
482	call prism_put_proto(il_out_var_id(2), kt, tauyy_u(istart:iend), ierror)
483	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
484	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
485	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
486	WRITE (nuout,*) cl_writ(2), kt
487	abort_message=' Probleme dans prism_put_proto '
488	call abort_gcm(modname,abort_message,1)
489	endif
490	call prism_put_proto(il_out_var_id(3), kt, tauzz_u(istart:iend), ierror)
491	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
492	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
493	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
494	WRITE (nuout,*) cl_writ(3), kt
495	abort_message=' Probleme dans prism_put_proto '
496	call abort_gcm(modname,abort_message,1)
497	endif
498	call prism_put_proto(il_out_var_id(4), kt, tauxx_v(istart:iend), ierror)
499	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
500	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
501	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
502	WRITE (nuout,*) cl_writ(4), kt
503	abort_message=' Probleme dans prism_put_proto '
504	call abort_gcm(modname,abort_message,1)
505	endif
506	call prism_put_proto(il_out_var_id(5), kt, tauyy_v(istart:iend), ierror)
507	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
508	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
509	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
510	WRITE (nuout,*) cl_writ(5), kt
511	abort_message=' Probleme dans prism_put_proto '
512	call abort_gcm(modname,abort_message,1)
513	endif
514	call prism_put_proto(il_out_var_id(6), kt, tauzz_v(istart:iend), ierror)
515	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
516	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
517	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
518	WRITE (nuout,*) cl_writ(6), kt
519	abort_message=' Probleme dans prism_put_proto '
520	call abort_gcm(modname,abort_message,1)
521	endif
522	call prism_put_proto(il_out_var_id(7), kt, windsp(istart:iend), ierror)
523	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
524	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
525	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
526	WRITE (nuout,*) cl_writ(7), kt
527	abort_message=' Probleme dans prism_put_proto '
528	call abort_gcm(modname,abort_message,1)
529	endif
530
531	if (last) then
532	IF (monocpu) THEN
533	call prism_terminate_proto(ierror)
534	IF (ierror .ne. PRISM_Ok) THEN
535	abort_message=' Probleme dans prism_terminate_proto '
536	call abort_gcm(modname,abort_message,1)
537	endif
538	ENDIF
539	endif
540
541
542	RETURN
543	END SUBROUTINE intocpl
544
545	END MODULE oasis

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

Download in other formats:

Original Format