source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/mct/mpeu/m_ioutil.F90 @ 4775

Last change on this file since 4775 was 4775, checked in by aclsce, 5 years ago
  • Imported oasis3-mct from Cerfacs svn server (not suppotred anymore).

The version has been extracted from ​https://oasis3mct.cerfacs.fr/svn/branches/OASIS3-MCT_2.0_branch/oasis3-mct@1818
File size: 11.7 KB
Line 
1!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
3!-----------------------------------------------------------------------
4! CVS m_ioutil.F90,v 1.16 2006-07-06 22:06:25 jacob Exp
5! CVS MCT_2_8_0 
6!-----------------------------------------------------------------------
7!BOP
8!
9! !MODULE: m_ioutil - a F90 module for several convenient I/O functions
10!
11! !DESCRIPTION:
12!
13!       m\_ioutil is a module containing several portable interfaces for
14!       some highly system dependent, but frequently used I/O functions.
15!
16! !INTERFACE:
17
18        module m_ioutil
19        implicit none
20        private ! except
21
22        public  :: opntext,clstext ! open/close a text file
23        public  :: opnieee,clsieee ! open/close a binary sequential file
24        public  :: luavail         ! return a free logical unit
25        public  :: luflush         ! flush the buffer of a given unit
26        !public :: MX_LU
27
28! !REVISION HISTORY:
29!       16Jul96 - J. Guo        - (to do)
30!       02Apr97 - Jing Guo <guo@eramus> - finished the coding
31!       11Feb97 - Jing Guo <guo@thunder> - added luflush()
32!       08Nov01  - Jace A Mogill <mogill@cray.com>  FORTRAN only defines
33!                 99 units, three units below unit 10 are often used for
34!                 stdin, stdout, and stderr.  Be far more conservative
35!                 and stay within FORTRAN standard.
36!
37!EOP
38!_______________________________________________________________________
39
40        character(len=*),parameter :: myname="MCT(MPEU)::m_ioutil"
41        integer,parameter :: MX_LU=99
42
43contains
44
45!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
46!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
47!-----------------------------------------------------------------------
48!BOP
49!
50! !IROUTINE: opnieee - portablly open an IEEE format file
51!
52! !DESCRIPTION:
53!
54!       Open a file in IEEE format.
55!
56!       IEEE format is refered as a FORTRAN "unformatted" file with
57!       "sequantial" access and variable record lengths.  Under common
58!       Unix, it is only a file with records packed with a leading 4-
59!       byte word and a trailing 4-byte word indicating the size of
60!       the record in bytes.  However, under UNICOS, it is also assumed
61!       to have numerical data representations represented according to
62!       the IEEE standard corresponding KIND conversions.  Under a DEC
63!       machine, it means that compilations of the source code should
64!       have the "-bigendian" option specified.
65!
66! !INTERFACE:
67
68    subroutine opnieee(lu,fname,status,ier,recl)
69      use m_stdio,only : stderr
70      implicit none
71
72      integer,         intent(in) :: lu     ! logical unit number
73      character(len=*),intent(in) :: fname  ! filename to be opended
74      character(len=*),intent(in) :: status ! the value for STATUS=
75      integer,         intent(out):: ier    ! the status
76      integer,optional,intent(in) :: recl   ! record length
77
78! !REVISION HISTORY:
79!       02Feb95 - Jing G. - First version included in PSAS.  It is not
80!               used in the libpsas.a calls, since no binary data input/
81!               output is to be handled.
82!
83!       09Oct96 - J. Guo  - Check for any previous assign() call under
84!               UNICOS.
85!EOP
86!_______________________________________________________________________
87
88#ifdef _UNICOS
89        character(len=128) :: attr
90#endif
91
92                ! local parameter
93        character(len=*),parameter :: myname_=myname//'::opnieee'
94
95        integer,parameter :: iA=ichar('a')
96        integer,parameter :: mA=ichar('A')
97        integer,parameter :: iZ=ichar('z')
98
99        logical :: direct
100        character(len=16) :: clen
101        character(len=len(status)) :: Ustat
102        integer :: i,ic
103
104! Work-around for absoft 9.0 f90, which has trouble understanding that
105! ier is an output argument from the write() call below.
106
107        ier = 0
108
109        direct=.false.
110        if(present(recl)) then
111          if(recl<0) then
112            clen='****************'
113            write(clen,'(i16)',iostat=ier) recl
114            write(stderr,'(3a)') myname_,       &
115                ': invalid recl, ',trim(adjustl(clen))
116            ier=-1
117            return
118          endif
119          direct = recl>0
120        endif
121
122#ifdef _UNICOS
123        call asnqunit(lu,attr,ier)      ! test the unit
124
125        if(ier.eq.-1) then              ! the unit is not used
126          if(direct) then
127            call asnunit(lu,'-N ieee -F null',ier)
128          else
129            call asnunit(lu,'-N ieee -F f77',ier)
130          endif
131          ier=0
132
133        elseif(ier.ge.0) then           ! the unit is already assigned
134          ier=-1
135        endif
136        if(ier.ne.0) return
137#endif
138
139        do i=1,len(status)
140          ic=ichar(status(i:i))
141          if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA)
142          Ustat(i:i)=char(ic)
143        end do
144
145        select case(Ustat)
146
147        case ('APPEND')
148
149          if(direct) then
150            write(stderr,'(2a)') myname_,               &
151                ': invalid arguments, (status=="APPEND",recl>0)'
152            ier=1
153            return
154          endif
155
156          open(                         &
157            unit        =lu,            &
158            file        =fname,         &
159            form        ='unformatted', &
160            access      ='sequential',  &
161            status      ='unknown',     &
162            position    ='append',      &
163            iostat      =ier            )
164
165        case default
166
167          if(direct) then
168            open(                       &
169              unit      =lu,            &
170              file      =fname,         &
171              form      ='unformatted', &
172              access    ='direct',      &
173              status    =status,        &
174              recl      =recl,          &
175              iostat    =ier            )
176
177          else
178            open(                       &
179              unit      =lu,            &
180              file      =fname,         &
181              form      ='unformatted', &
182              access    ='sequential',  &
183              status    =status,        &
184              position  ='asis',        &
185              iostat    =ier            )
186          endif
187
188        end select
189
190        end subroutine opnieee
191!-----------------------------------------------------------------------
192!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
193!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
194!-----------------------------------------------------------------------
195!BOP
196!
197! !IROUTINE: clsieee - Close a logical unit opened by opnieee()
198!
199! !DESCRIPTION:
200!
201!       The reason for a paired clsieee() for opnieee() instead of a
202!       simple close(), is for the portability reason.  For example,
203!       under UNICOS, special system calls may be need to set up the
204!       unit right, and the status of the unit should be restored upon
205!       close.
206!
207! !INTERFACE:
208
209        subroutine clsieee(lu,ier)
210          implicit none
211          integer, intent(in)  :: lu    ! the unit used by opnieee()
212          integer, intent(out) :: ier   ! the status
213
214! !REVISION HISTORY:
215!       10Oct96 - J. Guo        - (to do)
216!EOP
217!_______________________________________________________________________
218          close(lu,iostat=ier)
219#ifdef _UNICOS
220          if(ier==0) call asnunit(lu,'-R',ier) ! remove attributes
221#endif
222
223        end subroutine clsieee
224
225!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
226!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
227!-----------------------------------------------------------------------
228!BOP
229!
230! !IROUTINE: opntext - portablly open a text file
231!
232! !DESCRIPTION:
233!
234!       Open a text (ASCII) file.  Under FORTRAN, it is defined as
235!       "formatted" with "sequential" access.
236!
237! !INTERFACE:
238
239    subroutine opntext(lu,fname,status,ier)
240      implicit none
241
242      integer,         intent(in) :: lu     ! logical unit number
243      character(len=*),intent(in) :: fname  ! filename to be opended
244      character(len=*),intent(in) :: status ! the value for STATUS=<>
245      integer,         intent(out):: ier    ! the status
246
247
248! !REVISION HISTORY:
249!
250!       02Feb95 - Jing G. - First version included in PSAS and libpsas.a
251!       09Oct96 - J. Guo  - modified to allow assign() call under UNICOS
252!                         = and now, it is a module in Fortran 90.
253!EOP
254!_______________________________________________________________________
255
256                ! local parameter
257        character(len=*),parameter :: myname_=myname//'::opntext'
258
259        integer,parameter :: iA=ichar('a')
260        integer,parameter :: mA=ichar('A')
261        integer,parameter :: iZ=ichar('z')
262
263        character(len=len(status)) :: Ustat
264        integer :: i,ic
265
266#ifdef _UNICOS
267        call asnunit(lu,'-R',ier)       ! remove any set attributes
268        if(ier.ne.0) return             ! let the parent handle it
269#endif
270
271        do i=1,len(status)
272          ic=ichar(status(i:i))
273          if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA)
274          Ustat(i:i)=char(ic)
275        end do
276
277        select case(Ustat)
278
279        case ('APPEND')
280
281          open(                         &
282            unit        =lu,            &
283            file        =fname,         &
284            form        ='formatted',   &
285            access      ='sequential',  &
286            status      ='unknown',     &
287            position    ='append',      &
288            iostat      =ier            )
289
290        case default
291
292          open(                         &
293            unit        =lu,            &
294            file        =fname,         &
295            form        ='formatted',   &
296            access      ='sequential',  &
297            status      =status,        &
298            position    ='asis',        &
299            iostat      =ier            )
300
301        end select
302
303        end subroutine opntext
304
305!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
306!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
307!-----------------------------------------------------------------------
308!BOP
309!
310! !IROUTINE: clstext - close a text file opend with an opntext() call
311!
312! !DESCRIPTION:
313!
314! !INTERFACE:
315
316    subroutine clstext(lu,ier)
317      implicit none
318
319      integer, intent(in)  :: lu  ! a logical unit to close
320      integer, intent(out) :: ier ! the status
321
322! !REVISION HISTORY:
323!       09Oct96 - J. Guo        - (to do)
324!EOP
325!_______________________________________________________________________
326
327        close(lu,iostat=ier)
328#ifdef _UNICOS
329        if(ier == 0) call asnunit(lu,'-R',ier)  ! remove any attributes
330#endif
331
332        end subroutine clstext
333
334!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
336!BOP -------------------------------------------------------------------
337!
338! !IROUTINE: luavail - locate the next available unit
339!
340! !DESCRIPTION:
341!
342!    luavail() Look for an available (not opened and not statically
343!    assigned to any I/O attributes to) logical unit.
344!
345! !INTERFACE:
346
347        function luavail()
348          use m_stdio
349          implicit none
350          integer :: luavail    ! result
351
352! !REVISION HISTORY:
353!       23Apr98 - Jing Guo <guo@thunder> - new prototype/prolog/code
354!                       - with additional unit constraints for SunOS.
355!
356!       : Jing Guo, [09-Oct-96]
357!               + Checking also Cray assign() attributes, with some
358!                 changes to the code.  See also other routines.
359!
360!       : Jing Guo, [01-Apr-94]
361!               + Initial code.
362!   2001-11-08  - Jace A Mogill <mogill@cray.com>  clean up
363!                 logic for finding lu.
364!
365!EOP ___________________________________________________________________
366
367  character(len=*),parameter :: myname_=myname//'::luavail'
368
369        integer lu,ios
370        logical inuse
371
372        lu=10
373        ios=0
374        inuse=.true.
375
376        do while(ios.eq.0 .and. inuse .and. lu.le.MX_LU)
377          lu=lu+1
378          inquire(unit=lu,opened=inuse,iostat=ios)
379        end do
380
381        if(ios.ne.0) lu=-1
382        luavail=lu
383end function luavail
384
385!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
387!-----------------------------------------------------------------------
388!BOP
389!
390! !IROUTINE: luflush - a uniform interface of system flush()
391!
392! !DESCRIPTION:
393!
394!       Flush() calls available on many systems are often implementation
395!       dependent.  This subroutine provides a uniform interface.  It
396!       also ignores invalid logical unit value.
397!
398! !INTERFACE:
399
400    subroutine luflush(unit)
401      use m_stdio, only : stdout
402#ifdef CPRNAG
403      use F90_UNIX_IO,only : flush
404#endif
405      implicit none
406      integer,optional,intent(in) :: unit
407
408! !REVISION HISTORY:
409!       13Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
410!       08Jul02 - E. Ong <eong@mcs.anl.gov> - added flush support for nag95
411!  2001-11-08  Jace A Mogill <mogill@cray.com>  - Flush is not part of
412!              the F90 standard.  Default is NO unit flush.
413!EOP
414!_______________________________________________________________________
415  character(len=*),parameter :: myname_=myname//'::luflush'
416
417  integer :: ier
418  integer :: lu
419
420        ! Which logical unit number?
421
422  lu=stdout
423  if(present(unit)) lu=unit
424  if(lu < 0) return
425
426        ! The following call may be system dependent.
427
428#if SYSIRIX64 || CPRNAG || SYSUNICOS
429  call flush(lu,ier)
430#elif  SYSAIX || CPRXLF
431  call flush_(lu)      ! Function defined in xlf reference document.
432#elif SYSLINUX || SYSOSF1 || SYSSUNOS || SYST3E || SYSUNIXSYSTEMV || SYSSUPERUX
433  call flush(lu)
434#endif
435
436end subroutine luflush
437!-----------------------------------------------------------------------
438end module m_ioutil
439!.
Note: See TracBrowser for help on using the repository browser.