Context Navigation

oasis.F @ 212

Last change on this file since 212 was 66, checked in by lmdz, 25 years ago
Rajout d'appels bidons aux routines clim et svipc pour une bonne edition de liens LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 25.7 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
	388	SUBROUTINE fromcpl(kt, imjm, sst, gla)
[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
	401	REAL gla(imjm) ! sea-ice
[2]	402	c
[13]	403	INTEGER nuout ! listing output unit
[2]	404	PARAMETER (nuout=6)
	405	c
	406	INTEGER nuread, ios, iflag, icpliter
[13]	407	CHARACTER*8 pipnom ! name for the pipe
	408	CHARACTER*8 fldnom ! name for the field
	409	CHARACTER*8 filnom ! name for the data file
	410
	411	INTEGER info, jf
	412
[2]	413	c
	414	#include "oasis.h"
	415	#include "clim.h"
	416	c
[13]	417	#include "param_cou.h"
[2]	418	c
[13]	419	#include "inc_sipc.h"
	420	#include "inc_cpl.h"
[2]	421	c
[13]	422	c Addition for SIPC CASE
	423	INTEGER index
	424	CHARACTER*3 cmodinf ! Header or not
	425	CHARACTER*3 cljobnam_r ! Experiment name in the field brick, if any
	426	INTEGER infos(3) ! infos in the field brick, if any
[2]	427	c
[13]	428	c
	429	WRITE (nuout,*) ' '
	430	WRITE (nuout,*) 'Fromcpl: Read fields from CPL, kt=',kt
	431	WRITE (nuout,*) ' '
[2]	432	CALL flush (nuout)
[13]	433
	434	IF (cchan.eq.'PIPE') THEN
[2]	435	c
[13]	436	c UNIT number for fields
[2]	437	c
[13]	438	nuread = 99
[2]	439	c
[13]	440	c exchanges from ocean=CPL to atmosphere
[2]	441	c
[13]	442	DO jf=1,jpfldo2a
	443	CALL PIPE_Model_Recv(cl_read(jf), icpliter, nuout)
	444	OPEN (nuread, FILE=cl_f_read(jf), FORM='UNFORMATTED')
	445	IF (jf.eq.1)
	446	$ CALL locread(cl_read(jf), sst, imjm, nuread, iflag,
	447	$ nuout)
	448	IF (jf.eq.2)
	449	$ CALL locread(cl_read(jf), gla, imjm, nuread, iflag,
	450	$ nuout)
	451	CLOSE (nuread)
	452	END DO
	453
[2]	454	c
[13]	455	ELSE IF (cchan.eq.'SIPC') THEN
[2]	456	c
[13]	457	c Define IF a header must be encapsulated within the field brick :
	458	cmodinf = 'NOT' ! as $MODINFO in namcouple
	459	c
	460	c reading of input field sea-surface-temperature SISUTESU
[2]	461	c
	462	c
[13]	463	c Index of sst in total number of fields jpfldo2a:
	464	index = 1
[2]	465	c
[13]	466	CALL SIPC_Read_Model(index, imjm, cmodinf,
	467	$ cljobnam_r,infos, sst)
[2]	468	c
[13]	469	c reading of input field sea-ice SIICECOV
[2]	470	c
	471	c
[13]	472	c Index of sea-ice in total number of fields jpfldo2a:
	473	index = 2
[2]	474	c
[13]	475	CALL SIPC_Read_Model(index, imjm, cmodinf,
	476	$ cljobnam_r,infos, gla)
[2]	477	c
[13]	478	c
	479	ELSE IF (cchan.eq.'CLIM') THEN
[2]	480
	481	c
[13]	482	c exchanges from ocean=CPL to atmosphere
	483	c
	484	DO jf=1,jpfldo2a
	485	IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
	486	IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info)
	487	IF ( info .NE. CLIM_Ok) THEN
	488	WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
	489	WRITE(nuout,*)'Couplage kt is = ',kt
	490	WRITE(nuout,*)'CLIM error code is = ', info
	491	WRITE(nuout,*)'STOP in Fromcpl'
	492	STOP 'Fromcpl'
	493	ENDIF
	494	END DO
	495
	496	ENDIF
	497	c
[2]	498	RETURN
	499	END
	500
	501
[13]	502	SUBROUTINE intocpl(kt,imjm,
[2]	503	. fsol, fnsol,
	504	. rain, snow, evap, ruisoce, ruisriv,
[13]	505	. taux, tauy, last)
[2]	506	IMPLICIT NONE
	507	c
	508	c Laurent Z.X Li (Feb. 10, 1997): It provides several fields to the
	509	c coupler. Of course, it sends a message to the corresponding pipes
	510	c after the writting.
[13]	511	c 3 techniques : pipes
	512	c clim
	513	c svipc
	514	c IF last time step WRITE output files anway
[2]	515	c
[13]	516	#include "oasis.h"
	517
	518	INTEGER kt, imjm
[2]	519	c
	520	REAL fsol(imjm)
	521	REAL fnsol(imjm)
	522	REAL rain(imjm)
	523	REAL snow(imjm)
	524	REAL evap(imjm)
	525	REAL ruisoce(imjm)
	526	REAL ruisriv(imjm)
	527	REAL taux(imjm)
	528	REAL tauy(imjm)
[13]	529	LOGICAL last
[2]	530	c
	531	INTEGER nuout
	532	PARAMETER (nuout = 6)
	533	c
[13]	534	c Additions for SVIPC
[2]	535	c
[13]	536	INTEGER index
	537	INTEGER infos(3)
	538	CHARACTER*3 cmodinf ! Header or not
	539	CHARACTER*3 cljobnam ! experiment name
	540	c
[2]	541	#include "clim.h"
	542	c
[13]	543	#include "param_cou.h"
[2]	544	c
[13]	545	#include "inc_sipc.h"
	546	#include "inc_cpl.h"
[2]	547	c
	548	C
[13]	549	INTEGER nuwrit, ios
	550	CHARACTER*8 pipnom
	551	CHARACTER*8 fldnom
	552	CHARACTER*6 file_name(jpmaxfld)
	553	INTEGER max_file
	554	INTEGER file_unit_max, file_unit(jpmaxfld),
	555	$ file_unit_field(jpmaxfld)
	556
	557	INTEGER icstep, info, jn, jf, ierror
	558	LOGICAL trouve
[2]	559	c
	560	c
[13]	561	icstep=kt
[2]	562	c
[13]	563	WRITE(nuout,*) ' '
	564	WRITE(nuout,*) 'Intocpl: send fields to CPL, kt= ', kt
	565	WRITE(nuout,*) ' '
	566
	567	IF (last.or.(cchan.eq.'PIPE')) THEN
[2]	568	c
	569	c
[13]	570	c WRITE fields for coupler with pipe technique or for last time step
[2]	571	c
[13]	572	c initialisation
[2]	573	c
[13]	574	max_file=1
	575	file_unit_max=99
	576	c keeps first file name
	577	file_name(max_file)=cl_f_writ(max_file)
	578	c keeps first file unit
	579	file_unit(max_file)=file_unit_max
	580	c decrements file unit maximum
	581	file_unit_max=file_unit_max-1
	582	c keeps file unit for field
	583	file_unit_field(1)=file_unit(max_file)
[2]	584	c
[13]	585	c different files names counter
[2]	586	c
[13]	587
	588	DO jf= 2, jpflda2o
	589	trouve=.false.
	590	DO jn= 1, max_file
	591	IF (.not.trouve) THEN
	592	IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
	593	c keep file unit for field
	594	file_unit_field(jf)=file_unit(jn)
	595	trouve=.true.
	596	END IF
	597	END IF
	598	END DO
	599	IF (.not.trouve) then
	600	c increment the number of different files
	601	max_file=max_file+1
	602	c keep file name
	603	file_name(max_file)=cl_f_writ(jf)
	604	c keep file unit for file
	605	file_unit(max_file)=file_unit_max
	606	c keep file unit for field
	607	file_unit_field(jf)=file_unit(max_file)
	608	c decrement unit maximum number from 99 to 98, ...
	609	file_unit_max=file_unit_max-1
	610	END IF
	611	END DO
	612
	613	DO jn=1, max_file
	614	OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
	615	END DO
	616
	617	DO jf=1, jpflda2o
	618	IF (jf.eq.1)
	619	$ CALL locwrite(cl_writ(jf),fnsol, imjm,
	620	$ file_unit_field(jf), ierror, nuout)
	621	IF (jf.eq.2)
	622	$ CALL locwrite(cl_writ(jf),fsol, imjm,
	623	$ file_unit_field(jf), ierror, nuout)
	624	IF (jf.eq.3)
	625	$ CALL locwrite(cl_writ(jf),rain, imjm,
	626	$ file_unit_field(jf), ierror, nuout)
	627	IF (jf.eq.4)
	628	$ CALL locwrite(cl_writ(jf),evap, imjm,
	629	$ file_unit_field(jf), ierror, nuout)
	630	IF (jf.eq.5)
	631	$ CALL locwrite(cl_writ(jf),ruisoce, imjm,
	632	$ file_unit_field(jf),ierror, nuout)
	633	IF (jf.eq.6)
	634	$ CALL locwrite(cl_writ(jf),ruisriv, imjm,
	635	$ file_unit_field(jf),ierror, nuout)
	636	IF (jf.eq.7)
	637	$ CALL locwrite(cl_writ(jf),taux, imjm,
	638	$ file_unit_field(jf), ierror, nuout)
	639	IF (jf.eq.8)
	640	$ CALL locwrite(cl_writ(jf),taux, imjm,
	641	$ file_unit_field(jf), ierror, nuout)
	642	IF (jf.eq.9)
	643	$ CALL locwrite(cl_writ(jf),tauy, imjm,
	644	$ file_unit_field(jf), ierror, nuout)
	645	IF (jf.eq.10)
	646	$ CALL locwrite(cl_writ(jf),tauy, imjm,
	647	$ file_unit_field(jf), ierror, nuout)
	648	END DO
	649	C
	650	C simulate a FLUSH
	651	C
	652	DO jn=1, max_file
	653	CLOSE (file_unit(jn))
	654	END DO
[2]	655	c
[13]	656	c
[2]	657	c
[13]	658	IF(cchan.eq.'CLIM') THEN
[2]	659	c
[13]	660	c inform PVM daemon, I have finished
[2]	661	c
[13]	662	CALL CLIM_Quit (CLIM_ContPvm, info)
	663	IF (info .NE. CLIM_Ok) THEN
	664	WRITE (6, *)
	665	$ 'An error occured while leaving CLIM. Error = ',
	666	$ info
	667	ENDIF
	668
	669	END IF
	670
	671	END IF
	672
[2]	673	c
[13]	674	c IF last we have finished
[2]	675	c
[13]	676	IF (last) RETURN
	677
	678	IF (cchan.eq.'PIPE') THEN
[2]	679	c
[13]	680	c Send message to pipes for CPL=ocean
[2]	681	c
[13]	682	DO jf=1, jpflda2o
	683	CALL PIPE_Model_Send(cl_writ(jf), kt, nuout)
	684	END DO
[2]	685	c
[13]	686	c
[2]	687	c
[13]	688	ELSE IF(cchan.eq.'SIPC') THEN
[2]	689	c
[13]	690	c Define IF a header must be encapsulated within the field brick :
	691	cmodinf = 'NOT' ! as $MODINFO in namcouple
[2]	692	c
[13]	693	c IF cmodinf = 'YES', define encapsulated infos to be exchanged
	694	c infos(1) = initial date
	695	c infos(2) = timestep
	696	c infos(3) = actual time
[2]	697	c
[13]	698	c Writing of output field non solar heat flux CONSFTOT
[2]	699	c
[13]	700	c Index of non solar heat flux in total number of fields jpflda2o:
	701	index = 1
	702	c
	703	CALL SIPC_Write_Model(index, imjm, cmodinf,
	704	$ cljobnam,infos,fnsol)
[2]	705	c
	706	c
[13]	707	c Writing of output field solar heat flux COSHFTOT
[2]	708	c
[13]	709	c Index of solar heat flux in total number of fields jpflda2o:
	710	index = 2
	711	c
	712	CALL SIPC_Write_Model(index, imjm, cmodinf,
	713	$ cljobnam,infos,fsol)
[2]	714	c
[13]	715	c Writing of output field rain COTOPRSU
[2]	716	c
[13]	717	c Index of rain in total number of fields jpflda2o:
	718	index = 3
	719	c
	720	CALL SIPC_Write_Model(index, imjm, cmodinf,
	721	$ cljobnam,infos, rain)
[2]	722	c
[13]	723	c Writing of output field evap COTFSHSU
[2]	724	c
[13]	725	c Index of evap in total number of fields jpflda2o:
	726	index = 4
	727	c
	728	CALL SIPC_Write_Model(index, imjm, cmodinf,
	729	$ cljobnam,infos, evap)
[2]	730	c
[13]	731	c Writing of output field ruisoce CORUNCOA
[2]	732	c
[13]	733	c Index of ruisoce in total number of fields jpflda2o:
	734	index = 5
	735	c
	736	CALL SIPC_Write_Model(index, imjm, cmodinf,
	737	$ cljobnam,infos, ruisoce)
[2]	738	c
	739	c
[13]	740	c Writing of output field ruisriv CORIVFLU
[2]	741	c
[13]	742	c Index of ruisriv in total number of fields jpflda2o:
	743	index = 6
	744	c
	745	CALL SIPC_Write_Model(index, imjm, cmodinf,
	746	$ cljobnam,infos, ruisriv)
[2]	747	c
	748	c
[13]	749	c Writing of output field zonal wind stress COZOTAUX
[2]	750	c
[13]	751	c Index of runoff in total number of fields jpflda2o:
	752	index = 7
	753	c
	754	CALL SIPC_Write_Model(index, imjm, cmodinf,
	755	$ cljobnam,infos, taux)
[2]	756	c
[13]	757	c Writing of output field meridional wind stress COMETAUY
[2]	758	c
[13]	759	c Index of runoff in total number of fields jpflda2o:
	760	index = 8
	761	c
	762	CALL SIPC_Write_Model(index, imjm, cmodinf,
	763	$ cljobnam,infos, taux)
[2]	764	c
	765	c
[13]	766	c Writing of output field zonal wind stress COMETAU2 (at v point)
[2]	767	c
[13]	768	c Index of runoff in total number of fields jpflda2o:
	769	index = 9
	770	c
	771	CALL SIPC_Write_Model(index, imjm, cmodinf,
	772	$ cljobnam,infos, tauy)
[2]	773	c
[13]	774	c Writing of output field meridional wind stress COMETAU2
[2]	775	c
[13]	776	c Index of runoff in total number of fields jpflda2o:
	777	index = 10
	778	c
	779	CALL SIPC_Write_Model(index, imjm, cmodinf,
	780	$ cljobnam,infos, tauy)
[2]	781	c
	782	c
[13]	783	ELSE IF(cchan.eq.'CLIM') THEN
	784
	785	DO jn=1, jpflda2o
	786
	787	IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fnsol, info)
	788	IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsol, info)
	789	IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, rain, info)
	790	IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, evap, info)
	791	IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, ruisoce, info
	792	$ )
	793	IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ruisriv, info
	794	$ )
	795	IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, taux, info)
	796	IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, taux, info)
	797	IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, tauy, info)
	798	IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn), kt, tauy, info)
	799
	800	IF (info .NE. CLIM_Ok) THEN
	801	WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
	802	WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
	803	WRITE (nuout,*) 'Clim error code is = ',info
	804	WRITE (nuout,*) 'STOP in intocpl '
	805	CALL abort(' intocpl ')
	806	ENDIF
	807
	808	END DO
	809
	810	ENDIF
[2]	811	c
	812	RETURN
	813	END
	814
[26]	815	SUBROUTINE locread
	816	print *, 'Attention dans oasis.F, locread est non defini'
	817	RETURN
	818	END
	819
	820	SUBROUTINE locwrite
	821	print *, 'Attention dans oasis.F, locwrite est non defini'
	822	RETURN
	823	END
	824
	825	SUBROUTINE pipe_model_define
	826	print*,'Attention dans oasis.F, pipe_model_define est non defini'
	827	RETURN
	828	END
	829
	830	SUBROUTINE pipe_model_stepi
	831	print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
	832	RETURN
	833	END
	834
	835	SUBROUTINE pipe_model_recv
	836	print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
	837	RETURN
[31]	838	END
[26]	839
	840	SUBROUTINE pipe_model_send
	841	print *, 'Attention dans oasis.F, pipe_model_send est non defini'
	842	RETURN
	843	END
	844
[66]	845	SUBROUTINE clim_stepi
	846	print *, 'Attention dans oasis.F, clim_stepi est non defini'
	847	RETURN
	848	END
[26]	849
[66]	850	SUBROUTINE clim_start
	851	print *, 'Attention dans oasis.F, clim_start est non defini'
	852	RETURN
	853	END
	854
	855	SUBROUTINE clim_import
	856	print *, 'Attention dans oasis.F, clim_import est non defini'
	857	RETURN
	858	END
	859
	860	SUBROUTINE clim_export
	861	print *, 'Attention dans oasis.F, clim_export est non defini'
	862	RETURN
	863	END
	864
	865	SUBROUTINE clim_init
	866	print *, 'Attention dans oasis.F, clim_init est non defini'
	867	RETURN
	868	END
	869
	870	SUBROUTINE clim_define
	871	print *, 'Attention dans oasis.F, clim_define est non defini'
	872	RETURN
	873	END
	874
	875	SUBROUTINE clim_quit
	876	print *, 'Attention dans oasis.F, clim_quit est non defini'
	877	RETURN
	878	END
	879
	880	SUBROUTINE svipc_write
	881	print *, 'Attention dans oasis.F, svipc_write est non defini'
	882	RETURN
	883	END
	884
	885	SUBROUTINE svipc_close
	886	print *, 'Attention dans oasis.F, svipc_close est non defini'
	887	RETURN
	888	END
	889
	890	SUBROUTINE svipc_read
	891	print *, 'Attention dans oasis.F, svipc_read est non defini'
	892	RETURN
	893	END
	894
	895	SUBROUTINE quitcpl
	896	print *, 'Attention dans oasis.F, quitcpl est non defini'
	897	RETURN
	898	END
	899
	900	SUBROUTINE sipc_write_model
	901	print *, 'Attention dans oasis.F, sipc_write_model est non defini'
	902	RETURN
	903	END
	904
	905	SUBROUTINE sipc_attach
	906	print *, 'Attention dans oasis.F, sipc_attach est non defini'
	907	RETURN
	908	END
	909
	910	SUBROUTINE sipc_init_model
	911	print *, 'Attention dans oasis.F, sipc_init_model est non defini'
	912	RETURN
	913	END
	914
	915	SUBROUTINE sipc_read_model
	916	print *, 'Attention dans oasis.F, sipc_read_model est non defini'
	917	RETURN
	918	END

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

Download in other formats:

Original Format