Context Navigation

oasis.psmile @ 5415

Last change on this file since 5415 was 748, checked in by lsce, 18 years ago
ACo : correction monocupu en monocpu
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 20.3 KB

Rev	Line
[524]	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
[626]	24	CHARACTER (len=8), dimension(jpmaxfld), public, save :: cl_writ, cl_read
[524]	25	CHARACTER (len=8), dimension(jpmaxfld), save :: cl_f_writ, cl_f_read
	26
[626]	27	CONTAINS
[524]	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
[704]	47	use dimphy
[524]	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
[626]	62	integer :: ierror, il_commlocal
[524]	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	!
[748]	96	IF (monocpu) THEN
[746]	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
[704]	107	call prism_get_localcomm_proto (il_commlocal, ierror)
[524]	108	!
	109	! and domain decomposition
	110	!
	111	! monoproc case
	112	!
[704]	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
[524]	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	!
[626]	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'
[704]	146	! -- LOOP
[626]	147	cl_writ(7)='COWINDSP'
[704]	148	! -- LOOP
[626]	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'
[524]	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
[704]	224	use dimphy
[524]	225	IMPLICIT none
	226
	227	!
	228	! parametres
	229	!
	230	integer :: im, jm, kt
[704]	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
[524]	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
[704]	242	integer :: istart,iend
[524]	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
[704]	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)
[626]	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
[524]	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
[704]	268	call prism_get_proto(in_var_id(2), kt, gla(istart:iend), ierror)
[626]	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
[524]	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
[704]	277	call prism_get_proto(in_var_id(3), kt, albedo(istart:iend), ierror)
[626]	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
[524]	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
[704]	286	call prism_get_proto(in_var_id(4), kt, tice(istart:iend), ierror)
[626]	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
[524]	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, &
[704]	302	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v, &
	303	! -- LOOP
	304	& windsp, &
	305	! -- LOOP
	306	& last)
[524]	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
[704]	315	use dimphy
	316	use write_field_phy
[524]	317	IMPLICIT NONE
	318
	319	!
	320	! parametres
	321	!
	322	integer :: kt, im, jm
[704]	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
[524]	329	logical :: last
[704]	330	logical :: checkout=.FALSE.
	331	integer :: istart,iend
	332	integer :: wstart,wend
[524]	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
[704]	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)
[626]	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
[524]	386	abort_message=' Probleme dans prism_put_proto '
	387	call abort_gcm(modname,abort_message,1)
	388	endif
[704]	389	call prism_put_proto(il_out_var_id(9), kt, fsolwat(istart:iend), ierror)
[626]	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
[524]	394	abort_message=' Probleme dans prism_put_proto '
	395	call abort_gcm(modname,abort_message,1)
	396	endif
[704]	397	call prism_put_proto(il_out_var_id(10), kt, fnsolice(istart:iend), ierror)
[626]	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
[524]	402	abort_message=' Probleme dans prism_put_proto '
	403	call abort_gcm(modname,abort_message,1)
	404	endif
[704]	405	call prism_put_proto(il_out_var_id(11), kt, fnsolwat(istart:iend), ierror)
[626]	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
[524]	410	abort_message=' Probleme dans prism_put_proto '
	411	call abort_gcm(modname,abort_message,1)
	412	endif
[704]	413	call prism_put_proto(il_out_var_id(12), kt, fnsicedt(istart:iend), ierror)
[626]	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
[524]	418	abort_message=' Probleme dans prism_put_proto '
	419	call abort_gcm(modname,abort_message,1)
	420	endif
[704]	421	call prism_put_proto(il_out_var_id(13), kt, evice(istart:iend), ierror)
[626]	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
[524]	426	abort_message=' Probleme dans prism_put_proto '
	427	call abort_gcm(modname,abort_message,1)
	428	endif
[704]	429	call prism_put_proto(il_out_var_id(14), kt, evwat(istart:iend), ierror)
[626]	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
[524]	434	abort_message=' Probleme dans prism_put_proto '
	435	call abort_gcm(modname,abort_message,1)
	436	endif
[704]	437	call prism_put_proto(il_out_var_id(15), kt, lpre(istart:iend), ierror)
[626]	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
[524]	442	abort_message=' Probleme dans prism_put_proto '
	443	call abort_gcm(modname,abort_message,1)
	444	endif
[704]	445	call prism_put_proto(il_out_var_id(16), kt, spre(istart:iend), ierror)
[626]	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
[524]	450	abort_message=' Probleme dans prism_put_proto '
	451	call abort_gcm(modname,abort_message,1)
	452	endif
[704]	453	call prism_put_proto(il_out_var_id(17), kt, dirunoff(istart:iend), ierror)
[626]	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
[524]	458	abort_message=' Probleme dans prism_put_proto '
	459	call abort_gcm(modname,abort_message,1)
	460	endif
[704]	461	call prism_put_proto(il_out_var_id(18), kt, rivrunoff(istart:iend), ierror)
[626]	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
[524]	466	abort_message=' Probleme dans prism_put_proto '
	467	call abort_gcm(modname,abort_message,1)
	468	endif
[704]	469	call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror)
[626]	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
[524]	474	abort_message=' Probleme dans prism_put_proto '
	475	call abort_gcm(modname,abort_message,1)
	476	endif
[704]	477	call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror)
[626]	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
[524]	482	abort_message=' Probleme dans prism_put_proto '
	483	call abort_gcm(modname,abort_message,1)
	484	endif
[704]	485	call prism_put_proto(il_out_var_id(2), kt, tauyy_u(istart:iend), ierror)
[626]	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
[524]	490	abort_message=' Probleme dans prism_put_proto '
	491	call abort_gcm(modname,abort_message,1)
	492	endif
[704]	493	call prism_put_proto(il_out_var_id(3), kt, tauzz_u(istart:iend), ierror)
[626]	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
[524]	498	abort_message=' Probleme dans prism_put_proto '
	499	call abort_gcm(modname,abort_message,1)
	500	endif
[704]	501	call prism_put_proto(il_out_var_id(4), kt, tauxx_v(istart:iend), ierror)
[626]	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
[524]	506	abort_message=' Probleme dans prism_put_proto '
	507	call abort_gcm(modname,abort_message,1)
	508	endif
[704]	509	call prism_put_proto(il_out_var_id(5), kt, tauyy_v(istart:iend), ierror)
[626]	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
[524]	514	abort_message=' Probleme dans prism_put_proto '
	515	call abort_gcm(modname,abort_message,1)
	516	endif
[704]	517	call prism_put_proto(il_out_var_id(6), kt, tauzz_v(istart:iend), ierror)
[626]	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
[524]	522	abort_message=' Probleme dans prism_put_proto '
	523	call abort_gcm(modname,abort_message,1)
	524	endif
[704]	525	call prism_put_proto(il_out_var_id(7), kt, windsp(istart:iend), ierror)
[626]	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
[524]	533
	534	if (last) then
[704]	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
[524]	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