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

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	!
[704]	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)
[524]	105	!
	106	! and domain decomposition
	107	!
	108	! monoproc case
	109	!
[704]	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
[524]	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	!
[626]	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'
[704]	143	! -- LOOP
[626]	144	cl_writ(7)='COWINDSP'
[704]	145	! -- LOOP
[626]	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'
[524]	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
[704]	221	use dimphy
[524]	222	IMPLICIT none
	223
	224	!
	225	! parametres
	226	!
	227	integer :: im, jm, kt
[704]	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
[524]	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
[704]	239	integer :: istart,iend
[524]	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
[704]	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)
[626]	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
[524]	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
[704]	265	call prism_get_proto(in_var_id(2), kt, gla(istart:iend), ierror)
[626]	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
[524]	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
[704]	274	call prism_get_proto(in_var_id(3), kt, albedo(istart:iend), ierror)
[626]	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
[524]	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
[704]	283	call prism_get_proto(in_var_id(4), kt, tice(istart:iend), ierror)
[626]	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
[524]	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, &
[704]	299	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v, &
	300	! -- LOOP
	301	& windsp, &
	302	! -- LOOP
	303	& last)
[524]	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
[704]	312	use dimphy
	313	use write_field_phy
[524]	314	IMPLICIT NONE
	315
	316	!
	317	! parametres
	318	!
	319	integer :: kt, im, jm
[704]	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
[524]	326	logical :: last
[704]	327	logical :: checkout=.FALSE.
	328	integer :: istart,iend
	329	integer :: wstart,wend
[524]	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
[704]	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)
[626]	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
[524]	383	abort_message=' Probleme dans prism_put_proto '
	384	call abort_gcm(modname,abort_message,1)
	385	endif
[704]	386	call prism_put_proto(il_out_var_id(9), kt, fsolwat(istart:iend), ierror)
[626]	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
[524]	391	abort_message=' Probleme dans prism_put_proto '
	392	call abort_gcm(modname,abort_message,1)
	393	endif
[704]	394	call prism_put_proto(il_out_var_id(10), kt, fnsolice(istart:iend), ierror)
[626]	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
[524]	399	abort_message=' Probleme dans prism_put_proto '
	400	call abort_gcm(modname,abort_message,1)
	401	endif
[704]	402	call prism_put_proto(il_out_var_id(11), kt, fnsolwat(istart:iend), ierror)
[626]	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
[524]	407	abort_message=' Probleme dans prism_put_proto '
	408	call abort_gcm(modname,abort_message,1)
	409	endif
[704]	410	call prism_put_proto(il_out_var_id(12), kt, fnsicedt(istart:iend), ierror)
[626]	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
[524]	415	abort_message=' Probleme dans prism_put_proto '
	416	call abort_gcm(modname,abort_message,1)
	417	endif
[704]	418	call prism_put_proto(il_out_var_id(13), kt, evice(istart:iend), ierror)
[626]	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
[524]	423	abort_message=' Probleme dans prism_put_proto '
	424	call abort_gcm(modname,abort_message,1)
	425	endif
[704]	426	call prism_put_proto(il_out_var_id(14), kt, evwat(istart:iend), ierror)
[626]	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
[524]	431	abort_message=' Probleme dans prism_put_proto '
	432	call abort_gcm(modname,abort_message,1)
	433	endif
[704]	434	call prism_put_proto(il_out_var_id(15), kt, lpre(istart:iend), ierror)
[626]	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
[524]	439	abort_message=' Probleme dans prism_put_proto '
	440	call abort_gcm(modname,abort_message,1)
	441	endif
[704]	442	call prism_put_proto(il_out_var_id(16), kt, spre(istart:iend), ierror)
[626]	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
[524]	447	abort_message=' Probleme dans prism_put_proto '
	448	call abort_gcm(modname,abort_message,1)
	449	endif
[704]	450	call prism_put_proto(il_out_var_id(17), kt, dirunoff(istart:iend), ierror)
[626]	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
[524]	455	abort_message=' Probleme dans prism_put_proto '
	456	call abort_gcm(modname,abort_message,1)
	457	endif
[704]	458	call prism_put_proto(il_out_var_id(18), kt, rivrunoff(istart:iend), ierror)
[626]	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
[524]	463	abort_message=' Probleme dans prism_put_proto '
	464	call abort_gcm(modname,abort_message,1)
	465	endif
[704]	466	call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror)
[626]	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
[524]	471	abort_message=' Probleme dans prism_put_proto '
	472	call abort_gcm(modname,abort_message,1)
	473	endif
[704]	474	call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror)
[626]	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
[524]	479	abort_message=' Probleme dans prism_put_proto '
	480	call abort_gcm(modname,abort_message,1)
	481	endif
[704]	482	call prism_put_proto(il_out_var_id(2), kt, tauyy_u(istart:iend), ierror)
[626]	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
[524]	487	abort_message=' Probleme dans prism_put_proto '
	488	call abort_gcm(modname,abort_message,1)
	489	endif
[704]	490	call prism_put_proto(il_out_var_id(3), kt, tauzz_u(istart:iend), ierror)
[626]	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
[524]	495	abort_message=' Probleme dans prism_put_proto '
	496	call abort_gcm(modname,abort_message,1)
	497	endif
[704]	498	call prism_put_proto(il_out_var_id(4), kt, tauxx_v(istart:iend), ierror)
[626]	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
[524]	503	abort_message=' Probleme dans prism_put_proto '
	504	call abort_gcm(modname,abort_message,1)
	505	endif
[704]	506	call prism_put_proto(il_out_var_id(5), kt, tauyy_v(istart:iend), ierror)
[626]	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
[524]	511	abort_message=' Probleme dans prism_put_proto '
	512	call abort_gcm(modname,abort_message,1)
	513	endif
[704]	514	call prism_put_proto(il_out_var_id(6), kt, tauzz_v(istart:iend), ierror)
[626]	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
[524]	519	abort_message=' Probleme dans prism_put_proto '
	520	call abort_gcm(modname,abort_message,1)
	521	endif
[704]	522	call prism_put_proto(il_out_var_id(7), kt, windsp(istart:iend), ierror)
[626]	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
[524]	530
	531	if (last) then
[704]	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
[524]	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