Context Navigation

oasis.psmile @ 746

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

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

Download in other formats:

Original Format