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 |
---|
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 |
---|
50 | #include "dimensions.h" |
---|
51 | #include "dimphy.h" |
---|
52 | #include "oasis.h" |
---|
53 | #include "clim.h" |
---|
54 | c |
---|
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 |
---|
70 | C |
---|
71 | INTEGER nuout |
---|
72 | PARAMETER (nuout = 6) |
---|
73 | c |
---|
74 | C |
---|
75 | c |
---|
76 | |
---|
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 |
---|
89 | c 1.2.1-Define the model name |
---|
90 | c |
---|
91 | clmodnam = 'lmd.xx' ! as $NBMODEL in namcouple |
---|
92 | c |
---|
93 | c 1.2.2-Define the coupler name |
---|
94 | c |
---|
95 | cloasis = 'Oasis' ! as in coupler |
---|
96 | c |
---|
97 | c |
---|
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: |
---|
100 | c |
---|
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' |
---|
111 | c |
---|
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: |
---|
114 | c |
---|
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' |
---|
125 | c |
---|
126 | c |
---|
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: |
---|
129 | c |
---|
130 | cl_read(1)='SISUTESU' |
---|
131 | cl_read(2)='SIICECOV' |
---|
132 | c |
---|
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: |
---|
135 | c |
---|
136 | cl_f_read(1)='atmsst' |
---|
137 | cl_f_read(2)='atmice' |
---|
138 | c |
---|
139 | c 1.5-Define infos for sending to oasis |
---|
140 | c |
---|
141 | imess(1) = kastp |
---|
142 | imess(2) = kexch |
---|
143 | imess(3) = kstep |
---|
144 | imess(4) = getpid() |
---|
145 | |
---|
146 | c |
---|
147 | c |
---|
148 | IF (cchan.eq.'PIPE') THEN |
---|
149 | c |
---|
150 | ierror=0 |
---|
151 | c |
---|
152 | c |
---|
153 | WRITE(nuout,*) ' ' |
---|
154 | WRITE(nuout,*) 'Making pipes for fields to receive from CPL' |
---|
155 | WRITE(nuout,*) ' ' |
---|
156 | c |
---|
157 | c loop to define pipes (ocean=CPL to atmos) |
---|
158 | c |
---|
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 |
---|
163 | c |
---|
164 | WRITE(nuout,*) ' ' |
---|
165 | WRITE(nuout,*) 'Making pipes for fields to send to CPL' |
---|
166 | WRITE(nuout,*) ' ' |
---|
167 | c |
---|
168 | c loop to define pipes (atmos to ocean=CPL) |
---|
169 | c |
---|
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 |
---|
174 | c |
---|
175 | IF (ierror.ne.0) THEN |
---|
176 | WRITE (nuout,*) 'Error in pipes definitions' |
---|
177 | WRITE (nuout,*) 'STOP inicma' |
---|
178 | CALL abort |
---|
179 | END IF |
---|
180 | c |
---|
181 | WRITE(nuout,*) ' ' |
---|
182 | WRITE(nuout,*) 'All pipes have been made' |
---|
183 | WRITE(nuout,*) ' ' |
---|
184 | c |
---|
185 | WRITE(nuout,*) ' ' |
---|
186 | WRITE(nuout,*) 'Communication test between ATM and CPL' |
---|
187 | WRITE(nuout,*) ' ' |
---|
188 | CALL flush(nuout) |
---|
189 | c |
---|
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, |
---|
329 | * kastp, kexch, kstep, |
---|
330 | * 5, 3600, 3600, info ) |
---|
331 | c |
---|
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 |
---|
339 | c |
---|
340 | iparal ( clim_strategy ) = clim_serial |
---|
341 | iparal ( clim_length ) = iim*(jjm+1) |
---|
342 | iparal ( clim_offset ) = 0 |
---|
343 | c |
---|
344 | c loop to define messages (CPL=ocean to atmos) |
---|
345 | c |
---|
346 | DO jf=1, jpfldo2a |
---|
347 | CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal |
---|
348 | $ , info ) |
---|
349 | END DO |
---|
350 | |
---|
351 | c |
---|
352 | c loop to define messages (atmos to ocean=CPL) |
---|
353 | c |
---|
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 |
---|
368 | c |
---|
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 | |
---|
385 | RETURN |
---|
386 | END |
---|
387 | |
---|
388 | SUBROUTINE fromcpl(kt, imjm, sst, gla) |
---|
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 |
---|
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 |
---|
398 | c |
---|
399 | INTEGER imjm, kt |
---|
400 | REAL sst(imjm) ! sea-surface-temperature |
---|
401 | REAL gla(imjm) ! sea-ice |
---|
402 | c |
---|
403 | INTEGER nuout ! listing output unit |
---|
404 | PARAMETER (nuout=6) |
---|
405 | c |
---|
406 | INTEGER nuread, ios, iflag, icpliter |
---|
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 | |
---|
413 | c |
---|
414 | #include "oasis.h" |
---|
415 | #include "clim.h" |
---|
416 | c |
---|
417 | #include "param_cou.h" |
---|
418 | c |
---|
419 | #include "inc_sipc.h" |
---|
420 | #include "inc_cpl.h" |
---|
421 | c |
---|
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 |
---|
427 | c |
---|
428 | c |
---|
429 | WRITE (nuout,*) ' ' |
---|
430 | WRITE (nuout,*) 'Fromcpl: Read fields from CPL, kt=',kt |
---|
431 | WRITE (nuout,*) ' ' |
---|
432 | CALL flush (nuout) |
---|
433 | |
---|
434 | IF (cchan.eq.'PIPE') THEN |
---|
435 | c |
---|
436 | c UNIT number for fields |
---|
437 | c |
---|
438 | nuread = 99 |
---|
439 | c |
---|
440 | c exchanges from ocean=CPL to atmosphere |
---|
441 | c |
---|
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 | |
---|
454 | c |
---|
455 | ELSE IF (cchan.eq.'SIPC') THEN |
---|
456 | c |
---|
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 |
---|
461 | c |
---|
462 | c |
---|
463 | c Index of sst in total number of fields jpfldo2a: |
---|
464 | index = 1 |
---|
465 | c |
---|
466 | CALL SIPC_Read_Model(index, imjm, cmodinf, |
---|
467 | $ cljobnam_r,infos, sst) |
---|
468 | c |
---|
469 | c reading of input field sea-ice SIICECOV |
---|
470 | c |
---|
471 | c |
---|
472 | c Index of sea-ice in total number of fields jpfldo2a: |
---|
473 | index = 2 |
---|
474 | c |
---|
475 | CALL SIPC_Read_Model(index, imjm, cmodinf, |
---|
476 | $ cljobnam_r,infos, gla) |
---|
477 | c |
---|
478 | c |
---|
479 | ELSE IF (cchan.eq.'CLIM') THEN |
---|
480 | |
---|
481 | c |
---|
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 |
---|
498 | RETURN |
---|
499 | END |
---|
500 | |
---|
501 | |
---|
502 | SUBROUTINE intocpl(kt,imjm, |
---|
503 | . fsol, fnsol, |
---|
504 | . rain, snow, evap, ruisoce, ruisriv, |
---|
505 | . taux, tauy, last) |
---|
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. |
---|
511 | c 3 techniques : pipes |
---|
512 | c clim |
---|
513 | c svipc |
---|
514 | c IF last time step WRITE output files anway |
---|
515 | c |
---|
516 | #include "oasis.h" |
---|
517 | |
---|
518 | INTEGER kt, imjm |
---|
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) |
---|
529 | LOGICAL last |
---|
530 | c |
---|
531 | INTEGER nuout |
---|
532 | PARAMETER (nuout = 6) |
---|
533 | c |
---|
534 | c Additions for SVIPC |
---|
535 | c |
---|
536 | INTEGER index |
---|
537 | INTEGER infos(3) |
---|
538 | CHARACTER*3 cmodinf ! Header or not |
---|
539 | CHARACTER*3 cljobnam ! experiment name |
---|
540 | c |
---|
541 | #include "clim.h" |
---|
542 | c |
---|
543 | #include "param_cou.h" |
---|
544 | c |
---|
545 | #include "inc_sipc.h" |
---|
546 | #include "inc_cpl.h" |
---|
547 | c |
---|
548 | C |
---|
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 |
---|
559 | c |
---|
560 | c |
---|
561 | icstep=kt |
---|
562 | c |
---|
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 |
---|
568 | c |
---|
569 | c |
---|
570 | c WRITE fields for coupler with pipe technique or for last time step |
---|
571 | c |
---|
572 | c initialisation |
---|
573 | c |
---|
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) |
---|
584 | c |
---|
585 | c different files names counter |
---|
586 | c |
---|
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 |
---|
655 | c |
---|
656 | c |
---|
657 | c |
---|
658 | IF(cchan.eq.'CLIM') THEN |
---|
659 | c |
---|
660 | c inform PVM daemon, I have finished |
---|
661 | c |
---|
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 | |
---|
673 | c |
---|
674 | c IF last we have finished |
---|
675 | c |
---|
676 | IF (last) RETURN |
---|
677 | |
---|
678 | IF (cchan.eq.'PIPE') THEN |
---|
679 | c |
---|
680 | c Send message to pipes for CPL=ocean |
---|
681 | c |
---|
682 | DO jf=1, jpflda2o |
---|
683 | CALL PIPE_Model_Send(cl_writ(jf), kt, nuout) |
---|
684 | END DO |
---|
685 | c |
---|
686 | c |
---|
687 | c |
---|
688 | ELSE IF(cchan.eq.'SIPC') THEN |
---|
689 | c |
---|
690 | c Define IF a header must be encapsulated within the field brick : |
---|
691 | cmodinf = 'NOT' ! as $MODINFO in namcouple |
---|
692 | c |
---|
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 |
---|
697 | c |
---|
698 | c Writing of output field non solar heat flux CONSFTOT |
---|
699 | c |
---|
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) |
---|
705 | c |
---|
706 | c |
---|
707 | c Writing of output field solar heat flux COSHFTOT |
---|
708 | c |
---|
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) |
---|
714 | c |
---|
715 | c Writing of output field rain COTOPRSU |
---|
716 | c |
---|
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) |
---|
722 | c |
---|
723 | c Writing of output field evap COTFSHSU |
---|
724 | c |
---|
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) |
---|
730 | c |
---|
731 | c Writing of output field ruisoce CORUNCOA |
---|
732 | c |
---|
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) |
---|
738 | c |
---|
739 | c |
---|
740 | c Writing of output field ruisriv CORIVFLU |
---|
741 | c |
---|
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) |
---|
747 | c |
---|
748 | c |
---|
749 | c Writing of output field zonal wind stress COZOTAUX |
---|
750 | c |
---|
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) |
---|
756 | c |
---|
757 | c Writing of output field meridional wind stress COMETAUY |
---|
758 | c |
---|
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) |
---|
764 | c |
---|
765 | c |
---|
766 | c Writing of output field zonal wind stress COMETAU2 (at v point) |
---|
767 | c |
---|
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) |
---|
773 | c |
---|
774 | c Writing of output field meridional wind stress COMETAU2 |
---|
775 | c |
---|
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) |
---|
781 | c |
---|
782 | c |
---|
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 |
---|
811 | c |
---|
812 | RETURN |
---|
813 | END |
---|
814 | |
---|
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 |
---|
838 | END |
---|
839 | |
---|
840 | SUBROUTINE pipe_model_send |
---|
841 | print *, 'Attention dans oasis.F, pipe_model_send est non defini' |
---|
842 | RETURN |
---|
843 | END |
---|
844 | |
---|
845 | SUBROUTINE clim_stepi |
---|
846 | print *, 'Attention dans oasis.F, clim_stepi est non defini' |
---|
847 | RETURN |
---|
848 | END |
---|
849 | |
---|
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 |
---|