Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_prism_get_proto.F90 @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago
Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).
File size: 62.1 KB

Line
1	module mod_prism_get_proto
2	#include <psmile_os.h>
3
4	interface prism_get_proto
5
6	#ifndef __NO_4BYTE_REALS
7	module procedure prism_get_proto_r14
8	module procedure prism_get_proto_r24
9	#endif
10	module procedure prism_get_proto_r18, &
11	prism_get_proto_r28
12
13	end interface
14
15	contains
16
17	SUBROUTINE prism_get_proto_r14(id_port_id,kstep,rd_field,kinfo)
18	!
19	!* * PRISM_get * PRISM 1.0
20	!
21	! purpose:
22	! --------
23	! recv pfield from oasis or models connected to port id_port_id
24	!
25	! interface:
26	! ----------
27	! id_port_id : port number of the field
28	! kstep : current time in seconds
29	! pfield : buffer of reals
30	! kinfo : output status
31	!
32	! lib mp:
33	! -------
34	! mpi-1 or mpi-2
35	!
36	! author:
37	! -------
38	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import)
39	!
40	! modified:
41	! ---------
42	! Reiner Vogelsang, SGI, 27 April 2003
43	! - Screening of 4 byte real interfaces in case a of dbl4 compilation.
44	! File has to be preprocessed with -D__SXdbl4.
45	! S. Legutke, MPI M&D (05/03 - kinfo = PRISM_Recvd added)
46	!
47	!---------------------------------------------------------------------
48	USE mod_kinds_model
49	USE mod_prism_proto
50	USE mod_comprism_proto
51	IMPLICIT none
52	#include <mpif.h>
53	! ----------------------------------------------------------------
54	INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id,kstep
55	INTEGER(kind=ip_intwp_p), intent(out) :: kinfo
56	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field
57	! ----------------------------------------------------------------
58	INTEGER(kind=ip_intwp_p) info, ip, iport
59	INTEGER(kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb
60	INTEGER(kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt
61	INTEGER(kind=ip_intwp_p) iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
62	!jl
63	#ifdef __DEBUG
64	INTEGER(kind=ip_intwp_p) icount
65	INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
66	LOGICAL :: iflag
67	#endif
68	! ----------------------------------------------------------------
69	!
70	istatus(:)=0
71
72	!* 0. First Check
73	! --------------
74	!
75	IF (nexit.ne.1) THEN
76	kinfo = CLIM_FastExit
77	WRITE(nulprt,FMT='(A)') 'Get - should not be called'
78	GO TO 1010
79	ENDIF
80	kinfo = PRISM_Ok
81	!
82	!* 1. check for this port in my list
83	! ---------------------------------
84	!
85	irecv = 0
86	iport = -1
87	!
88	! Test if the field is defined in the namcouple and if its coupling period
89	! is not greater than the time of the simulation.
90	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
91	ig_def_freq(id_port_id) .gt. ig_ntime .or. &
92	ig_def_state(id_port_id) .eq. ip_auxilary) THEN
93	GOTO 1010
94	ENDIF
95	IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
96	IF (iport.lt.0) THEN
97	kinfo = CLIM_BadPort
98	WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
99	cports(id_port_id)
100	GO TO 1010
101	ENDIF
102	!
103	!* Test if the current time is a coupling (or I/O) time
104	!
105	IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
106	!
107	!* If the user indicated in the namcouple that the field is
108	!* a field input-from-file (keyword 'INPUT' at the end of the
109	!* field 1st line), do the reading from file here, e.g.:
110	!
111	#if !defined key_noIO
112	IF (ig_def_state(iport) .EQ. ip_input) THEN
113	CALL psmile_read_4(iport,rd_field,kstep)
114	kinfo = PRISM_Input
115	ENDIF
116	#endif
117	!
118	!* Define return code (direct or via Oasis does not matter)
119	!
120	IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
121	kinfo = PRISM_FromRest
122	#if !defined key_noIO
123	IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
124	ig_def_state(iport) .EQ. ip_expout) THEN
125	kinfo = PRISM_FromRestOut
126	ENDIF
127	#endif
128	ELSE
129	IF (ig_def_state(iport) .NE. ip_input) THEN
130	kinfo = PRISM_Recvd
131	!
132	#if !defined key_noIO
133	IF (ig_def_state(iport) .EQ. ip_expout .OR. &
134	ig_def_state(iport) .EQ. ip_ignout) THEN
135	kinfo = PRISM_RecvOut
136	ENDIF
137	#endif
138	ENDIF
139	ENDIF
140	!
141	IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
142	(ig_def_state(iport) .eq. ip_ignored .or. &
143	ig_def_state(iport) .eq. ip_ignout)) THEN
144	!
145	!* Note: A model can have several restart files but same restart
146	!* file can't be used by different models
147	!* Test if model is serial or parallel and if variables are real
148	! or double precision
149	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
150	call read_filer4(rd_field, cports(iport),iport)
151	ELSE
152	call read_file_parar4(rd_field, cports(iport),iport)
153	ENDIF
154	#if !defined key_noIO
155	IF (ig_def_state(iport) .EQ. ip_ignout) &
156	CALL psmile_write_4(iport,rd_field,kstep)
157	#endif
158	ELSE
159	!*
160	!* If the user indicated in the namcouple that the field is
161	!* a coupling field then do the import :
162	IF (ig_def_state(iport) .ne. ip_output .and. &
163	ig_def_state(iport) .ne. ip_input) THEN
164	!
165	!* Check for connected ports (in)
166	! ------------------------------
167	!
168	WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
169	!
170	ityp = myport(2,iport)
171	ibyt = myport(3,iport)
172	!
173	DO ip=1,myport(5,iport)
174	!
175	ilk = myport(5+ip,iport)
176	imod = mylink(1,ilk)
177	itid = mylink(2,ilk)
178	itag = mylink(3,ilk) - kstep / ig_frqmin
179	iseg = mylink(4,ilk)
180	!
181	!* Implementation with "blocking" receives : the program will wait
182	!* indefinitely until a message is received (this may generate a
183	!* deadlock if all models are waiting on a receive).
184	!* However this method will be more efficient in most cases than the
185	!* receives with a time-out loop.
186	!
187	#ifdef __DEBUG
188	!jl
189	!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
190	!jl exist in the network (2004-04-28)
191	!jl Also, allows to check the timing of the receives of messages
192	!jl For completion, the same syntax should be added in oasis "Getfld"
193	!jl
194	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
195	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
196	' comm = ',mpi_comm,' result is : ',iflag
197	call flush(nulprt)
198
199	IF (.NOT.iflag) THEN
200	icount = 0
201	WAITLOOP: DO
202	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
203	icount = icount + 1
204	IF ( iflag ) EXIT WAITLOOP
205	IF ( icount .GE. icountmax ) THEN
206	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
207	' still negative after ',icountmax,' seconds : Abort the job'
208	call flush(nulprt)
209	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
210	ENDIF
211	call sleep(1)
212	END DO WAITLOOP
213	WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
214	call flush(nulprt)
215	ENDIF
216	!jl
217	#endif
218	CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
219	itid, itag, mpi_comm, istatus, info )
220	CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
221	info )
222	!
223	IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN
224	ilgb = 0
225	iposbuf = 0
226	DO is=1,iseg
227	ioff = mylink(4+2is-1,ilk) 2 + 1
228	il_len = mylink(4+2*is,ilk)
229	!
230	IF ( ityp .EQ. PRISM_Real ) THEN
231	CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
232	iposbuf, rd_field(ioff), il_len, &
233	MPI_REAL, mpi_comm, info)
234	ELSE
235	WRITE(nulprt,*)'Get - pb type incorrect ',ityp
236	kinfo = CLIM_BadType
237	GO TO 1010
238	ENDIF
239	ilgb = ilgb + il_len
240	ENDDO
241	IF (ilgb*ibyt .le. imaxbyt) THEN
242	irecv = irecv + 1
243	nbrecv = nbrecv + ilgb * ibyt
244	WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
245	'Get - <from:',imod, &
246	'> <step:',kstep, &
247	'> <len:',ilgb, &
248	'> <type:',ibyt, &
249	'> <tag:',itag,'>'
250	ELSE
251	kinfo = CLIM_Unpack
252	WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
253	info,'>'
254	ENDIF
255	ELSE
256	kinfo = CLIM_TimeOut
257	WRITE(nulprt,FMT='(A,I3,A)') &
258	'Get - abnormal exit from trecv <mpi ',info,'>'
259	ENDIF
260	!
261	ENDDO
262	!
263	WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
264	!
265	#if !defined key_noIO
266	IF (ig_def_state(iport) .eq. ip_expout .or. &
267	ig_def_state(iport) .eq. ip_ignout) &
268	!
269	!* If the user indicated in the namcouple that the field must be written
270	!* to file, do the writing here :
271	!
272	CALL psmile_write_4(iport,rd_field,kstep)
273	#endif
274	ENDIF
275	ENDIF
276	ENDIF
277	!
278	! ----------------------------------------------------------------
279	!
280	1010 CONTINUE
281	CALL FLUSH(nulprt)
282	RETURN
283	END SUBROUTINE prism_get_proto_r14
284
285	SUBROUTINE prism_get_proto_r18(id_port_id,kstep,rd_field,kinfo)
286	!
287	!* * PRISM_get * PRISM 1.0
288	!
289	! purpose:
290	! --------
291	! recv pfield from oasis or models connected to port id_port_id
292	!
293	! interface:
294	! ----------
295	! id_port_id : port number of the field
296	! kstep : current time in seconds
297	! rd_field : buffer of reals
298	! kinfo : output status
299	!
300	! lib mp:
301	! -------
302	! mpi-1 or mpi-2
303	!
304	! author:
305	! -------
306	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import)
307	! S. Legutke, - MPI M&D (05/03 - kinfo = PRISM_Recvd added)
308	! ----------------------------------------------------------------
309	USE mod_kinds_model
310	USE mod_prism_proto
311	USE mod_comprism_proto
312	IMPLICIT none
313	#include <mpif.h>
314	! ----------------------------------------------------------------
315	INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id,kstep
316	INTEGER (kind=ip_intwp_p), intent(out) :: kinfo
317	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)), intent(inout) :: rd_field
318	! ----------------------------------------------------------------
319	INTEGER (kind=ip_intwp_p) info, ip, iport
320	INTEGER (kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb
321	INTEGER (kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt
322	INTEGER (kind=ip_intwp_p) iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
323	!jl
324	#ifdef __DEBUG
325	INTEGER(kind=ip_intwp_p) icount
326	INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
327	LOGICAL :: iflag
328	#endif
329	! ----------------------------------------------------------------
330	!
331	istatus(:)=0
332	!
333	!* 0. First Check
334	! --------------
335	!
336	IF (nexit.ne.1) THEN
337	kinfo = CLIM_FastExit
338	WRITE(nulprt,FMT='(A)') 'Get - should not be called'
339	GO TO 1010
340	ENDIF
341	kinfo = PRISM_Ok
342	!
343	!* 1. check for this port in my list
344	! ---------------------------------
345	!
346	irecv = 0
347	iport = -1
348	!
349	! Test if the field is defined in the namcouple and if its coupling period
350	! is not greater than the time of the simulation.
351	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
352	ig_def_freq(id_port_id) .gt. ig_ntime .or. &
353	ig_def_state(id_port_id) .eq. ip_auxilary) THEN
354	GOTO 1010
355	ENDIF
356	IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
357	IF (iport.lt.0) THEN
358	kinfo = CLIM_BadPort
359	WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
360	cports(id_port_id)
361	GO TO 1010
362	ENDIF
363	!
364	!* Test if the current time is a coupling (or I/O) time
365	!
366	IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
367	!
368	!* If the user indicated in the namcouple that the field is
369	!* a field input-from-file (keyword 'INPUT' at the end of the
370	!* field 1st line), do the reading from file here, e.g.:
371	!
372	#if !defined key_noIO
373	IF (ig_def_state(iport) .eq. ip_input) then
374	WRITE(nulprt,*) 'Get - Input field'
375	CALL psmile_read_8(iport,rd_field,kstep)
376	kinfo = PRISM_Input
377	ENDIF
378	#endif
379	!
380	!* Define return code (direct or via Oasis does not matter)
381	!
382	IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
383	kinfo = PRISM_FromRest
384	#if !defined key_noIO
385	IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
386	ig_def_state(iport) .EQ. ip_expout) THEN
387	kinfo = PRISM_FromRestOut
388	ENDIF
389	#endif
390	ELSE
391	IF (ig_def_state(iport) .NE. ip_input) THEN
392	kinfo = PRISM_Recvd
393	!
394	#if !defined key_noIO
395	IF (ig_def_state(iport) .EQ. ip_expout .OR. &
396	ig_def_state(iport) .EQ. ip_ignout) THEN
397	kinfo = PRISM_RecvOut
398	ENDIF
399	#endif
400	ENDIF
401	ENDIF
402	!
403	!* Test if first import and if the user indicated in the
404	!* namcouple that the field is exchanged directly
405	!* between the models and not treated by Oasis
406	!* (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
407	!* do the reading from restart file (not implemented).
408	!
409	IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
410	(ig_def_state(iport) .eq. ip_ignored .or. &
411	ig_def_state(iport) .eq. ip_ignout)) THEN
412	!
413	!* Note: A model can have several restart files but same restart
414	!* file can't be used by different models
415	!* Test if model is serial or parallel and if variables are real
416	! or double precision
417	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
418	call read_filer8(rd_field, cports(iport),iport)
419	ELSE
420	call read_file_parar8(rd_field, cports(iport),iport)
421	ENDIF
422	#if !defined key_noIO
423	IF (ig_def_state(iport) .EQ. ip_ignout) &
424	CALL psmile_write_8(iport,rd_field,kstep)
425	#endif
426	ELSE
427	!*
428	!* If the user indicated in the namcouple that the field is
429	!* a coupling field then do the import :
430	!
431	IF (ig_def_state(iport) .ne. ip_output .and. &
432	ig_def_state(iport) .ne. ip_input) THEN
433	!
434	!* Check for connected ports (in)
435	! ------------------------------
436	!
437	WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
438	!
439	ityp = myport(2,iport)
440	ibyt = myport(3,iport)
441	!
442	DO ip=1,myport(5,iport)
443	!
444	ilk = myport(5+ip,iport)
445	imod = mylink(1,ilk)
446	itid = mylink(2,ilk)
447	itag = mylink(3,ilk) - kstep / ig_frqmin
448	iseg = mylink(4,ilk)
449	!
450	!* Implementation with "blocking" receives : the program will wait
451	!* indefinitely until a message is received (this may generate a
452	!* deadlock if all models are waiting on a receive).
453	!* However this method will be more efficient in most cases than the
454	!* receives with a time-out loop.
455	!
456	!
457	#ifdef __DEBUG
458	!jl
459	!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
460	!jl exist in the network (2004-04-28)
461	!jl
462	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
463	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
464	' comm = ',mpi_comm,' result is : ',iflag
465	call flush(nulprt)
466
467	IF (.NOT.iflag) THEN
468	icount = 0
469	WAITLOOP: DO
470	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
471	icount = icount + 1
472	IF ( iflag ) EXIT WAITLOOP
473	IF ( icount .GE. icountmax ) THEN
474	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
475	' still negative after ',icountmax,' seconds : Abort the job'
476	call flush(nulprt)
477	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
478	ENDIF
479	call sleep(1)
480	END DO WAITLOOP
481	WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
482	call flush(nulprt)
483	ENDIF
484	!jl
485	#endif
486	CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
487	itid, itag, mpi_comm, istatus, info )
488	CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
489	info )
490	!
491	IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN
492	ilgb = 0
493	iposbuf = 0
494	DO is=1,iseg
495	ioff = mylink(4+2*is-1,ilk) + 1
496	il_len = mylink(4+2*is,ilk)
497	!
498	! IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double) THEN
499	IF ( ityp .EQ. PRISM_Real ) THEN
500	CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
501	iposbuf, rd_field(ioff), il_len, &
502	MPI_DOUBLE_PRECISION, mpi_comm, info)
503	ELSE
504	WRITE(nulprt,*)'Get - pb type incorrect ',ityp
505	kinfo = CLIM_BadType
506	GO TO 1010
507	ENDIF
508	ilgb = ilgb + il_len
509	ENDDO
510	IF (ilgb*ibyt .le. imaxbyt) THEN
511	irecv = irecv + 1
512	nbrecv = nbrecv + ilgb * ibyt
513	WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
514	'Get - <from:',imod, &
515	'> <step:',kstep, &
516	'> <len:',ilgb, &
517	'> <type:',ibyt, &
518	'> <tag:',itag,'>'
519	ELSE
520	kinfo = CLIM_Unpack
521	WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
522	info,'>'
523	ENDIF
524	ELSE
525	kinfo = CLIM_TimeOut
526	WRITE(nulprt,FMT='(A,I3,A)') &
527	'Get - abnormal exit from trecv <mpi ',info,'>'
528	ENDIF
529	!
530	ENDDO
531	!
532	WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
533	!
534	#if !defined key_noIO
535	IF (ig_def_state(iport) .eq. ip_expout .or. &
536	ig_def_state(iport) .eq. ip_ignout) &
537	!
538	!* If the user indicated in the namcouple that the field must be written
539	!* to file, do the writing here :
540	!
541	CALL psmile_write_8(iport,rd_field,kstep)
542	#endif
543	ENDIF
544	ENDIF
545	ENDIF
546	!
547	! ----------------------------------------------------------------
548	!
549	1010 CONTINUE
550	CALL FLUSH(nulprt)
551	RETURN
552	END SUBROUTINE prism_get_proto_r18
553
554	SUBROUTINE prism_get_proto_r24(id_port_id,kstep,rd_field_2d,kinfo)
555	!
556	!* * PRISM_get * PRISM 1.0
557	!
558	! purpose:
559	! --------
560	! recv pfield from oasis or models connected to port id_port_id
561	!
562	! interface:
563	! ----------
564	! id_port_id : port number of the field
565	! kstep : current time in seconds
566	! rd_field_2d : buffer of reals
567	! kinfo : output status
568	!
569	! lib mp:
570	! -------
571	! mpi-1 or mpi-2
572	!
573	! author:
574	! -------
575	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import)
576	! S. Legutke, - MPI M&D (05/03 - kinfo = PRISM_Recvd added)
577	! ----------------------------------------------------------------
578	USE mod_kinds_model
579	USE mod_prism_proto
580	USE mod_comprism_proto
581	IMPLICIT none
582	#include <mpif.h>
583	! ----------------------------------------------------------------
584	INTEGER (kind=ip_intwp_p), intent(in) :: id_port_id, kstep
585	INTEGER (kind=ip_intwp_p), intent(out) :: kinfo
586	REAL(kind=ip_single_p), DIMENSION(:,:), intent(inout) :: rd_field_2d
587	! ----------------------------------------------------------------
588	REAL(kind=ip_single_p), DIMENSION(myport(4,id_port_id)) :: rd_field
589	INTEGER (kind=ip_intwp_p) info, ip, iport
590	INTEGER (kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb
591	INTEGER (kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt
592	INTEGER (kind=ip_intwp_p) iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
593	!jl
594	#ifdef __DEBUG
595	INTEGER(kind=ip_intwp_p) icount
596	INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
597	LOGICAL :: iflag
598	#endif
599	! ----------------------------------------------------------------
600	!
601	rd_field(:)=0
602	!
603	!* 0. First Check
604	! --------------
605	!
606	IF (nexit.ne.1) THEN
607	kinfo = CLIM_FastExit
608	WRITE(nulprt,FMT='(A)') 'Get - should not be called'
609	GO TO 1010
610	ENDIF
611	kinfo = PRISM_Ok
612	!
613	!* 1. check for this port in my list
614	! ---------------------------------
615	!
616	irecv = 0
617	iport = -1
618	!
619	! Test if the field is defined in the namcouple and if its coupling period
620	! is not greater than the time of the simulation.
621	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
622	ig_def_freq(id_port_id) .gt. ig_ntime .or. &
623	ig_def_state(id_port_id) .eq. ip_auxilary) THEN
624	GOTO 1010
625	ENDIF
626	IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
627	IF (iport.lt.0) THEN
628	kinfo = CLIM_BadPort
629	WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
630	cports(id_port_id)
631	GO TO 1010
632	ENDIF
633	!
634	!
635	!* Test if the current time is a coupling (or I/O) time
636	!
637	IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
638	!
639	!* If the user indicated in the namcouple that the field is
640	!* a field input-from-file (keyword 'INPUT' at the end of the
641	!* field 1st line), do the reading from file here, e.g.:
642	!
643	#if !defined key_noIO
644	IF (ig_def_state(iport) .EQ. ip_input) THEN
645	CALL psmile_read_4(iport,rd_field,kstep)
646	kinfo = PRISM_Input
647	ENDIF
648	#endif
649	!
650	!* Define return code (direct or via Oasis does not matter)
651	!
652	IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
653	kinfo = PRISM_FromRest
654	#if !defined key_noIO
655	IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
656	ig_def_state(iport) .EQ. ip_expout) THEN
657	kinfo = PRISM_FromRestOut
658	ENDIF
659	#endif
660	ELSE
661	IF (ig_def_state(iport) .NE. ip_input) THEN
662	kinfo = PRISM_Recvd
663	!
664	#if !defined key_noIO
665	IF (ig_def_state(iport) .EQ. ip_expout .OR. &
666	ig_def_state(iport) .EQ. ip_ignout) THEN
667	kinfo = PRISM_RecvOut
668	ENDIF
669	#endif
670	ENDIF
671	ENDIF
672	!
673	!* Test if first import and if the user indicated in the
674	!* namcouple that the field is
675	!* exchanged directly between the models and not treated by
676	!* Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
677	!* do the reading from restart file (not implemented).
678	!
679	IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
680	(ig_def_state(iport) .eq. ip_ignored .or. &
681	ig_def_state(iport) .eq. ip_ignout)) THEN
682	!
683	!* Note: A model can have several restart files but same restart
684	!* file can't be used by different models
685	!* Test if model is serial or parallel and if variables are real
686	! or double precision
687	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
688	call read_filer4(rd_field, cports(iport),iport)
689	ELSE
690	call read_file_parar4(rd_field, cports(iport),iport)
691	ENDIF
692	#if !defined key_noIO
693	IF (ig_def_state(iport) .EQ. ip_ignout) &
694	call psmile_write_4(iport,rd_field,kstep)
695	#endif
696	ELSE
697	!
698	!* If the user indicated in the namcouple that the field is
699	!* a coupling field then do the import :
700	IF (ig_def_state(iport) .NE. ip_output .AND. &
701	ig_def_state(iport) .ne. ip_input) THEN
702	!
703	!* Check for connected ports (in)
704	! ------------------------------
705	!
706	WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
707	!
708	ityp = myport(2,iport)
709	ibyt = myport(3,iport)
710	!
711	DO ip=1,myport(5,iport)
712	!
713	ilk = myport(5+ip,iport)
714	imod = mylink(1,ilk)
715	itid = mylink(2,ilk)
716	itag = mylink(3,ilk) - kstep / ig_frqmin
717	iseg = mylink(4,ilk)
718	!
719	!* Implementation with "blocking" receives : the program will wait
720	!* indefinitely until a message is received (this may generate a
721	!* deadlock if all models are waiting on a receive).
722	!* However this method will be more efficient in most cases than the
723	!* receives with a time-out loop.
724	!
725	#ifdef __DEBUG
726	!
727	!jl
728	!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
729	!jl exist in the network (2004-04-28)
730	!jl
731	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
732	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
733	' comm = ',mpi_comm,' result is : ',iflag
734	call flush(nulprt)
735
736	IF (.NOT.iflag) THEN
737	icount = 0
738	WAITLOOP: DO
739	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
740	icount = icount + 1
741	IF ( iflag ) EXIT WAITLOOP
742	IF ( icount .GE. icountmax ) THEN
743	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
744	' still negative after ',icountmax,' seconds : Abort the job'
745	call flush(nulprt)
746	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
747	ENDIF
748	call sleep(1)
749	END DO WAITLOOP
750	WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
751	call flush(nulprt)
752	ENDIF
753	!jl
754	#endif
755	CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
756	itid, itag, mpi_comm, istatus, info )
757	CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
758	info )
759	!
760	IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN
761	ilgb = 0
762	iposbuf = 0
763	DO is=1,iseg
764	ioff = mylink(4+2is-1,ilk) 2 + 1
765	il_len = mylink(4+2*is,ilk)
766	!
767	IF ( ityp .EQ. PRISM_Real ) THEN
768	CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
769	iposbuf, rd_field(ioff), il_len, &
770	MPI_REAL, mpi_comm, info)
771	ELSE
772	WRITE(nulprt,*)'Get - pb type incorrect ',ityp
773	kinfo = CLIM_BadType
774	GO TO 1010
775	ENDIF
776	ilgb = ilgb + il_len
777	ENDDO
778	IF (ilgb*ibyt .le. imaxbyt) THEN
779	irecv = irecv + 1
780	nbrecv = nbrecv + ilgb * ibyt
781	WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
782	'Get - <from:',imod, &
783	'> <step:',kstep, &
784	'> <len:',ilgb, &
785	'> <type:',ibyt, &
786	'> <tag:',itag,'>'
787	ELSE
788	kinfo = CLIM_Unpack
789	WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
790	info,'>'
791	ENDIF
792	ELSE
793	kinfo = CLIM_TimeOut
794	WRITE(nulprt,FMT='(A,I3,A)') &
795	'Get - abnormal exit from trecv <mpi ',info,'>'
796	ENDIF
797	!
798	ENDDO
799	!
800	WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
801	!
802	#if !defined key_noIO
803	IF (ig_def_state(iport) .eq. ip_expout .or. &
804	ig_def_state(iport) .eq. ip_ignout) &
805	!
806	!* If the user indicated in the namcouple that the field must be written
807	!* to file, do the writing here :
808	!
809	call psmile_write_4(iport,rd_field,kstep)
810	#endif
811	ENDIF
812	rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), &
813	size(rd_field_2d,2)/))
814	ENDIF
815	ENDIF
816	!
817	! ----------------------------------------------------------------
818	!
819	1010 CONTINUE
820	CALL FLUSH(nulprt)
821	RETURN
822	END SUBROUTINE prism_get_proto_r24
823
824	SUBROUTINE prism_get_proto_r28(id_port_id,kstep,rd_field_2d,kinfo)
825	!
826	!* * PRISM_get * PRISM 1.0
827	!
828	! purpose:
829	! --------
830	! recv pfield from oasis or models connected to port id_port_id
831	!
832	! interface:
833	! ----------
834	! id_port_id : port number of the field
835	! kstep : current time in seconds
836	! rd_field_2d : buffer of reals
837	! kinfo : output status
838	!
839	! lib mp:
840	! -------
841	! mpi-1 or mpi-2
842	!
843	! author:
844	! -------
845	! Arnaud Caubel - Fecit (08/02 - created from CLIM_Import)
846	! S. Legutke - MPI M&D (05/03 - kinfo = PRISM_Recvd added)
847	! ----------------------------------------------------------------
848	USE mod_kinds_model
849	USE mod_prism_proto
850	USE mod_comprism_proto
851	IMPLICIT none
852	#include <mpif.h>
853	! ----------------------------------------------------------------
854	INTEGER(kind=ip_intwp_p), intent(in) :: id_port_id, kstep
855	INTEGER(kind=ip_intwp_p), intent(out) :: kinfo
856	REAL(kind=ip_double_p), DIMENSION(:,:), intent(inout) :: rd_field_2d
857	! ----------------------------------------------------------------
858	REAL(kind=ip_double_p), DIMENSION(myport(4,id_port_id)) :: rd_field
859	INTEGER(kind=ip_intwp_p) info, ip, iport
860	INTEGER(kind=ip_intwp_p) irecv, imod, ilk, iseg, is, ilgb
861	INTEGER(kind=ip_intwp_p) itid, itag, il_len, ioff, ityp, ibyt
862	INTEGER(kind=ip_intwp_p) iposbuf, istatus(MPI_STATUS_SIZE), imaxbyt
863	!jl
864	#ifdef __DEBUG
865	INTEGER(kind=ip_intwp_p) icount
866	INTEGER(kind=ip_intwp_p), parameter :: icountmax=600
867	LOGICAL :: iflag
868	#endif
869	! ----------------------------------------------------------------
870	rd_field(:)=0
871	!
872	!* 0. First Check
873	! --------------
874	!
875	IF (nexit.ne.1) THEN
876	kinfo = CLIM_FastExit
877	WRITE(nulprt,FMT='(A)') 'Get - should not be called'
878	GO TO 1010
879	ENDIF
880	kinfo = PRISM_Ok
881	!
882	!* 1. check for this port in my list
883	! ---------------------------------
884	!
885	irecv = 0
886	iport = -1
887	!
888	! Test if the field is defined in the namcouple and if its coupling period
889	! is not greater than the time of the simulation.
890	IF (ig_def_freq(id_port_id) .eq. 0 .or. &
891	ig_def_freq(id_port_id) .gt. ig_ntime .or. &
892	ig_def_state(id_port_id) .eq. ip_auxilary) THEN
893	GOTO 1010
894	ENDIF
895	IF (myport(1,id_port_id).eq.CLIM_In) iport=id_port_id
896	IF (iport.lt.0) THEN
897	kinfo = CLIM_BadPort
898	WRITE(nulprt,FMT='(A,A)')'Get - WARNING - Invalid port in: ', &
899	cports(id_port_id)
900	GO TO 1010
901	ENDIF
902	!
903	!* Test if the current time is a coupling (or I/O) time
904	!
905	IF (mod(kstep,ig_def_freq(iport)).eq.0) THEN
906	!
907	!* If the user indicated in the namcouple that the field is
908	!* a field input-from-file (keyword 'INPUT' at the end of the
909	!* field 1st line), do the reading from file here, e.g.:
910	!
911	#if !defined key_noIO
912	IF (ig_def_state(iport) .EQ. ip_input) THEN
913	CALL psmile_read_8(iport,rd_field,kstep)
914	kinfo = PRISM_Input
915	ENDIF
916	#endif
917	!
918	!* Define return code (direct or via Oasis does not matter)
919	!
920	IF (kstep.EQ.0 .AND. ig_def_lag(iport) .GT. 0) THEN
921	kinfo = PRISM_FromRest
922	#if !defined key_noIO
923	IF (ig_def_state(iport) .EQ. ip_ignout .OR. &
924	ig_def_state(iport) .EQ. ip_expout) THEN
925	kinfo = PRISM_FromRestOut
926	ENDIF
927	#endif
928	ELSE
929	IF (ig_def_state(iport) .NE. ip_input) THEN
930	kinfo = PRISM_Recvd
931	!
932	#if !defined key_noIO
933	IF (ig_def_state(iport) .EQ. ip_expout .OR. &
934	ig_def_state(iport) .EQ. ip_ignout) THEN
935	kinfo = PRISM_RecvOut
936	ENDIF
937	#endif
938	ENDIF
939	ENDIF
940	!
941	!* Test if first import and if the user indicated in the
942	!* namcouple that the field is
943	!* exchanged directly between the models and not treated by
944	!* Oasis (keyword 'IGNORED' or 'IGNOUT' at the end of the field 1st line),
945	!* do the reading from restart file (not implemented).
946	!
947	IF (kstep.eq.0 .and. ig_def_lag(iport) .gt. 0 .and. &
948	(ig_def_state(iport) .eq. ip_ignored .or. &
949	ig_def_state(iport) .eq. ip_ignout)) THEN
950	!
951	!* Note: A model can have several restart files but same restart
952	!* file can't be used by different models
953	!* Test if model is serial or parallel and if variables are real
954	! or double precision
955	IF (mydist(CLIM_Strategy,iport) .eq. CLIM_Serial) THEN
956	call read_filer8(rd_field, cports(iport),iport)
957	ELSE
958	call read_file_parar8(rd_field, cports(iport),iport)
959	ENDIF
960	#if !defined key_noIO
961	IF (ig_def_state(iport) .EQ. ip_ignout) &
962	CALL psmile_write_8(iport,rd_field,kstep)
963	#endif
964	ELSE
965	!*
966	!* If the user indicated in the namcouple that the field is
967	!* a coupling field then do the import :
968	IF (ig_def_state(iport) .NE. ip_output .AND. &
969	ig_def_state(iport) .ne. ip_input) THEN
970	!
971	!* Check for connected ports (in)
972	! ------------------------------
973	!
974	WRITE(nulprt,FMT='(A,A)') 'Get - ', cports(iport)
975	!
976	ityp = myport(2,iport)
977	ibyt = myport(3,iport)
978	!
979	DO ip=1,myport(5,iport)
980	!
981	ilk = myport(5+ip,iport)
982	imod = mylink(1,ilk)
983	itid = mylink(2,ilk)
984	itag = mylink(3,ilk) - kstep / ig_frqmin
985	iseg = mylink(4,ilk)
986	!
987	!* Implementation with "blocking" receives : the program will wait
988	!* indefinitely until a message is received (this may generate a
989	!* deadlock if all models are waiting on a receive).
990	!* However this method will be more efficient in most cases than the
991	!* receives with a time-out loop.
992	!
993	#ifdef __DEBUG
994	!
995	!jl
996	!jl add a nonblocking syntax, in order to avoid deadlocks, when NO mailbox
997	!jl exist in the network (2004-04-28)
998	!jl
999	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
1000	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
1001	' comm = ',mpi_comm,' result is : ',iflag
1002	call flush(nulprt)
1003
1004	IF (.NOT.iflag) THEN
1005	icount = 0
1006	WAITLOOP: DO
1007	CALL MPI_Iprobe ( itid, itag, mpi_comm, iflag, istatus, info )
1008	icount = icount + 1
1009	IF ( iflag ) EXIT WAITLOOP
1010	IF ( icount .GE. icountmax ) THEN
1011	WRITE(nulprt,*) 'probing for tid = ',itid,' tag = ',itag, &
1012	' still negative after ',icountmax,' seconds : Abort the job'
1013	call flush(nulprt)
1014	CALL MPI_ABORT (mpi_comm, 0, mpi_err)
1015	ENDIF
1016	call sleep(1)
1017	END DO WAITLOOP
1018	WRITE(nulprt,*) 'probing for tid = ',itid,'icount = ', icount
1019	call flush(nulprt)
1020	ENDIF
1021	!jl
1022	#endif
1023	CALL MPI_Recv ( pkwork_field, ig_maxtype_field, MPI_PACKED, &
1024	itid, itag, mpi_comm, istatus, info )
1025	CALL MPI_Get_count ( istatus, MPI_PACKED, imaxbyt, &
1026	info )
1027	!
1028	IF ( info .EQ. CLIM_ok .AND. imaxbyt .GT. 0) THEN
1029	ilgb = 0
1030	iposbuf = 0
1031	DO is=1,iseg
1032	ioff = mylink(4+2*is-1,ilk) + 1
1033	il_len = mylink(4+2*is,ilk)
1034	!
1035	! IF ( ityp .EQ. PRISM_Real .or. ityp .EQ. PRISM_Double ) THEN
1036	IF ( ityp .EQ. PRISM_Real ) THEN
1037	CALL MPI_Unpack ( pkwork_field, ig_maxtype_field, &
1038	iposbuf, rd_field(ioff), il_len, &
1039	MPI_DOUBLE_PRECISION, mpi_comm, info)
1040	ELSE
1041	WRITE(nulprt,*)'Get - pb type incorrect ',ityp
1042	kinfo = CLIM_BadType
1043	GO TO 1010
1044	ENDIF
1045	ilgb = ilgb + il_len
1046	ENDDO
1047	IF (ilgb*ibyt .le. imaxbyt) THEN
1048	irecv = irecv + 1
1049	nbrecv = nbrecv + ilgb * ibyt
1050	WRITE(nulprt,FMT='(A,I2,A,I9,A,I7,A,I2,A,I10,A)') &
1051	'Get - <from:',imod, &
1052	'> <step:',kstep, &
1053	'> <len:',ilgb, &
1054	'> <type:',ibyt, &
1055	'> <tag:',itag,'>'
1056	ELSE
1057	kinfo = CLIM_Unpack
1058	WRITE(nulprt,FMT='(A,I3,A)')'Get - pb unpack <mpi ', &
1059	info,'>'
1060	GO TO 1010
1061	ENDIF
1062	ELSE
1063	kinfo = CLIM_TimeOut
1064	WRITE(nulprt,FMT='(A,I3,A)') &
1065	'Get - abnormal exit from trecv <mpi ',info,'>'
1066	GO TO 1010
1067	ENDIF
1068	!
1069	ENDDO
1070	!
1071	WRITE(nulprt,FMT='(A,I3,A)')'Get - ',irecv,' fields imported'
1072	!
1073	#if !defined key_noIO
1074	IF (ig_def_state(iport) .eq. ip_expout .or. &
1075	ig_def_state(iport) .eq. ip_ignout) &
1076	!
1077	!* If the user indicated in the namcouple that the field must be written
1078	!* to file, do the writing here :
1079	!
1080	call psmile_write_8(iport,rd_field,kstep)
1081	#endif
1082	ENDIF
1083	rd_field_2d(:,:) = RESHAPE (rd_field(:),(/size(rd_field_2d,1), &
1084	size(rd_field_2d,2)/))
1085	ENDIF
1086	ENDIF
1087	!
1088	! ----------------------------------------------------------------
1089	!
1090	1010 CONTINUE
1091	CALL FLUSH(nulprt)
1092	RETURN
1093	END SUBROUTINE prism_get_proto_r28
1094
1095	! ********************************************************************
1096	! ********************************************************************
1097	! ********************************************************************
1098	!
1099	!* * READ_FILE * PRISM 1.0
1100	!
1101	! purpose:
1102	! --------
1103	! At first time step, reads input fields from binary files or
1104	! netcdf files.
1105	!
1106	! interface:
1107	! ----------
1108	! inp_fld : field to be read from the restart file
1109	! cd_port : symbolic name of the field
1110	! id_port : port number of the field
1111	!
1112	! lib mp:
1113	! -------
1114	! mpi-1
1115	!
1116	! author:
1117	! -------
1118	! Eric Sevault - METEO FRANCE
1119	! Laurent Terray - CERFACS
1120	! Jean Latour - F.S.E. (mpi-2)
1121	! Arnaud Caubel - Adaptation to PRISM interface
1122	! ----------------------------------------------------------------
1123	SUBROUTINE read_filer4(inp_fld, cd_port,id_port)
1124	! ----------------------------------------------------------------
1125	USE mod_kinds_model
1126	USE mod_prism_proto
1127	USE mod_comprism_proto
1128	IMPLICIT NONE
1129	include 'netcdf.inc'
1130	! ----------------------------------------------------------------
1131	INTEGER(kind=ip_intwp_p) :: id_port
1132	REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port))
1133	CHARACTER(len=8) :: cd_port
1134	! ----------------------------------------------------------------
1135	INTEGER(kind=ip_intwp_p) il_unit
1136	INTEGER(kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus
1137	LOGICAL ll_file
1138	! ----------------------------------------------------------------
1139	WRITE(nulprt,*)'Entering Read_File '
1140	!
1141	!* Test if restart file is in NETCDF format or not
1142	!
1143	IF (lg_ncdfrst) THEN
1144	!
1145	!* Case NETCDF format
1146	!
1147	istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid)
1148	IF (istatus.ne.NF_NOERR) THEN
1149	WRITE(nulprt,*) NF_STRERROR(istatus)
1150	WRITE(nulprt,*)' stop in PRISM_get routine '
1151	STOP
1152	ENDIF
1153	istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
1154	IF (istatus.ne.NF_NOERR) THEN
1155	WRITE(nulprt,*) NF_STRERROR(istatus)
1156	WRITE(nulprt,*)' stop in PRISM_get routine '
1157	STOP
1158	ENDIF
1159	istatus = NF_GET_VAR_REAL (il_ncid, il_varid, inp_fld)
1160	IF (istatus.ne.NF_NOERR) THEN
1161	WRITE(nulprt,*) NF_STRERROR(istatus)
1162	WRITE(nulprt,*)' stop in PRISM_get routine '
1163	STOP
1164	ENDIF
1165	istatus = NF_CLOSE(il_ncid)
1166	IF (istatus.ne.NF_NOERR) THEN
1167	WRITE(nulprt,*) NF_STRERROR(istatus)
1168	WRITE(nulprt,*)' stop in PRISM_get routine '
1169	STOP
1170	ENDIF
1171	ELSE
1172	!
1173	!* Case binary format
1174	!
1175	il_unit = nulprt + 1
1176	INQUIRE (il_unit,OPENED = ll_file)
1177	DO WHILE (ll_file)
1178	il_unit = il_unit + 1
1179	INQUIRE (il_unit,OPENED = ll_file)
1180	END DO
1181	OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
1182	CALL locreadr4(cd_port,inp_fld,myport(4,id_port),il_unit, &
1183	ierror, nulprt)
1184	CLOSE (il_unit)
1185	ENDIF
1186	END SUBROUTINE read_filer4
1187
1188	! ********************************************************************
1189	! ********************************************************************
1190	! ********************************************************************
1191	!
1192	!* * READ_FILE * PRISM 1.0
1193	!
1194	! purpose:
1195	! --------
1196	! At first time step, reads input fields from binary files or
1197	! netcdf files.
1198	!
1199	! interface:
1200	! ----------
1201	! inp_fld : field to be read from the restart file
1202	! cd_port : symbolic name of the field
1203	! id_port : port number of the field
1204	!
1205	! lib mp:
1206	! -------
1207	! mpi-1
1208	!
1209	! author:
1210	! -------
1211	! Eric Sevault - METEO FRANCE
1212	! Laurent Terray - CERFACS
1213	! Jean Latour - F.S.E. (mpi-2)
1214	! Arnaud Caubel - Adaptation to PRISM interface
1215	! ----------------------------------------------------------------
1216	SUBROUTINE read_filer8(inp_fld, cd_port,id_port)
1217	! ----------------------------------------------------------------
1218	USE mod_kinds_model
1219	USE mod_prism_proto
1220	USE mod_comprism_proto
1221	IMPLICIT NONE
1222	include 'netcdf.inc'
1223	! ----------------------------------------------------------------
1224	INTEGER (kind=ip_intwp_p) :: id_port
1225	REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port))
1226	CHARACTER(len=8) :: cd_port
1227	! ----------------------------------------------------------------
1228	INTEGER (kind=ip_intwp_p) il_unit
1229	INTEGER (kind=ip_intwp_p) ierror,info, il_varid, il_ncid, istatus
1230	LOGICAL ll_file
1231	! ----------------------------------------------------------------
1232	WRITE(nulprt,*)'Entering Read_File '
1233	!
1234	!* Test if restart file is in NETCDF format or not
1235	!
1236	IF (lg_ncdfrst) THEN
1237	!
1238	!* Case NETCDF format
1239	!
1240	istatus = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE,il_ncid)
1241	IF (istatus.ne.NF_NOERR) THEN
1242	WRITE(nulprt,*) NF_STRERROR(istatus)
1243	WRITE(nulprt,*)' stop in PRISM_get routine '
1244	STOP
1245	ENDIF
1246	istatus = NF_INQ_VARID(il_ncid, cd_port, il_varid)
1247	IF (istatus.ne.NF_NOERR) THEN
1248	WRITE(nulprt,*) NF_STRERROR(istatus)
1249	WRITE(nulprt,*)' stop in PRISM_get routine '
1250	STOP
1251	ENDIF
1252	istatus = NF_GET_VAR_DOUBLE (il_ncid, il_varid, inp_fld)
1253	IF (istatus.ne.NF_NOERR) THEN
1254	WRITE(nulprt,*) NF_STRERROR(istatus)
1255	WRITE(nulprt,*)' stop in PRISM_get routine '
1256	STOP
1257	ENDIF
1258	istatus = NF_CLOSE(il_ncid)
1259	IF (istatus.ne.NF_NOERR) THEN
1260	WRITE(nulprt,*) NF_STRERROR(istatus)
1261	WRITE(nulprt,*)' stop in PRISM_get routine '
1262	STOP
1263	ENDIF
1264	ELSE
1265	!
1266	!* Case binary format
1267	!
1268	il_unit = nulprt + 1
1269	INQUIRE (il_unit,OPENED = ll_file)
1270	DO WHILE (ll_file)
1271	il_unit = il_unit + 1
1272	INQUIRE (il_unit,OPENED = ll_file)
1273	END DO
1274	OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
1275	CALL locreadr8(cd_port,inp_fld,myport(4,id_port),il_unit, &
1276	ierror, nulprt)
1277	CLOSE (il_unit)
1278	ENDIF
1279	END SUBROUTINE read_filer8
1280
1281	! ********************************************************************
1282	! ********************************************************************
1283	! ********************************************************************
1284	!
1285	!* * READ_FILE_PARA * PRISM 1.0
1286	!
1287	! purpose:
1288	! --------
1289	! At first time step, reads input fields from binary files or
1290	! netcdf files.
1291	!
1292	! interface:
1293	! ----------
1294	! inp_fld : field to be read from the restart file
1295	! cd_port : symbolic name of the field
1296	! id_port : port number of the field
1297	!
1298	! lib mp:
1299	! -------
1300	! mpi-1
1301	!
1302	! author:
1303	! -------
1304	! Eric Sevault - METEO FRANCE
1305	! Laurent Terray - CERFACS
1306	! Jean Latour - F.S.E. (mpi-2)
1307	! Arnaud Caubel - Adaptation to PRISM interface
1308	! ----------------------------------------------------------------
1309	SUBROUTINE read_file_parar4(inp_fld, cd_port, id_port)
1310	! ----------------------------------------------------------------
1311	USE mod_kinds_model
1312	USE mod_prism_proto
1313	USE mod_comprism_proto
1314	IMPLICIT NONE
1315	#include <netcdf.inc>
1316	#include <mpif.h>
1317	! ----------------------------------------------------------------
1318	INTEGER (kind=ip_intwp_p) :: id_port
1319	CHARACTER(len=8) :: cd_port
1320	REAL(kind=ip_single_p) :: inp_fld(myport(4,id_port))
1321	! ----------------------------------------------------------------
1322	INTEGER (kind=ip_intwp_p),PARAMETER :: ip_tag=100
1323	INTEGER (kind=ip_intwp_p) il_unit
1324	INTEGER (kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf, il_aux
1325	INTEGER (kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len
1326	INTEGER (kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
1327	INTEGER (kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
1328	REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work
1329	REAL(kind=ip_single_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
1330	LOGICAL ll_file
1331	INTEGER(kind=ip_intwp_p)::il_sndreq
1332	! ----------------------------------------------------------------
1333	WRITE(nulprt,*)'Entering Read_File_Para '
1334	istatus(:)=0
1335	!
1336	!* Each process of local communicator sends his decomposition to master proc
1337	!
1338	CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
1339	ip_tag, ig_local_comm, ierror )
1340	CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
1341	ip_tag+1, ig_local_comm, ierror )
1342	!
1343	!* Master proc receives each process decomposition
1344	!
1345	IF (mpi_rank.eq.0) THEN
1346	il_maxgrd = 0
1347	ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
1348	il_paral_mast(:,:)=0
1349	DO ib = 0, kbcplproc(ig_mynummod)-1
1350	CALL MPI_Recv (il_paral_mast(:,ib+1), &
1351	CLIM_Parsize, MPI_INTEGER, ib, &
1352	ip_tag, ig_local_comm, istatus, ierror )
1353	CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
1354	ip_tag+1, ig_local_comm, istatus, ierror )
1355	il_maxgrd = il_maxgrd + il_aux
1356	END DO
1357	il_maxbyte = il_maxgrd * 4
1358	ENDIF
1359	ALLOCATE(rl_work(myport(4,id_port)))
1360	IF (mpi_rank.eq.0) THEN
1361	ALLOCATE (rl_start(il_maxgrd))
1362	ALLOCATE(rl_work_mast(il_maxgrd))
1363	rl_start(:)=0
1364	rl_work_mast(:)=0
1365	!
1366	!* Test if restart file is in NETCDF format or not
1367	!
1368	IF (lg_ncdfrst) THEN
1369	!
1370	!* Case NETCDF format
1371	!
1372	il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, &
1373	il_ncid)
1374	IF (il_status_ncdf.ne.NF_NOERR) THEN
1375	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1376	WRITE(nulprt,*)' stop in PRISM_get routine '
1377	STOP
1378	ENDIF
1379	il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
1380	IF (il_status_ncdf.ne.NF_NOERR) THEN
1381	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1382	WRITE(nulprt,*)' stop in PRISM_get routine '
1383	STOP
1384	ENDIF
1385	il_status_ncdf = NF_GET_VAR_REAL (il_ncid, il_varid, rl_start)
1386	IF (il_status_ncdf.ne.NF_NOERR) THEN
1387	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1388	WRITE(nulprt,*)' stop in PRISM_put routine '
1389	STOP
1390	ENDIF
1391	il_status_ncdf = NF_CLOSE(il_ncid)
1392	IF (il_status_ncdf.ne.NF_NOERR) THEN
1393	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1394	WRITE(nulprt,*)' stop in PRISM_get routine '
1395	STOP
1396	ENDIF
1397	ELSE
1398	!
1399	!* Case binary format
1400	!
1401	il_unit = nulprt + 1
1402	INQUIRE (il_unit,OPENED = ll_file)
1403	DO WHILE (ll_file)
1404	il_unit = il_unit + 1
1405	INQUIRE (il_unit,OPENED = ll_file)
1406	END DO
1407	OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
1408	CALL locreadr4(cd_port,rl_start,il_maxgrd,il_unit, &
1409	ierror, nulprt)
1410	!
1411	CLOSE (il_unit)
1412	ENDIF
1413	!
1414	!* Master proc sends to each proc his part of the field
1415	!
1416	DO ib = kbcplproc(ig_mynummod)- 1,0,-1
1417	iposbuf=0
1418	DO ib_aux=1,il_paral_mast(clim_segments,ib+1)
1419	il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1
1420	il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1)
1421	call MPI_Pack(rl_start(il_off:il_off+il_len-1), &
1422	il_len,MPI_REAL,rl_work_mast,il_maxbyte, &
1423	iposbuf, ig_local_comm, ierror)
1424	END DO
1425	IF(ib.GT.0) THEN
1426	CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
1427	ip_tag+2, ig_local_comm, ierror )
1428	ELSE
1429	CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
1430	ip_tag+2, ig_local_comm,il_sndreq, ierror )
1431	ENDIF
1432	ENDDO
1433	DEALLOCATE (il_paral_mast)
1434	DEALLOCATE (rl_work_mast)
1435	DEALLOCATE (rl_start)
1436	ENDIF
1437	!
1438	!* Each proc receives his part of the field
1439	!
1440	call MPI_Recv ( rl_work, myport(4,id_port)*4, MPI_PACKED, 0, &
1441	ip_tag+2, ig_local_comm, istatus, ierror )
1442	iposbuf=0
1443	il_off=1
1444	il_len=myport(4,id_port)
1445	CALL MPI_Unpack(rl_work, myport(4,id_port)*4,iposbuf, &
1446	inp_fld(il_off:il_off+il_len-1), &
1447	il_len, MPI_REAL, ig_local_comm, ierror)
1448	IF (mpi_rank.eq.0) THEN
1449	call MPI_Wait(il_sndreq,istatus,ierror)
1450	ENDIF
1451	DEALLOCATE(rl_work)
1452	END SUBROUTINE read_file_parar4
1453
1454	! ********************************************************************
1455	! ********************************************************************
1456	! ********************************************************************
1457	!
1458	!* * READ_FILE_PARA * PRISM 1.0
1459	!
1460	! purpose:
1461	! --------
1462	! At first time step, reads input fields from binary files or
1463	! netcdf files.
1464	!
1465	! interface:
1466	! ----------
1467	! inp_fld : field to be read from the restart file
1468	! cd_port : symbolic name of the field
1469	! id_port : port number of the field
1470	!
1471	! lib mp:
1472	! -------
1473	! mpi-1
1474	!
1475	! author:
1476	! -------
1477	! Eric Sevault - METEO FRANCE
1478	! Laurent Terray - CERFACS
1479	! Jean Latour - F.S.E. (mpi-2)
1480	! Arnaud Caubel - Adaptation to PRISM interface
1481	! ----------------------------------------------------------------
1482	SUBROUTINE read_file_parar8(inp_fld, cd_port, id_port)
1483	! ----------------------------------------------------------------
1484	USE mod_kinds_model
1485	USE mod_prism_proto
1486	USE mod_comprism_proto
1487	IMPLICIT NONE
1488	#include <netcdf.inc>
1489	#include <mpif.h>
1490	! ----------------------------------------------------------------
1491	CHARACTER(len=8) :: cd_port
1492	INTEGER(kind=ip_intwp_p) :: id_port
1493	REAL(kind=ip_double_p) :: inp_fld(myport(4,id_port))
1494	! ----------------------------------------------------------------
1495	INTEGER(kind=ip_intwp_p),PARAMETER :: ip_tag=100
1496	INTEGER(kind=ip_intwp_p) il_unit, il_aux
1497	INTEGER(kind=ip_intwp_p) ierror, info, il_varid, il_ncid, il_status_ncdf
1498	INTEGER(kind=ip_intwp_p) il_maxgrd, il_maxbyte, ib, ib_aux, iposbuf, il_off, il_len
1499	INTEGER(kind=ip_intwp_p), DIMENSION(MPI_STATUS_SIZE) :: istatus
1500	INTEGER(kind=ip_intwp_p), DIMENSION(:,:), ALLOCATABLE :: il_paral_mast
1501	REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_start, rl_work
1502	REAL(kind=ip_double_p), DIMENSION(:), ALLOCATABLE :: rl_work_mast
1503	LOGICAL ll_file
1504	INTEGER(kind=ip_intwp_p)::il_sndreq
1505	! ----------------------------------------------------------------
1506	WRITE(nulprt,*)'Entering Read_File_Para '
1507	istatus(:)=0
1508	!
1509	!* Each process of local communicator sends his decomposition to master proc
1510	!
1511	CALL MPI_Send (mydist(:,id_port), CLIM_Parsize, MPI_INTEGER, 0, &
1512	ip_tag, ig_local_comm, ierror )
1513	CALL MPI_Send (myport(4,id_port), 1, MPI_INTEGER, 0, &
1514	ip_tag+1, ig_local_comm, ierror )
1515	!
1516	!* Master proc receives each process decomposition
1517	!
1518	IF (mpi_rank.eq.0) THEN
1519	il_maxgrd = 0
1520	ALLOCATE(il_paral_mast(CLIM_Parsize,kbcplproc(ig_mynummod)))
1521	il_paral_mast(:,:)=0
1522	DO ib = 0, kbcplproc(ig_mynummod)-1
1523	CALL MPI_Recv (il_paral_mast(:,ib+1), &
1524	CLIM_Parsize, MPI_INTEGER, ib, &
1525	ip_tag, ig_local_comm, istatus, ierror )
1526	CALL MPI_Recv (il_aux, 1, MPI_INTEGER, ib, &
1527	ip_tag+1, ig_local_comm, istatus, ierror )
1528	il_maxgrd = il_maxgrd + il_aux
1529	END DO
1530	il_maxbyte = il_maxgrd * 8
1531	ENDIF
1532	ALLOCATE(rl_work(myport(4,id_port)))
1533	rl_work(:)=0
1534	IF (mpi_rank.eq.0) THEN
1535	ALLOCATE (rl_start(il_maxgrd))
1536	ALLOCATE(rl_work_mast(il_maxgrd))
1537	rl_start(:)=0
1538	rl_work_mast(:)=0
1539	!
1540	!* Test if restart file is in NETCDF format or not
1541	!
1542	IF (lg_ncdfrst) THEN
1543	!
1544	!* Case NETCDF format
1545	!
1546	il_status_ncdf = NF_OPEN(cg_def_rstfile(id_port),NF_NOWRITE, &
1547	il_ncid)
1548	IF (il_status_ncdf.ne.NF_NOERR) THEN
1549	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1550	WRITE(nulprt,*)' stop in PRISM_get routine '
1551	STOP
1552	ENDIF
1553	il_status_ncdf = NF_INQ_VARID(il_ncid, cd_port, il_varid)
1554	IF (il_status_ncdf.ne.NF_NOERR) THEN
1555	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1556	WRITE(nulprt,*)' stop in PRISM_get routine '
1557	STOP
1558	ENDIF
1559	il_status_ncdf = NF_GET_VAR_DOUBLE (il_ncid, il_varid, rl_start)
1560	IF (il_status_ncdf.ne.NF_NOERR) THEN
1561	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1562	WRITE(nulprt,*)' stop in PRISM_put routine '
1563	STOP
1564	ENDIF
1565	il_status_ncdf = NF_CLOSE(il_ncid)
1566	IF (il_status_ncdf.ne.NF_NOERR) THEN
1567	WRITE(nulprt,*) NF_STRERROR(il_status_ncdf)
1568	WRITE(nulprt,*)' stop in PRISM_get routine '
1569	STOP
1570	ENDIF
1571	ELSE
1572	!
1573	!* Case binary format
1574	!
1575	il_unit = nulprt + 1
1576	INQUIRE (il_unit,OPENED = ll_file)
1577	DO WHILE (ll_file)
1578	il_unit = il_unit + 1
1579	INQUIRE (il_unit,OPENED = ll_file)
1580	END DO
1581	OPEN (il_unit, FILE=cg_def_rstfile(id_port),FORM='UNFORMATTED')
1582	CALL locreadr8(cd_port,rl_start,il_maxgrd,il_unit, &
1583	ierror, nulprt)
1584	!
1585	CLOSE (il_unit)
1586	ENDIF
1587	!
1588	!* Master proc sends to each proc his part of the field
1589	!
1590	DO ib = kbcplproc(ig_mynummod)- 1,0,-1
1591	iposbuf=0
1592	DO ib_aux=1,il_paral_mast(clim_segments,ib+1)
1593	il_off=il_paral_mast(clim_segments+2*ib_aux-1,ib+1)+1
1594	il_len=il_paral_mast(clim_segments+2*ib_aux,ib+1)
1595	call MPI_Pack(rl_start(il_off:il_off+il_len-1), &
1596	il_len,MPI_DOUBLE_PRECISION,rl_work_mast,il_maxbyte, &
1597	iposbuf, ig_local_comm, ierror)
1598	END DO
1599	IF(ib.GT.0) THEN
1600	CALL MPI_Send ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
1601	ip_tag+2, ig_local_comm, ierror )
1602	ELSE
1603	CALL MPI_ISend ( rl_work_mast, iposbuf, MPI_PACKED, ib, &
1604	ip_tag+2, ig_local_comm,il_sndreq, ierror )
1605	ENDIF
1606	ENDDO
1607	DEALLOCATE (il_paral_mast)
1608	DEALLOCATE (rl_work_mast)
1609	DEALLOCATE (rl_start)
1610	ENDIF
1611	!
1612	!* Each proc receives his part of the field
1613	!
1614	call MPI_Recv ( rl_work, myport(4,id_port)*8, MPI_PACKED, 0, &
1615	ip_tag+2, ig_local_comm, istatus, ierror )
1616	iposbuf=0
1617	il_off=1
1618	il_len=myport(4,id_port)
1619	CALL MPI_Unpack(rl_work, myport(4,id_port)*8,iposbuf, &
1620	inp_fld(il_off:il_off+il_len-1), &
1621	il_len, MPI_DOUBLE_PRECISION, ig_local_comm, ierror)
1622	IF (mpi_rank.eq.0) THEN
1623	call MPI_Wait(il_sndreq,istatus,ierror)
1624	ENDIF
1625	DEALLOCATE(rl_work)
1626	END SUBROUTINE read_file_parar8
1627
1628	!
1629	! ********************************************************************
1630	! ********************************************************************
1631	! ********************************************************************
1632	!
1633	SUBROUTINE locreadr4 ( cdfldn, pfield, kdimax, knulre, kflgre, kout)
1634	!
1635	!**** locread - Read binary field on unit knulre
1636	!
1637	! Purpose:
1638	! -------
1639	! Find string cdfldn on unit knulre and read array pfield
1640	!
1641	!** Interface:
1642	! ---------
1643	! CALL locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)
1644	!
1645	! Input:
1646	! -----
1647	! cdfldn : character string locator
1648	! kdimax : dimension of field to be read
1649	! knulre : logical unit to be read
1650	! kout : logical unit to write messages
1651	!
1652	! Output:
1653	! ------
1654	! pfield : field array (real 1D)
1655	! kflgre : error status flag
1656	!
1657	! Reference:
1658	! ---------
1659	! See OASIS manual (1995)
1660	!
1661	! History:
1662	! -------
1663	! Version Programmer Date Description
1664	! ------- ---------- ---- -----------
1665	! 2.0 L. Terray 95/09/01 created
1666	!
1667	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1668	!
1669	!
1670	!* ---------------------------- Argument declarations -------------------
1671	!
1672	USE mod_kinds_model
1673	INTEGER (kind=ip_intwp_p) kdimax, knulre, kflgre, kout
1674	REAL(kind=ip_single_p) :: pfield(kdimax)
1675	CHARACTER*8 cdfldn
1676	!
1677	!* ---------------------------- Local declarations ----------------------
1678	!
1679	CHARACTER*8 clecfl
1680	!
1681	!* ---------------------------- Poema verses ----------------------------
1682	!
1683	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1684	!
1685	!* 1. Initialization
1686	! --------------
1687	!
1688	WRITE (UNIT = kout,FMT = 1001) knulre
1689	!
1690	!* Formats
1691	!
1692	1001 FORMAT('Locread : Read binary file connected to unit = ',I4)
1693	!
1694	! 2. Find field in file
1695	! ------------------
1696	!
1697	REWIND knulre
1698	200 CONTINUE
1699	!* Find string
1700	READ (UNIT = knulre, ERR = 200, END = 210) clecfl
1701	IF (clecfl .NE. cdfldn) GO TO 200
1702	!* Read associated field
1703	READ (UNIT = knulre, ERR = 210, END = 210) pfield
1704	!* Reading done and ok
1705	kflgre = 0
1706	GO TO 220
1707	!* Problem in reading
1708	210 kflgre = 1
1709	220 CONTINUE
1710	!
1711	!
1712	!* 3. End of routine
1713	! --------------
1714	!
1715	WRITE (UNIT = kout,FMT = *) 'Locread : done'
1716	CALL FLUSH (kout)
1717	RETURN
1718	END SUBROUTINE locreadr4
1719
1720	!
1721	! ********************************************************************
1722	! ********************************************************************
1723	! ********************************************************************
1724	!
1725	SUBROUTINE locreadr8 ( cdfldn, pfield, kdimax, knulre, kflgre, kout)
1726	!
1727	!**** locread - Read binary field on unit knulre
1728	!
1729	! Purpose:
1730	! -------
1731	! Find string cdfldn on unit knulre and read array pfield
1732	!
1733	!** Interface:
1734	! ---------
1735	! CALL locread (cdfldn, pfield, kdimax, knulre, kflgre, kout)
1736	!
1737	! Input:
1738	! -----
1739	! cdfldn : character string locator
1740	! kdimax : dimension of field to be read
1741	! knulre : logical unit to be read
1742	! kout : logical unit to write messages
1743	!
1744	! Output:
1745	! ------
1746	! pfield : field array (real 1D)
1747	! kflgre : error status flag
1748	!
1749	! Reference:
1750	! ---------
1751	! See OASIS manual (1995)
1752	!
1753	! History:
1754	! -------
1755	! Version Programmer Date Description
1756	! ------- ---------- ---- -----------
1757	! 2.0 L. Terray 95/09/01 created
1758	!
1759	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1760	!
1761	!
1762	!* ---------------------------- Argument declarations -------------------
1763	!
1764	USE mod_kinds_model
1765	INTEGER(kind=ip_intwp_p) kdimax, knulre, kflgre, kout
1766	REAL(kind=ip_double_p) :: pfield(kdimax)
1767	CHARACTER*8 cdfldn
1768	!
1769	!* ---------------------------- Local declarations ----------------------
1770	!
1771	CHARACTER*8 clecfl
1772	!
1773	!* ---------------------------- Poema verses ----------------------------
1774	!
1775	! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1776	!
1777	!* 1. Initialization
1778	! --------------
1779	!
1780	WRITE (UNIT = kout,FMT = 1001) knulre
1781	!
1782	!* Formats
1783	!
1784	1001 FORMAT('Locread : Read binary file connected to unit = ',I4)
1785	!
1786	! 2. Find field in file
1787	! ------------------
1788	!
1789	REWIND knulre
1790	200 CONTINUE
1791	!* Find string
1792	READ (UNIT = knulre, ERR = 200, END = 210) clecfl
1793	IF (clecfl .NE. cdfldn) GO TO 200
1794	!* Read associated field
1795	READ (UNIT = knulre, ERR = 210, END = 210) pfield
1796	!* Reading done and ok
1797	kflgre = 0
1798	GO TO 220
1799	!* Problem in reading
1800	210 kflgre = 1
1801	220 CONTINUE
1802	!
1803	!
1804	!* 3. End of routine
1805	! --------------
1806	!
1807	WRITE (UNIT = kout,FMT = *) 'Locread : done'
1808	CALL FLUSH (kout)
1809	RETURN
1810	END SUBROUTINE locreadr8
1811
1812	END module mod_prism_get_proto

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

Context Navigation

source: CPL/oasis3/trunk/src/lib/psmile/src/mod_prism_get_proto.F90 @ 1677

Download in other formats: