Context Navigation

oasis.psmile @ 778

Last change on this file since 778 was 776, checked in by Laurent Fairhead, 18 years ago
Suite du merge entre la version et la HEAD: quelques modifications de Yann sur le 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
[766]	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	!
[776]	96	IF (is_sequential) THEN
[766]	97	call prism_init_comp_proto (comp_id, clmodnam, ierror)
[524]	98
[766]	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
[524]	106
[766]	107	call prism_get_localcomm_proto (il_commlocal, ierror)
[524]	108	!
	109	! and domain decomposition
	110	!
	111	! monoproc case
	112	!
[766]	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 //
[776]	118	ig_paral(2) = (jj_begin-1)*im+ii_begin-1
	119	ig_paral(3) = (jj_endim+ii_end)-(jj_beginim+ii_begin)+1
	120	if (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+im-1
	121	print *,mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
[766]	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'
[766]	146	! -- LOOP
[626]	147	cl_writ(7)='COWINDSP'
[766]	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
[776]	224	USE dimphy
	225	USE mod_phys_lmdz_para
[524]	226	IMPLICIT none
	227
	228	!
	229	! parametres
	230	!
	231	integer :: im, jm, kt
[766]	232	real, dimension(im*jm) :: sst ! sea-surface-temperature
	233	real, dimension(im*jm) :: gla ! sea-ice
	234	real, dimension(im*jm) :: tice ! temp glace
	235	real, dimension(im*jm) :: albedo ! albedo glace
[524]	236	!
	237	! local variables
	238	!
	239	integer :: nuout = 6 ! listing output unit
	240	integer :: ierror
	241	character (len = 20),save :: modname = 'fromcpl'
	242	character (len = 80) :: abort_message
[766]	243	integer :: istart,iend
[524]	244	!
	245	#include "param_cou.h"
	246	!
	247	!
	248	WRITE (nuout,*) ' '
	249	WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
	250	WRITE (nuout,*) ' '
	251	CALL flush (nuout)
	252
[776]	253	istart=ii_begin
	254	if (is_south_pole) then
	255	iend=(jj_end-jj_begin)*im+im
[766]	256	else
[776]	257	iend=(jj_end-jj_begin)*im+ii_end
[766]	258	endif
	259
	260	call prism_get_proto(in_var_id(1), kt, sst(istart:iend), ierror)
[626]	261	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
	262	& ierror.ne.PRISM_FromRest &
	263	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
	264	& .and. ierror.ne.PRISM_FromRestOut) THEN
[524]	265	WRITE (nuout,*) cl_read(1), kt
	266	abort_message=' Probleme dans prism_get_proto '
	267	call abort_gcm(modname,abort_message,1)
	268	endif
[766]	269	call prism_get_proto(in_var_id(2), kt, gla(istart:iend), ierror)
[626]	270	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
	271	& ierror.ne.PRISM_FromRest &
	272	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
	273	& .and. ierror.ne.PRISM_FromRestOut) THEN
[524]	274	WRITE (nuout,*) cl_read(2), kt
	275	abort_message=' Probleme dans prism_get_proto '
	276	call abort_gcm(modname,abort_message,1)
	277	endif
[766]	278	call prism_get_proto(in_var_id(3), kt, albedo(istart:iend), ierror)
[626]	279	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
	280	& ierror.ne.PRISM_FromRest &
	281	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
	282	& .and. ierror.ne.PRISM_FromRestOut) THEN
[524]	283	WRITE (nuout,*) cl_read(3), kt
	284	abort_message=' Probleme dans prism_get_proto '
	285	call abort_gcm(modname,abort_message,1)
	286	endif
[766]	287	call prism_get_proto(in_var_id(4), kt, tice(istart:iend), ierror)
[626]	288	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Recvd .and. &
	289	& ierror.ne.PRISM_FromRest &
	290	& .and. ierror.ne.PRISM_Input .and. ierror.ne.PRISM_RecvOut &
	291	& .and. ierror.ne.PRISM_FromRestOut) THEN
[524]	292	WRITE (nuout,*) cl_read(4), kt
	293	abort_message=' Probleme dans prism_get_proto '
	294	call abort_gcm(modname,abort_message,1)
	295	endif
	296
	297	!
	298	RETURN
	299	END SUBROUTINE fromcpl
	300
	301	SUBROUTINE intocpl(kt, im, jm, fsolice, fsolwat, fnsolice, fnsolwat, &
	302	& fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff, &
[766]	303	& calving, tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v, &
	304	! -- LOOP
	305	& windsp, &
	306	! -- LOOP
	307	& last)
[524]	308	! ======================================================================
	309	! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the
	310	! atmospheric coupling fields to the coupler with the psmile library.
	311	! IF last time step, writes output fields to binary files.
	312	! ======================================================================
	313
	314	use mod_prism_proto
	315	use mod_prism_put_proto
[776]	316	USE dimphy
	317	USE mod_phys_lmdz_para
[766]	318	use write_field_phy
[524]	319	IMPLICIT NONE
	320
	321	!
	322	! parametres
	323	!
	324	integer :: kt, im, jm
[766]	325	real, dimension(im* jm) :: fsolice, fsolwat, fnsolwat, fnsolice
	326	real, dimension(im* jm) :: fnsicedt, evice, evwat, lpre, spre
	327	real, dimension(im* jm) :: dirunoff, rivrunoff, calving
	328	real, dimension(im* jm) :: tauxx_u, tauxx_v, tauyy_u
	329	real, dimension(im* jm) :: tauyy_v, tauzz_u, tauzz_v
	330	real, dimension(im*jm) :: windsp
[524]	331	logical :: last
[766]	332	logical :: checkout=.FALSE.
	333	integer :: istart,iend
	334	integer :: wstart,wend
[524]	335	!
	336	! local
	337	!
	338	integer, parameter :: nuout = 6
	339	integer :: ierror
	340	character (len = 20),save :: modname = 'intocpl'
	341	character (len = 80) :: abort_message
	342	!
	343	!
	344	WRITE(nuout,*) ' '
	345	WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
	346	WRITE(nuout,*) 'last ', last
	347	WRITE(nuout,*)
	348
[776]	349	istart=ii_begin
	350	if (is_south_pole) then
	351	iend=(jj_end-jj_begin)*im+im
[766]	352	else
[776]	353	iend=(jj_end-jj_begin)*im+ii_end
[766]	354	endif
	355
	356	IF (checkout) THEN
	357	wstart=istart
	358	wend=iend
[776]	359	IF (is_north_pole) wstart=istart+im-1
	360	IF (is_south_pole) wend=iend-im+1
[766]	361
	362	CALL writeField_phy("fsolice",fsolice(wstart:wend),1)
	363	CALL writeField_phy("fsolwat",fsolwat(wstart:wend),1)
	364	CALL writeField_phy("fnsolice",fnsolice(wstart:wend),1)
	365	CALL writeField_phy("fnsolwat",fnsolwat(wstart:wend),1)
	366	CALL writeField_phy("fnsicedt",fnsicedt(wstart:wend),1)
	367	CALL writeField_phy("evice",evice(wstart:wend),1)
	368	CALL writeField_phy("evwat",evwat(wstart:wend),1)
	369	CALL writeField_phy("lpre",lpre(wstart:wend),1)
	370	CALL writeField_phy("spre",spre(wstart:wend),1)
	371	CALL writeField_phy("dirunoff",dirunoff(wstart:wend),1)
	372	CALL writeField_phy("rivrunoff",rivrunoff(wstart:wend),1)
	373	CALL writeField_phy("calving",calving(wstart:wend),1)
	374	CALL writeField_phy("tauxx_u",tauxx_u(wstart:wend),1)
	375	CALL writeField_phy("tauyy_u",tauyy_u(wstart:wend),1)
	376	CALL writeField_phy("tauzz_u",tauzz_u(wstart:wend),1)
	377	CALL writeField_phy("tauxx_v",tauxx_v(wstart:wend),1)
	378	CALL writeField_phy("tauyy_v",tauyy_v(wstart:wend),1)
	379	CALL writeField_phy("tauzz_v",tauzz_v(wstart:wend),1)
	380	CALL writeField_phy("windsp",windsp(wstart:wend),1)
	381	ENDIF
	382
	383	call prism_put_proto(il_out_var_id(8), kt, fsolice(istart:iend), ierror)
[626]	384	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	385	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	386	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	387	WRITE (nuout,*) cl_writ(8), kt
[524]	388	abort_message=' Probleme dans prism_put_proto '
	389	call abort_gcm(modname,abort_message,1)
	390	endif
[766]	391	call prism_put_proto(il_out_var_id(9), kt, fsolwat(istart:iend), ierror)
[626]	392	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	393	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	394	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	395	WRITE (nuout,*) cl_writ(9), kt
[524]	396	abort_message=' Probleme dans prism_put_proto '
	397	call abort_gcm(modname,abort_message,1)
	398	endif
[766]	399	call prism_put_proto(il_out_var_id(10), kt, fnsolice(istart:iend), ierror)
[626]	400	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	401	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	402	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	403	WRITE (nuout,*) cl_writ(10), kt
[524]	404	abort_message=' Probleme dans prism_put_proto '
	405	call abort_gcm(modname,abort_message,1)
	406	endif
[766]	407	call prism_put_proto(il_out_var_id(11), kt, fnsolwat(istart:iend), ierror)
[626]	408	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	409	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	410	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	411	WRITE (nuout,*) cl_writ(11), kt
[524]	412	abort_message=' Probleme dans prism_put_proto '
	413	call abort_gcm(modname,abort_message,1)
	414	endif
[766]	415	call prism_put_proto(il_out_var_id(12), kt, fnsicedt(istart:iend), ierror)
[626]	416	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	417	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	418	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	419	WRITE (nuout,*) cl_writ(12), kt
[524]	420	abort_message=' Probleme dans prism_put_proto '
	421	call abort_gcm(modname,abort_message,1)
	422	endif
[766]	423	call prism_put_proto(il_out_var_id(13), kt, evice(istart:iend), ierror)
[626]	424	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	425	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	426	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	427	WRITE (nuout,*) cl_writ(13), kt
[524]	428	abort_message=' Probleme dans prism_put_proto '
	429	call abort_gcm(modname,abort_message,1)
	430	endif
[766]	431	call prism_put_proto(il_out_var_id(14), kt, evwat(istart:iend), ierror)
[626]	432	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	433	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	434	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	435	WRITE (nuout,*) cl_writ(14), kt
[524]	436	abort_message=' Probleme dans prism_put_proto '
	437	call abort_gcm(modname,abort_message,1)
	438	endif
[766]	439	call prism_put_proto(il_out_var_id(15), kt, lpre(istart:iend), ierror)
[626]	440	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	441	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	442	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	443	WRITE (nuout,*) cl_writ(15), kt
[524]	444	abort_message=' Probleme dans prism_put_proto '
	445	call abort_gcm(modname,abort_message,1)
	446	endif
[766]	447	call prism_put_proto(il_out_var_id(16), kt, spre(istart:iend), ierror)
[626]	448	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	449	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	450	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	451	WRITE (nuout,*) cl_writ(16), kt
[524]	452	abort_message=' Probleme dans prism_put_proto '
	453	call abort_gcm(modname,abort_message,1)
	454	endif
[766]	455	call prism_put_proto(il_out_var_id(17), kt, dirunoff(istart:iend), ierror)
[626]	456	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	457	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	458	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	459	WRITE (nuout,*) cl_writ(17), kt
[524]	460	abort_message=' Probleme dans prism_put_proto '
	461	call abort_gcm(modname,abort_message,1)
	462	endif
[766]	463	call prism_put_proto(il_out_var_id(18), kt, rivrunoff(istart:iend), ierror)
[626]	464	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	465	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	466	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	467	WRITE (nuout,*) cl_writ(18), kt
[524]	468	abort_message=' Probleme dans prism_put_proto '
	469	call abort_gcm(modname,abort_message,1)
	470	endif
[766]	471	call prism_put_proto(il_out_var_id(19), kt, calving(istart:iend), ierror)
[626]	472	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	473	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	474	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	475	WRITE (nuout,*) cl_writ(19), kt
[524]	476	abort_message=' Probleme dans prism_put_proto '
	477	call abort_gcm(modname,abort_message,1)
	478	endif
[766]	479	call prism_put_proto(il_out_var_id(1), kt, tauxx_u(istart:iend), ierror)
[626]	480	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	481	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	482	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	483	WRITE (nuout,*) cl_writ(1), kt
[524]	484	abort_message=' Probleme dans prism_put_proto '
	485	call abort_gcm(modname,abort_message,1)
	486	endif
[766]	487	call prism_put_proto(il_out_var_id(2), kt, tauyy_u(istart:iend), ierror)
[626]	488	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	489	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	490	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	491	WRITE (nuout,*) cl_writ(2), kt
[524]	492	abort_message=' Probleme dans prism_put_proto '
	493	call abort_gcm(modname,abort_message,1)
	494	endif
[766]	495	call prism_put_proto(il_out_var_id(3), kt, tauzz_u(istart:iend), ierror)
[626]	496	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	497	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	498	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	499	WRITE (nuout,*) cl_writ(3), kt
[524]	500	abort_message=' Probleme dans prism_put_proto '
	501	call abort_gcm(modname,abort_message,1)
	502	endif
[766]	503	call prism_put_proto(il_out_var_id(4), kt, tauxx_v(istart:iend), ierror)
[626]	504	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	505	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	506	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	507	WRITE (nuout,*) cl_writ(4), kt
[524]	508	abort_message=' Probleme dans prism_put_proto '
	509	call abort_gcm(modname,abort_message,1)
	510	endif
[766]	511	call prism_put_proto(il_out_var_id(5), kt, tauyy_v(istart:iend), ierror)
[626]	512	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	513	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	514	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	515	WRITE (nuout,*) cl_writ(5), kt
[524]	516	abort_message=' Probleme dans prism_put_proto '
	517	call abort_gcm(modname,abort_message,1)
	518	endif
[766]	519	call prism_put_proto(il_out_var_id(6), kt, tauzz_v(istart:iend), ierror)
[626]	520	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	521	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	522	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	523	WRITE (nuout,*) cl_writ(6), kt
[524]	524	abort_message=' Probleme dans prism_put_proto '
	525	call abort_gcm(modname,abort_message,1)
	526	endif
[766]	527	call prism_put_proto(il_out_var_id(7), kt, windsp(istart:iend), ierror)
[626]	528	IF (ierror .ne. PRISM_Ok .and. ierror.ne.PRISM_Sent .and. ierror.ne.PRISM_ToRest &
	529	& .and. ierror.ne.PRISM_LocTrans .and. ierror.ne.PRISM_Output .and. &
	530	& ierror.ne.PRISM_SentOut .and. ierror.ne.PRISM_ToRestOut) THEN
	531	WRITE (nuout,*) cl_writ(7), kt
	532	abort_message=' Probleme dans prism_put_proto '
	533	call abort_gcm(modname,abort_message,1)
	534	endif
[524]	535
	536	if (last) then
[776]	537	IF (is_sequential) THEN
[766]	538	call prism_terminate_proto(ierror)
	539	IF (ierror .ne. PRISM_Ok) THEN
	540	abort_message=' Probleme dans prism_terminate_proto '
	541	call abort_gcm(modname,abort_message,1)
	542	endif
	543	ENDIF
[524]	544	endif
	545
	546
	547	RETURN
	548	END SUBROUTINE intocpl
	549
	550	END MODULE oasis

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

Download in other formats:

Original Format