Context Navigation

oasis.F @ 13

Last change on this file since 13 was 13, checked in by lmdz, 25 years ago
Changement de oasis.F pour passage sur Nec LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 23.2 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

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

Download in other formats:

Original Format