Context Navigation

oasis.F @ 98

Last change on this file since 98 was 98, checked in by lmdzadmin, 24 years ago
Interface avec les differentes surface, version de travail.LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 24.8 KB

Rev	Line
[2]	1	c
	2	C****
	3	C *****************
	4	C * OASIS ROUTINE *
	5	C * ------------- *
	6	C *****************
	7	C
	8	C**** INICMA - Initialize coupled mode communication for atmosphere
	9	C
	10	C Purpose:
	11	C -------
	12	C Exchange process identifiers and timestep information
	13	C between AGCM, OGCM and COUPLER.
	14	C
	15	C Input:
	16	C -----
	17	C KASTP : total number of timesteps in atmospheric model
	18	C KEXCH : frequency of exchange (in time steps)
	19	C KSTEP : timestep value (in seconds)
	20	C
	21	C Method:
	22	C ------
	23	C Use named pipes(FIFO) to exchange process identifiers
	24	C between the programs
	25	C
	26	C Externals:
	27	C ---------
	28	C GETPID, MKNOD
	29	C
	30	C Reference:
	31	C ---------
	32	C See Epicoa 0803 (1992)
	33	C
	34	C Author:
	35	C -------
	36	C Laurent Terray 92-09-01
	37	C
	38	C -----------------------------------------------------------
	39	C
[13]	40	SUBROUTINE inicma(kastp,kexch,kstep)
	41	c
	42	INTEGER kastp, kexch, kstep
	43	c
	44	INTEGER ime
	45	PARAMETER (ime = 1)
	46
	47	INTEGER iparal(3)
	48	INTEGER ifcpl, idt, info, imxtag, istep
	49	c
[2]	50	#include "dimensions.h"
	51	#include "dimphy.h"
	52	#include "oasis.h"
	53	#include "clim.h"
	54	c
[13]	55	c Addition for SIPC CASE
	56	#include "param_sipc.h"
	57	#include "param_cou.h"
	58	#include "inc_sipc.h"
	59	#include "inc_cpl.h"
	60	CHARACTER*9 clpoolnam
	61	INTEGER ipoolhandle, imrc, ipoolsize, index, jf
	62	CHARACTER*3 cljobnam ! experiment name
	63	CHARACTER*6 clmodnam ! model name
	64	CHARACTER*5 cloasis ! coupler name (Oasis)
	65	INTEGER imess(4), imesso(4)
	66	INTEGER getpid, mknod ! system functions
	67	CHARACTER*80 clcmd
	68	CHARACTER*8 pipnom, fldnom
	69	INTEGER ierror, iretcode
[2]	70	C
	71	INTEGER nuout
	72	PARAMETER (nuout = 6)
[13]	73	c
	74	C
	75	c
	76
[2]	77	C -----------------------------------------------------------
	78	C
	79	C* 1. Initializations
	80	C ---------------
	81	C
	82	WRITE(nuout,*) ' '
	83	WRITE(nuout,*) ' '
	84	WRITE(nuout,*) ' ROUTINE INICMA'
	85	WRITE(nuout,) ' *************'
	86	WRITE(nuout,*) ' '
	87	WRITE(nuout,*) ' '
	88	c
[13]	89	c 1.2.1-Define the model name
[2]	90	c
[13]	91	clmodnam = 'lmd.xx' ! as $NBMODEL in namcouple
[2]	92	c
[13]	93	c 1.2.2-Define the coupler name
[2]	94	c
[13]	95	cloasis = 'Oasis' ! as in coupler
[2]	96	c
	97	c
[13]	98	c 1.3.1-Define symbolic name for fields exchanged from atmos to coupler,
	99	c must be the same as (1) of the field definition in namcouple:
[2]	100	c
[13]	101	cl_writ(1)='CONSFTOT'
	102	cl_writ(2)='COSHFTOT'
	103	cl_writ(3)='COTOPRSU'
	104	cl_writ(4)='COTFSHSU'
	105	cl_writ(5)='CORUNCOA'
	106	cl_writ(6)='CORIVFLU'
	107	cl_writ(7)='COZOTAUX'
	108	cl_writ(8)='COZOTAU2'
	109	cl_writ(9)='COMETAUY'
	110	cl_writ(10)='COMETAU2'
[2]	111	c
[13]	112	c 1.3.2-Define files name for fields exchanged from atmos to coupler,
	113	c must be the same as (6) of the field definition in namcouple:
[2]	114	c
[13]	115	cl_f_writ(1)='atmflx'
	116	cl_f_writ(2)='atmflx'
	117	cl_f_writ(3)='atmflx'
	118	cl_f_writ(4)='atmflx'
	119	cl_f_writ(5)='atmflx'
	120	cl_f_writ(6)='atmflx'
	121	cl_f_writ(7)='atmtau'
	122	cl_f_writ(8)='atmtau'
	123	cl_f_writ(9)='atmtau'
	124	cl_f_writ(10)='atmtau'
[2]	125	c
	126	c
[13]	127	c 1.4.1-Define symbolic name for fields exchanged from coupler to atmosphere,
	128	c must be the same as (2) of the field definition in namcouple:
[2]	129	c
[13]	130	cl_read(1)='SISUTESU'
	131	cl_read(2)='SIICECOV'
[2]	132	c
[13]	133	c 1.4.2-Define files names for fields exchanged from coupler to atmosphere,
	134	c must be the same as (7) of the field definition in namcouple:
[2]	135	c
[13]	136	cl_f_read(1)='atmsst'
	137	cl_f_read(2)='atmice'
[2]	138	c
[13]	139	c 1.5-Define infos for sending to oasis
[2]	140	c
[13]	141	imess(1) = kastp
	142	imess(2) = kexch
	143	imess(3) = kstep
	144	imess(4) = getpid()
	145
[2]	146	c
	147	c
[13]	148	IF (cchan.eq.'PIPE') THEN
[2]	149	c
[13]	150	ierror=0
[2]	151	c
	152	c
[13]	153	WRITE(nuout,*) ' '
	154	WRITE(nuout,*) 'Making pipes for fields to receive from CPL'
	155	WRITE(nuout,*) ' '
[2]	156	c
[13]	157	c loop to define pipes (ocean=CPL to atmos)
[2]	158	c
[13]	159	DO jf=1, jpfldo2a
	160	CALL PIPE_Model_Define(nuout, cl_read(jf), jpread, iretcode)
	161	IF (iretcode.ne.0) ierror=ierror+1
	162	END DO
[2]	163	c
[13]	164	WRITE(nuout,*) ' '
	165	WRITE(nuout,*) 'Making pipes for fields to send to CPL'
	166	WRITE(nuout,*) ' '
[2]	167	c
[13]	168	c loop to define pipes (atmos to ocean=CPL)
[2]	169	c
[13]	170	DO jf=1, jpflda2o
	171	CALL PIPE_Model_Define(nuout, cl_writ(jf), jpwrit, iretcode)
	172	IF (iretcode.ne.0) ierror=ierror+1
	173	END DO
[2]	174	c
[13]	175	IF (ierror.ne.0) THEN
	176	WRITE (nuout,*) 'Error in pipes definitions'
	177	WRITE (nuout,*) 'STOP inicma'
	178	CALL abort
	179	END IF
[2]	180	c
[13]	181	WRITE(nuout,*) ' '
	182	WRITE(nuout,*) 'All pipes have been made'
	183	WRITE(nuout,*) ' '
[2]	184	c
[13]	185	WRITE(nuout,*) ' '
	186	WRITE(nuout,*) 'Communication test between ATM and CPL'
	187	WRITE(nuout,*) ' '
	188	CALL flush(nuout)
[2]	189	c
[13]	190	CALL PIPE_Model_Stepi(nuout, imess, ime, imesso, ierror)
	191	c
	192	IF (ierror.ne.0) THEN
	193	WRITE (nuout,*)
	194	$ 'Error in exchange first informations with Oasis'
	195	WRITE (nuout,*) 'STOP inicma'
	196	CALL abort
	197	END IF
	198	c
	199	WRITE(nuout,*) ' '
	200	WRITE(nuout,*) 'Communication test between ATM and CPL is OK'
	201	WRITE(nuout,*) ' total simulation time in oasis = ', imesso(1)
	202	WRITE(nuout,*) ' total number of iterations is = ', imesso(2)
	203	WRITE(nuout,*) ' value of oasis timestep is = ', imesso(3)
	204	WRITE(nuout,*) ' process id for oasis is = ', imesso(4)
	205	WRITE(nuout,*) ' '
	206	CALL flush(nuout)
	207	c
	208	ELSE IF (cchan.eq.'SIPC') THEN
	209	c
	210	c debug for more information
	211	c
	212	c CALL SVIPC_debug(1)
	213	c
	214	c
	215	c 1.1-Define the experiment name :
	216	c
	217	cljobnam = 'IPC' ! as $JOBNAM in namcouple
	218	c
	219	c 3-Attach to shared memory pool used to exchange initial infos
	220	c
	221	imrc = 0
	222	CALL SIPC_Init_Model (cljobnam, clmodnam, 1, imrc)
	223	IF (imrc .NE. 0) THEN
	224	WRITE (nuout,*)' '
	225	WRITE (nuout,*)'WARNING: Problem with attachement to', imrc
	226	WRITE (nuout,*)' initial memory pool(s) in atmos'
	227	WRITE (nuout,*)' '
	228	CALL ABORT('STOP in atmos')
	229	ENDIF
	230	c
	231	c 4-Attach to pools used to exchange fields from atmos to coupler
	232	c
	233	DO jf = 1, jpflda2o
	234	c
	235	C
	236	c Pool name:
	237	clpoolnam = 'P'//cl_writ(jf)
	238	C
	239	CALL SIPC_Attach(clpoolnam, ipoolhandle)
	240	c
	241	c Resulting pool handle:
	242	mpoolwrit(jf) = ipoolhandle
	243	C
	244	END DO
	245	C
	246	c 5-Attach to pools used to exchange fields from coupler to atmos
	247	c
	248	DO jf = 1, jpfldo2a
	249	c
	250	c Pool name:
	251	clpoolnam = 'P'//cl_read(jf)
	252	c
	253	CALL SIPC_Attach(clpoolnam, ipoolhandle)
	254	c
	255	c Resulting pool handle:
	256	mpoolread(jf) = ipoolhandle
	257	c
	258	END DO
	259	c
	260	c 6-Exchange of initial infos
	261	c
	262	c Write data array isend to pool READ by Oasis
	263	c
	264	imrc = 0
	265	ipoolsize = 4*jpbyteint
	266	CALL SVIPC_Write(mpoolinitr, imess, ipoolsize, imrc)
	267	C
	268	C Find error if any
	269	C
	270	IF (imrc .LT. 0) THEN
	271	WRITE (nuout,*) ' '
	272	WRITE (nuout,*) 'Problem in atmos in writing initial'
	273	WRITE (nuout,*) 'infos to the shared memory segment(s)'
	274	WRITE (nuout,*) ' '
	275	ELSE
	276	WRITE (nuout,*) ' '
	277	WRITE (nuout,*) 'Initial infos written in atmos'
	278	WRITE (nuout,*) 'to the shared memory segment(s)'
	279	WRITE (nuout,*) ' '
	280	ENDIF
	281	C
	282	C Read data array irecv from pool written by Oasis
	283	C
	284	imrc = 0
	285	ipoolsize = 4*jpbyteint
	286	CALL SVIPC_Read(mpoolinitw, imesso, ipoolsize, imrc)
	287	C
	288	C* Find error if any
	289	C
	290	IF (imrc .LT. 0) THEN
	291	WRITE (nuout,*) ' '
	292	WRITE (nuout,*) 'Problem in atmos in reading initial'
	293	WRITE (nuout,*) 'infos from the shared memory segment(s)'
	294	WRITE (nuout,*) ' '
	295	ELSE
	296	WRITE (nuout,*) ' '
	297	WRITE (nuout,*) 'Initial infos read by atmos'
	298	WRITE (nuout,*) 'from the shared memory segment(s)'
	299	WRITE (nuout,*) ' '
	300	WRITE(,) ' ntime, niter, nstep, Oasis pid:'
	301	WRITE(,) imesso(1), imesso(2), imesso(3), imesso(4)
	302	ENDIF
	303	C
	304	C Detach from shared memory segment(s)
	305	C
	306	imrc = 0
	307	CALL SVIPC_close(mpoolinitw, 0, imrc)
	308	C
	309	C Find error if any
	310	C
	311	IF (imrc .LT. 0) THEN
	312	WRITE (nuout,*)
	313	$ 'Problem in detaching from shared memory segment(s)'
	314	WRITE (nuout,*)
	315	$ 'used by atmos to read initial infos'
	316	ENDIF
	317	c
	318	c
	319	ELSE IF (cchan.eq.'CLIM') THEN
	320
	321	c
	322	c 1.1-Define the experiment name :
	323	c
	324	cljobnam = 'CLI' ! as $JOBNAM in namcouple
	325
	326	OPEN ( UNIT = 7, FILE = 'trace', STATUS = 'unknown',
	327	$ FORM = 'formatted')
	328	CALL CLIM_Init ( cljobnam, clmodnam, 3, 7,
[2]	329	* kastp, kexch, kstep,
[13]	330	* 5, 3600, 3600, info )
[2]	331	c
[13]	332	IF (info.ne.clim_ok) THEN
	333	WRITE ( nuout, *) ' inicma : pb init clim '
	334	WRITE ( nuout, *) ' error code is = ', info
	335	CALL abort('STOP in inicma')
	336	ELSE
	337	WRITE(nuout,*) 'inicma : init clim ok '
	338	ENDIF
[2]	339	c
[13]	340	iparal ( clim_strategy ) = clim_serial
	341	iparal ( clim_length ) = iim*(jjm+1)
	342	iparal ( clim_offset ) = 0
[2]	343	c
[13]	344	c loop to define messages (CPL=ocean to atmos)
[2]	345	c
[13]	346	DO jf=1, jpfldo2a
	347	CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal
	348	$ , info )
	349	END DO
	350
[2]	351	c
[13]	352	c loop to define messages (atmos to ocean=CPL)
[2]	353	c
[13]	354	DO jf=1, jpflda2o
	355	CALL CLIM_Define (cl_writ(jf), clim_out , clim_double,
	356	$ iparal, info )
	357	END DO
	358
	359	WRITE(nuout,*) 'inicma : clim_define ok '
	360	CALL CLIM_Start ( imxtag, info )
	361	IF (info.ne.clim_ok) THEN
	362	WRITE ( nuout, *) 'inicma : pb start clim '
	363	WRITE ( nuout, *) ' error code is = ', info
	364	CALL abort('stop in inicma')
	365	ELSE
	366	WRITE ( nuout, *) 'inicma : start clim ok '
	367	ENDIF
[2]	368	c
[13]	369	CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info)
	370	IF (info .NE. clim_ok) THEN
	371	WRITE ( UNIT = nuout, FMT = *)
	372	$ ' warning : problem in getting step info ',
	373	$ 'from oasis '
	374	WRITE (UNIT = nuout, FMT = *)
	375	$ ' ======= error code number = ', info
	376	ELSE
	377	WRITE (UNIT = nuout, FMT = *)
	378	$ ' got step information from oasis '
	379	ENDIF
	380	WRITE ( nuout, *) ' number of tstep in oasis ', istep
	381	WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl
	382	WRITE ( nuout, *) ' length of tstep in oasis ', idt
	383	ENDIF
	384
[2]	385	RETURN
	386	END
[13]	387
[98]	388	SUBROUTINE fromcpl(kt, imjm, sst,sic, alb_sst, alb_sic )
[2]	389	IMPLICIT none
	390	c
	391	c Laurent Z.X Li (Feb. 10, 1997): It reads the SST and Sea-Ice
	392	c provided by the coupler. Of course, it waits until it receives
[13]	393	c the signal from the corresponding pipes.
	394	c 3 techniques:
	395	c - pipes and signals (only on Cray C90 and Cray J90)
	396	c - CLIM (PVM exchange messages)
	397	c - SVIPC shared memory segments and semaphores
[2]	398	c
[13]	399	INTEGER imjm, kt
	400	REAL sst(imjm) ! sea-surface-temperature
[98]	401	REAL alb_sst(imjm) ! open sea albedo
	402	REAL sic(imjm) ! sea ice cover
	403	REAL alb_sic(imjm) ! sea ice albedo
	404
[2]	405	c
[13]	406	INTEGER nuout ! listing output unit
[2]	407	PARAMETER (nuout=6)
	408	c
	409	INTEGER nuread, ios, iflag, icpliter
[13]	410	CHARACTER*8 pipnom ! name for the pipe
	411	CHARACTER*8 fldnom ! name for the field
	412	CHARACTER*8 filnom ! name for the data file
	413
	414	INTEGER info, jf
	415
[2]	416	c
	417	#include "oasis.h"
	418	#include "clim.h"
	419	c
[13]	420	#include "param_cou.h"
[2]	421	c
[13]	422	#include "inc_sipc.h"
	423	#include "inc_cpl.h"
[2]	424	c
[13]	425	c Addition for SIPC CASE
	426	INTEGER index
	427	CHARACTER*3 cmodinf ! Header or not
	428	CHARACTER*3 cljobnam_r ! Experiment name in the field brick, if any
	429	INTEGER infos(3) ! infos in the field brick, if any
[2]	430	c
[13]	431	c
	432	WRITE (nuout,*) ' '
	433	WRITE (nuout,*) 'Fromcpl: Read fields from CPL, kt=',kt
	434	WRITE (nuout,*) ' '
[2]	435	CALL flush (nuout)
[13]	436
	437	IF (cchan.eq.'PIPE') THEN
[2]	438	c
[13]	439	c UNIT number for fields
[2]	440	c
[13]	441	nuread = 99
[2]	442	c
[13]	443	c exchanges from ocean=CPL to atmosphere
[2]	444	c
[13]	445	DO jf=1,jpfldo2a
	446	CALL PIPE_Model_Recv(cl_read(jf), icpliter, nuout)
	447	OPEN (nuread, FILE=cl_f_read(jf), FORM='UNFORMATTED')
	448	IF (jf.eq.1)
	449	$ CALL locread(cl_read(jf), sst, imjm, nuread, iflag,
	450	$ nuout)
	451	IF (jf.eq.2)
[98]	452	$ CALL locread(cl_read(jf), sic, imjm, nuread, iflag,
[13]	453	$ nuout)
[98]	454	IF (jf.eq.3)
	455	$ CALL locread(cl_read(jf), alb_sst, imjm, nuread, iflag,
	456	$ nuout)
	457	IF (jf.eq.4)
	458	$ CALL locread(cl_read(jf), alb_sic, imjm, nuread, iflag,
	459	$ nuout)
[13]	460	CLOSE (nuread)
	461	END DO
	462
[2]	463	c
[13]	464	ELSE IF (cchan.eq.'SIPC') THEN
[2]	465	c
[13]	466	c Define IF a header must be encapsulated within the field brick :
	467	cmodinf = 'NOT' ! as $MODINFO in namcouple
	468	c
	469	c reading of input field sea-surface-temperature SISUTESU
[2]	470	c
	471	c
[13]	472	c Index of sst in total number of fields jpfldo2a:
	473	index = 1
[2]	474	c
[13]	475	CALL SIPC_Read_Model(index, imjm, cmodinf,
	476	$ cljobnam_r,infos, sst)
[2]	477	c
[13]	478	c reading of input field sea-ice SIICECOV
[2]	479	c
	480	c
[13]	481	c Index of sea-ice in total number of fields jpfldo2a:
	482	index = 2
[2]	483	c
[13]	484	CALL SIPC_Read_Model(index, imjm, cmodinf,
[98]	485	$ cljobnam_r,infos, sic)
	486	c Index of open sea albedo in total number of fields jpfldo2a:
	487	index = 3
[2]	488	c
[98]	489	CALL SIPC_Read_Model(index, imjm, cmodinf,
	490	$ cljobnam_r,infos, alb_sst)
	491	c Index of sea-ice albedo in total number of fields jpfldo2a:
	492	index = 4
[13]	493	c
[98]	494	CALL SIPC_Read_Model(index, imjm, cmodinf,
	495	$ cljobnam_r,infos, alb_sic)
	496	c
	497	c
[13]	498	ELSE IF (cchan.eq.'CLIM') THEN
[2]	499
	500	c
[13]	501	c exchanges from ocean=CPL to atmosphere
	502	c
[98]	503	DO jf=1,jpfldo2a
	504	IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
	505	IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, sic, info)
	506	IF (jf.eq.3) CALL CLIM_Import (cl_read(jf) , kt, alb_sst, info)
	507	IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, alb_sic, info)
	508	IF ( info .NE. CLIM_Ok) THEN
[13]	509	WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
	510	WRITE(nuout,*)'Couplage kt is = ',kt
	511	WRITE(nuout,*)'CLIM error code is = ', info
	512	WRITE(nuout,*)'STOP in Fromcpl'
	513	STOP 'Fromcpl'
	514	ENDIF
	515	END DO
	516
	517	ENDIF
	518	c
[2]	519	RETURN
	520	END
	521
	522
[13]	523	SUBROUTINE intocpl(kt,imjm,
[2]	524	. fsol, fnsol,
	525	. rain, snow, evap, ruisoce, ruisriv,
[13]	526	. taux, tauy, last)
[2]	527	IMPLICIT NONE
	528	c
	529	c Laurent Z.X Li (Feb. 10, 1997): It provides several fields to the
	530	c coupler. Of course, it sends a message to the corresponding pipes
	531	c after the writting.
[13]	532	c 3 techniques : pipes
	533	c clim
	534	c svipc
	535	c IF last time step WRITE output files anway
[2]	536	c
[13]	537	#include "oasis.h"
	538
	539	INTEGER kt, imjm
[2]	540	c
	541	REAL fsol(imjm)
	542	REAL fnsol(imjm)
	543	REAL rain(imjm)
	544	REAL snow(imjm)
	545	REAL evap(imjm)
	546	REAL ruisoce(imjm)
	547	REAL ruisriv(imjm)
	548	REAL taux(imjm)
	549	REAL tauy(imjm)
[13]	550	LOGICAL last
[2]	551	c
	552	INTEGER nuout
	553	PARAMETER (nuout = 6)
	554	c
[13]	555	c Additions for SVIPC
[2]	556	c
[13]	557	INTEGER index
	558	INTEGER infos(3)
	559	CHARACTER*3 cmodinf ! Header or not
	560	CHARACTER*3 cljobnam ! experiment name
	561	c
[2]	562	#include "clim.h"
	563	c
[13]	564	#include "param_cou.h"
[2]	565	c
[13]	566	#include "inc_sipc.h"
	567	#include "inc_cpl.h"
[2]	568	c
	569	C
[13]	570	INTEGER nuwrit, ios
	571	CHARACTER*8 pipnom
	572	CHARACTER*8 fldnom
	573	CHARACTER*6 file_name(jpmaxfld)
	574	INTEGER max_file
	575	INTEGER file_unit_max, file_unit(jpmaxfld),
	576	$ file_unit_field(jpmaxfld)
	577
	578	INTEGER icstep, info, jn, jf, ierror
	579	LOGICAL trouve
[2]	580	c
	581	c
[13]	582	icstep=kt
[2]	583	c
[13]	584	WRITE(nuout,*) ' '
	585	WRITE(nuout,*) 'Intocpl: send fields to CPL, kt= ', kt
	586	WRITE(nuout,*) ' '
	587
	588	IF (last.or.(cchan.eq.'PIPE')) THEN
[2]	589	c
	590	c
[13]	591	c WRITE fields for coupler with pipe technique or for last time step
[2]	592	c
[13]	593	c initialisation
[2]	594	c
[13]	595	max_file=1
	596	file_unit_max=99
	597	c keeps first file name
	598	file_name(max_file)=cl_f_writ(max_file)
	599	c keeps first file unit
	600	file_unit(max_file)=file_unit_max
	601	c decrements file unit maximum
	602	file_unit_max=file_unit_max-1
	603	c keeps file unit for field
	604	file_unit_field(1)=file_unit(max_file)
[2]	605	c
[13]	606	c different files names counter
[2]	607	c
[13]	608
	609	DO jf= 2, jpflda2o
	610	trouve=.false.
	611	DO jn= 1, max_file
	612	IF (.not.trouve) THEN
	613	IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
	614	c keep file unit for field
	615	file_unit_field(jf)=file_unit(jn)
	616	trouve=.true.
	617	END IF
	618	END IF
	619	END DO
	620	IF (.not.trouve) then
	621	c increment the number of different files
	622	max_file=max_file+1
	623	c keep file name
	624	file_name(max_file)=cl_f_writ(jf)
	625	c keep file unit for file
	626	file_unit(max_file)=file_unit_max
	627	c keep file unit for field
	628	file_unit_field(jf)=file_unit(max_file)
	629	c decrement unit maximum number from 99 to 98, ...
	630	file_unit_max=file_unit_max-1
	631	END IF
	632	END DO
	633
	634	DO jn=1, max_file
	635	OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
	636	END DO
	637
	638	DO jf=1, jpflda2o
	639	IF (jf.eq.1)
	640	$ CALL locwrite(cl_writ(jf),fnsol, imjm,
	641	$ file_unit_field(jf), ierror, nuout)
	642	IF (jf.eq.2)
	643	$ CALL locwrite(cl_writ(jf),fsol, imjm,
	644	$ file_unit_field(jf), ierror, nuout)
	645	IF (jf.eq.3)
	646	$ CALL locwrite(cl_writ(jf),rain, imjm,
	647	$ file_unit_field(jf), ierror, nuout)
	648	IF (jf.eq.4)
	649	$ CALL locwrite(cl_writ(jf),evap, imjm,
	650	$ file_unit_field(jf), ierror, nuout)
	651	IF (jf.eq.5)
	652	$ CALL locwrite(cl_writ(jf),ruisoce, imjm,
	653	$ file_unit_field(jf),ierror, nuout)
	654	IF (jf.eq.6)
	655	$ CALL locwrite(cl_writ(jf),ruisriv, imjm,
	656	$ file_unit_field(jf),ierror, nuout)
	657	IF (jf.eq.7)
	658	$ CALL locwrite(cl_writ(jf),taux, imjm,
	659	$ file_unit_field(jf), ierror, nuout)
	660	IF (jf.eq.8)
	661	$ CALL locwrite(cl_writ(jf),taux, imjm,
	662	$ file_unit_field(jf), ierror, nuout)
	663	IF (jf.eq.9)
	664	$ CALL locwrite(cl_writ(jf),tauy, imjm,
	665	$ file_unit_field(jf), ierror, nuout)
	666	IF (jf.eq.10)
	667	$ CALL locwrite(cl_writ(jf),tauy, imjm,
	668	$ file_unit_field(jf), ierror, nuout)
	669	END DO
	670	C
	671	C simulate a FLUSH
	672	C
	673	DO jn=1, max_file
	674	CLOSE (file_unit(jn))
	675	END DO
[2]	676	c
[13]	677	c
[2]	678	c
[13]	679	IF(cchan.eq.'CLIM') THEN
[2]	680	c
[13]	681	c inform PVM daemon, I have finished
[2]	682	c
[13]	683	CALL CLIM_Quit (CLIM_ContPvm, info)
	684	IF (info .NE. CLIM_Ok) THEN
	685	WRITE (6, *)
	686	$ 'An error occured while leaving CLIM. Error = ',
	687	$ info
	688	ENDIF
	689
	690	END IF
	691
	692	END IF
	693
[2]	694	c
[13]	695	c IF last we have finished
[2]	696	c
[13]	697	IF (last) RETURN
	698
	699	IF (cchan.eq.'PIPE') THEN
[2]	700	c
[13]	701	c Send message to pipes for CPL=ocean
[2]	702	c
[13]	703	DO jf=1, jpflda2o
	704	CALL PIPE_Model_Send(cl_writ(jf), kt, nuout)
	705	END DO
[2]	706	c
[13]	707	c
[2]	708	c
[13]	709	ELSE IF(cchan.eq.'SIPC') THEN
[2]	710	c
[13]	711	c Define IF a header must be encapsulated within the field brick :
	712	cmodinf = 'NOT' ! as $MODINFO in namcouple
[2]	713	c
[13]	714	c IF cmodinf = 'YES', define encapsulated infos to be exchanged
	715	c infos(1) = initial date
	716	c infos(2) = timestep
	717	c infos(3) = actual time
[2]	718	c
[13]	719	c Writing of output field non solar heat flux CONSFTOT
[2]	720	c
[13]	721	c Index of non solar heat flux in total number of fields jpflda2o:
	722	index = 1
	723	c
	724	CALL SIPC_Write_Model(index, imjm, cmodinf,
	725	$ cljobnam,infos,fnsol)
[2]	726	c
	727	c
[13]	728	c Writing of output field solar heat flux COSHFTOT
[2]	729	c
[13]	730	c Index of solar heat flux in total number of fields jpflda2o:
	731	index = 2
	732	c
	733	CALL SIPC_Write_Model(index, imjm, cmodinf,
	734	$ cljobnam,infos,fsol)
[2]	735	c
[13]	736	c Writing of output field rain COTOPRSU
[2]	737	c
[13]	738	c Index of rain in total number of fields jpflda2o:
	739	index = 3
	740	c
	741	CALL SIPC_Write_Model(index, imjm, cmodinf,
	742	$ cljobnam,infos, rain)
[2]	743	c
[13]	744	c Writing of output field evap COTFSHSU
[2]	745	c
[13]	746	c Index of evap in total number of fields jpflda2o:
	747	index = 4
	748	c
	749	CALL SIPC_Write_Model(index, imjm, cmodinf,
	750	$ cljobnam,infos, evap)
[2]	751	c
[13]	752	c Writing of output field ruisoce CORUNCOA
[2]	753	c
[13]	754	c Index of ruisoce in total number of fields jpflda2o:
	755	index = 5
	756	c
	757	CALL SIPC_Write_Model(index, imjm, cmodinf,
	758	$ cljobnam,infos, ruisoce)
[2]	759	c
	760	c
[13]	761	c Writing of output field ruisriv CORIVFLU
[2]	762	c
[13]	763	c Index of ruisriv in total number of fields jpflda2o:
	764	index = 6
	765	c
	766	CALL SIPC_Write_Model(index, imjm, cmodinf,
	767	$ cljobnam,infos, ruisriv)
[2]	768	c
	769	c
[13]	770	c Writing of output field zonal wind stress COZOTAUX
[2]	771	c
[13]	772	c Index of runoff in total number of fields jpflda2o:
	773	index = 7
	774	c
	775	CALL SIPC_Write_Model(index, imjm, cmodinf,
	776	$ cljobnam,infos, taux)
[2]	777	c
[13]	778	c Writing of output field meridional wind stress COMETAUY
[2]	779	c
[13]	780	c Index of runoff in total number of fields jpflda2o:
	781	index = 8
	782	c
	783	CALL SIPC_Write_Model(index, imjm, cmodinf,
	784	$ cljobnam,infos, taux)
[2]	785	c
	786	c
[13]	787	c Writing of output field zonal wind stress COMETAU2 (at v point)
[2]	788	c
[13]	789	c Index of runoff in total number of fields jpflda2o:
	790	index = 9
	791	c
	792	CALL SIPC_Write_Model(index, imjm, cmodinf,
	793	$ cljobnam,infos, tauy)
[2]	794	c
[13]	795	c Writing of output field meridional wind stress COMETAU2
[2]	796	c
[13]	797	c Index of runoff in total number of fields jpflda2o:
	798	index = 10
	799	c
	800	CALL SIPC_Write_Model(index, imjm, cmodinf,
	801	$ cljobnam,infos, tauy)
[2]	802	c
	803	c
[13]	804	ELSE IF(cchan.eq.'CLIM') THEN
	805
	806	DO jn=1, jpflda2o
	807
	808	IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fnsol, info)
	809	IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsol, info)
	810	IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, rain, info)
	811	IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, evap, info)
	812	IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, ruisoce, info
	813	$ )
	814	IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ruisriv, info
	815	$ )
	816	IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, taux, info)
	817	IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, taux, info)
	818	IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, tauy, info)
	819	IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn), kt, tauy, info)
	820
	821	IF (info .NE. CLIM_Ok) THEN
	822	WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
	823	WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
	824	WRITE (nuout,*) 'Clim error code is = ',info
	825	WRITE (nuout,*) 'STOP in intocpl '
	826	CALL abort(' intocpl ')
	827	ENDIF
	828
	829	END DO
	830
	831	ENDIF
[2]	832	c
	833	RETURN
	834	END
	835
[26]	836	SUBROUTINE locread
	837	print *, 'Attention dans oasis.F, locread est non defini'
	838	RETURN
	839	END
	840
	841	SUBROUTINE locwrite
	842	print *, 'Attention dans oasis.F, locwrite est non defini'
	843	RETURN
	844	END
	845
	846	SUBROUTINE pipe_model_define
	847	print*,'Attention dans oasis.F, pipe_model_define est non defini'
	848	RETURN
	849	END
	850
	851	SUBROUTINE pipe_model_stepi
	852	print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
	853	RETURN
	854	END
	855
	856	SUBROUTINE pipe_model_recv
	857	print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
	858	RETURN
[31]	859	END
[26]	860
	861	SUBROUTINE pipe_model_send
	862	print *, 'Attention dans oasis.F, pipe_model_send est non defini'
	863	RETURN
	864	END
	865
	866

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

Download in other formats:

Original Format