File: C:\NOAA\NEMS_11731\src\chem\gocart\src\GMAO_Shared\GMAO_mpeu\m_ioutil.F90

1     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
3     !-----------------------------------------------------------------------
4     !BOP
5     !
6     ! !MODULE: m_ioutil - a F90 module for several convenient I/O functions
7     !
8     ! !DESCRIPTION:
9     !
10     !	m\_ioutil is a module containing several portable interfaces for
11     !	some highly system dependent, but frequently used I/O functions.
12     !
13     ! !INTERFACE:
14     
15     	module m_ioutil
16     	implicit none
17     	private	! except
18     
19     	public	:: opntext,clstext ! open/close a text file
20     	public	:: opnieee,clsieee ! open/close a binary sequential file
21     	public	:: luavail	   ! return a free logical unit
22     	public	:: luflush	   ! flush the buffer of a given unit
23     	public  :: byteswap	   ! swap bytes in an integer array.
24     	!public	:: MX_LU
25     
26     	interface byteswap; module procedure	&
27     	  swapI4_,	&
28     	  swapI8_; end interface
29     
30     ! !REVISION HISTORY:
31     !	20Dec2005 - Jing Guo <jguo@gmao.gsfc.nasa.gov>
32     !		  - merged changes between 1.1.2.6 and 1.1.2.8 to 1.2:
33     !		    added byteswap() and its interfaces.
34     ! 	16Jul96 - J. Guo	- (to do)
35     ! 	02Apr97 - Jing Guo <guo@eramus> - finished the coding
36     !	11Feb97 - Jing Guo <guo@thunder> - added luflush()
37     !EOP
38     !_______________________________________________________________________
39     
40     	character(len=*),parameter :: myname="m_ioutil"
41     	integer,parameter :: MX_LU=255
42     
43     contains
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     		! local parameter
89     	character(len=*),parameter :: myname_=myname//'::opnieee'
90     
91     	integer,parameter :: iA=ichar('a')
92     	integer,parameter :: mA=ichar('A')
93     	integer,parameter :: iZ=ichar('z')
94     
95     	logical :: direct
96     	character(len=16) :: clen
97     	character(len=len(status)) :: Ustat
98     	integer :: i,ic
99     
100     	direct=.false.
101     	if(present(recl)) then
102     	  if(recl<0) then
103     	    clen='****************'
104     	    write(clen,'(i16)',iostat=ier) recl
105     	    write(stderr,'(3a)') myname_,	&
106     		': invalid recl, ',trim(adjustl(clen))
107     	    ier=-1
108     	    return
109     	  endif
110     	  direct = recl>0
111     	endif
112     
113     #ifdef _UNICOS
114     	character(len=128) :: attr
115     
116     	call asnqunit(lu,attr,ier)	! test the unit
117     
118     	if(ier.eq.-1) then		! the unit is not used
119     	  if(direct) then
120     	    call asnunit(lu,'-N ieee -F null',ier)
121     	  else
122     	    call asnunit(lu,'-N ieee -F f77',ier)
123     	  endif
124     	  ier=0
125     
126     	elseif(ier.ge.0) then		! the unit is already assigned
127     	  ier=-1
128     	endif
129     	if(ier.ne.0) return
130     #endif
131     
132     	do i=1,len(status)
133     	  ic=ichar(status(i:i))
134     	  if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA)
135     	  Ustat(i:i)=char(ic)
136     	end do
137     
138     	select case(Ustat)
139     
140     	case ('APPEND')
141     
142     	  if(direct) then
143     	    write(stderr,'(2a)') myname_,		&
144     		': invalid arguments, (status=="APPEND",recl>0)'
145     	    ier=1
146     	    return
147     	  endif
148     
149     	  open(				&
150     	    unit	=lu,		&
151     	    file	=fname,		&
152     	    form	='unformatted',	&
153     	    access	='sequential',	&
154     	    status	='unknown',	&
155     	    position	='append',	&
156     	    iostat	=ier		)
157     
158     	case default
159     
160     	  if(direct) then
161     	    open(			&
162     	      unit	=lu,		&
163     	      file	=fname,		&
164     	      form	='unformatted',	&
165     	      access	='direct',	&
166     	      status	=status,	&
167     	      recl	=recl,		&
168     	      iostat	=ier		)
169     
170     	  else
171     	    open(			&
172     	      unit	=lu,		&
173     	      file	=fname,		&
174     	      form	='unformatted',	&
175     	      access	='sequential',	&
176     	      status	=status,	&
177     	      position	='asis',	&
178     	      iostat	=ier		)
179     	  endif
180     
181     	end select
182     
183     	end subroutine opnieee
184     !-----------------------------------------------------------------------
185     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
186     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
187     !-----------------------------------------------------------------------
188     !BOP
189     !
190     ! !IROUTINE: clsieee - Close a logical unit opened by opnieee()
191     !
192     ! !DESCRIPTION:
193     !
194     !	The reason for a paired clsieee() for opnieee() instead of a
195     !	simple close(), is for the portability reason.  For example,
196     !	under UNICOS, special system calls may be need to set up the
197     !	unit right, and the status of the unit should be restored upon
198     !	close.
199     !
200     ! !INTERFACE:
201     
202     	subroutine clsieee(lu,ier,status)
203     	  implicit none
204     	  integer,                    intent(in)  :: lu	   ! the unit used by opnieee()
205     	  integer,                    intent(out) :: ier	   ! the status
206               Character(len=*), optional, intent(In)  :: status ! keep/delete
207     
208     ! !REVISION HISTORY:
209     ! 	10Oct96 - J. Guo	- (to do)
210     !EOP
211     !_______________________________________________________________________
212               character(len=*), parameter :: myname_ = myname//'::clsieee'
213               Character(Len=6) :: status_
214     
215               status_ = 'KEEP'
216               If (Present(status)) Then
217                  Select Case (Trim(status))
218                  Case ('DELETE','delete')
219                     status_ = 'DELETE'
220                  Case  ('KEEP','keep')
221                     status_ = 'KEEP'
222                  Case Default
223                     ier = -997
224                     return
225                  End Select
226               End If
227                     
228     	  close(lu,iostat=ier,status=status_)
229     #ifdef _UNICOS
230     	  if(ier==0) call asnunit(lu,'-R',ier) ! remove attributes
231     #endif
232     
233     	end subroutine clsieee
234     
235     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
236     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
237     !-----------------------------------------------------------------------
238     !BOP
239     !
240     ! !IROUTINE: opntext - portablly open a text file
241     !
242     ! !DESCRIPTION:
243     !
244     !	Open a text (ASCII) file.  Under FORTRAN, it is defined as
245     !	"formatted" with "sequential" access.
246     !
247     ! !INTERFACE:
248     
249         subroutine opntext(lu,fname,status,ier)
250           implicit none
251     
252           integer,         intent(in) :: lu     ! logical unit number
253           character(len=*),intent(in) :: fname  ! filename to be opended
254           character(len=*),intent(in) :: status ! the value for STATUS=<>
255           integer,         intent(out):: ier    ! the status
256     
257     
258     ! !REVISION HISTORY:
259     !
260     !	02Feb95 - Jing G. - First version included in PSAS and libpsas.a
261     ! 	09Oct96 - J. Guo  - modified to allow assign() call under UNICOS
262     !			  = and now, it is a module in Fortran 90.
263     !EOP
264     !_______________________________________________________________________
265     
266     		! local parameter
267     	character(len=*),parameter :: myname_=myname//'::opntext'
268     
269     	integer,parameter :: iA=ichar('a')
270     	integer,parameter :: mA=ichar('A')
271     	integer,parameter :: iZ=ichar('z')
272     
273     	character(len=len(status)) :: Ustat
274     	integer :: i,ic
275     
276     #ifdef _UNICOS
277     	call asnunit(lu,'-R',ier)	! remove any set attributes
278     	if(ier.ne.0) return		! let the parent handle it
279     #endif
280     
281     	do i=1,len(status)
282     	  ic=ichar(status(i:i))
283     	  if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA)
284     	  Ustat(i:i)=char(ic)
285     	end do
286     
287     	select case(Ustat)
288     
289     	case ('APPEND')
290     
291     	  open(				&
292     	    unit	=lu,		&
293     	    file	=fname,		&
294     	    form	='formatted',	&
295     	    access	='sequential',	&
296     	    status	='unknown',	&
297     	    position	='append',	&
298     	    iostat	=ier		)
299     
300     	case default
301     
302     	  open(				&
303     	    unit	=lu,		&
304     	    file	=fname,		&
305     	    form	='formatted',	&
306     	    access	='sequential',	&
307     	    status	=status,	&
308     	    position	='asis',	&
309     	    iostat	=ier		)
310     
311     	end select
312     
313     	end subroutine opntext
314     
315     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
316     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
317     !-----------------------------------------------------------------------
318     !BOP
319     !
320     ! !IROUTINE: clstext - close a text file opend with an opntext() call
321     !
322     ! !DESCRIPTION:
323     !
324     ! !INTERFACE:
325     
326         subroutine clstext(lu,ier,status)
327           implicit none
328     
329           integer,                    intent(in)  :: lu     ! a logical unit to close
330           integer,                    intent(out) :: ier    ! the status
331           Character(len=*), optional, intent(In)  :: status ! keep/delete
332     
333     ! !REVISION HISTORY:
334     ! 	09Oct96 - J. Guo	- (to do)
335     !EOP
336     !_______________________________________________________________________
337               character(len=*), parameter :: myname_ = myname//'::clsitext'
338               Character(Len=6) :: status_
339     
340               status_ = 'KEEP'
341               If (Present(status)) Then
342                  Select Case (Trim(status))
343                  Case ('DELETE','delete')
344                     status_ = 'DELETE'
345                  Case  ('KEEP','keep')
346                     status_ = 'KEEP'
347                  Case Default
348                     ier = -997
349                     return
350                  End Select
351               End If
352     
353     	close(lu,iostat=ier,status=status_)
354     #ifdef _UNICOS
355     	if(ier == 0) call asnunit(lu,'-R',ier)	! remove any attributes
356     #endif
357     
358     	end subroutine clstext
359     
360     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
361     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
362     !BOP -------------------------------------------------------------------
363     !
364     ! !IROUTINE: luavail - locate the next available unit
365     !
366     ! !DESCRIPTION:
367     !
368     !    luavail() Look for an available (not opened and not statically
369     !    assigned to any I/O attributes to) logical unit.
370     !
371     ! !INTERFACE:
372     
373     	function luavail()
374     	  use m_stdio
375     	  implicit none
376     	  integer :: luavail	! result
377     
378     ! !REVISION HISTORY:
379     ! 	23Apr98 - Jing Guo <guo@thunder> - new prototype/prolog/code
380     !			- with additional unit constraints for SunOS.
381     !
382     ! 	: Jing Guo, [09-Oct-96]
383     ! 		+ Checking also Cray assign() attributes, with some
384     ! 		  changes to the code.  See also other routines.
385     !
386     ! 	: Jing Guo, [01-Apr-94]
387     ! 		+ Initial code.
388     !EOP ___________________________________________________________________
389     
390       character(len=*),parameter :: myname_=myname//'::luavail'
391     
392     	integer lu,ios
393     	logical inuse
394     	character*8 attr
395     
396     	lu=-1
397     	ios=0
398     	inuse=.true.
399     
400     	do while(ios.eq.0.and.inuse)
401     	  lu=lu+1
402     
403     		! Test #1, reserved
404     
405     	  inuse = lu.eq.stdout .or. lu.eq.stdin .or. lu.eq.stderr
406     
407     #ifdef sysSunOS
408     		! Reserved units under SunOS
409     	  inuse = lu.eq.100 .or. lu.eq.101 .or. lu.eq.102
410     #endif
411     
412     		! Test #2, in-use
413     
414     	  if(.not.inuse) inquire(unit=lu,opened=inuse,iostat=ios)
415     
416     #ifdef _UNICOS
417     		! Test #3, if the user has reserved the unit through
418     		! UNICOS' assign().
419     
420     	  if(ios.eq.0 .and. .not.inuse) then
421     	    call asnqunit(lu,attr,ios)
422     
423     		! see asnqunig(3f):
424     		!
425     		! ios ==  0, has been assigned to some attributes
426     		!        -1, not been assigned any attributes
427     		!     >   0, an error condition, but who cares why.
428     
429     	    inuse=ios.ne.-1		! the unit is in-use
430     	    if(ios >= -1) ios=0		! still a valid test
431     	  endif
432     #endif
433     
434     	  if(lu >= MX_LU) ios=-1
435     	end do
436     
437     	if(ios.ne.0) lu=-1
438     	luavail=lu
439     end function luavail
440     
441     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
443     !-----------------------------------------------------------------------
444     !BOP
445     !
446     ! !IROUTINE: luflush - a uniform interface of system flush()
447     !
448     ! !DESCRIPTION:
449     !
450     !	Flush() calls available on many systems are often implementation
451     !	dependent.  This subroutine provides a uniform interface.  It
452     !	also ignores invalid logical unit value.
453     !
454     ! !INTERFACE:
455     
456         subroutine luflush(unit)
457           use m_stdio, only : stdout
458           implicit none
459           integer,optional,intent(in) :: unit
460     
461     ! !REVISION HISTORY:
462     ! 	13Mar98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
463     !EOP
464     !_______________________________________________________________________
465       character(len=*),parameter :: myname_=myname//'::luflush'
466     
467       integer :: ier
468       integer :: lu
469     
470     	! Which logical unit number?
471     
472       lu=stdout
473       if(present(unit)) lu=unit
474       if(lu < 0) return
475     
476     	! The following call may be system dependent.
477     
478     #ifdef sysIRIX64
479       call flush(lu,ier)
480     #else
481     #if sysAIX 
482       call flush_(lu)      ! Function defined in xlf reference document.
483     #else
484       call flush(lu)
485     #endif
486     #endif
487     
488     end subroutine luflush
489     
490     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
492     !BOP -------------------------------------------------------------------
493     !
494     ! !IROUTINE: swapI4_ - swap INTEGER*4
495     !
496     ! !DESCRIPTION:
497     !
498     ! !INTERFACE:
499     
500         function swapI4_(ibuf)
501           use m_intkinds,only : I4 => kind_i4
502           implicit none
503           integer(I4),dimension(:),intent(in) :: ibuf
504           integer(I4),dimension(size(ibuf)) :: swapI4_
505     
506     ! !REVISION HISTORY:
507     ! 	15Apr02	- Jing Guo <guo@dao.gsfc.nasa.gov>
508     !		- initial prototype/prolog/code
509     !EOP ___________________________________________________________________
510     
511       character(len=*),parameter :: myname_=myname//'::swapI4_'
512     
513       	! TRANSFER() should be used.  The current implementation may be
514     	! not fully portable.
515     
516       call ioutil_byteswap_(size(ibuf),4,ibuf,swapI4_)
517     
518     end function swapI4_
519     
520     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
521     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
522     !BOP -------------------------------------------------------------------
523     !
524     ! !IROUTINE: swapI8_ - swap INTEGER*8
525     !
526     ! !DESCRIPTION:
527     !
528     ! !INTERFACE:
529     
530         function swapI8_(ibuf)
531           use m_intkinds,only : I8 => kind_i8
532           implicit none
533           integer(I8),dimension(:),intent(in) :: ibuf
534           integer(I8),dimension(size(ibuf)) :: swapI8_
535     
536     ! !REVISION HISTORY:
537     ! 	15Apr02	- Jing Guo <guo@dao.gsfc.nasa.gov>
538     !		- initial prototype/prolog/code
539     !EOP ___________________________________________________________________
540     
541       character(len=*),parameter :: myname_=myname//'::swapI8_'
542     
543       	! TRANSFER() should be used.  The current implementation may be
544     	! not fully portable.
545     
546       call ioutil_byteswap_(size(ibuf),8,ibuf,swapI8_)
547     
548     end function swapI8_
549     end module m_ioutil
550     
551     !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
552     !       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
553     !BOP -------------------------------------------------------------------
554     !
555     ! !IROUTINE: ioutil_byteswap_ - swap bytes in each word
556     !
557     ! !DESCRIPTION:
558     !
559     ! !INTERFACE:
560     
561         subroutine ioutil_byteswap_(nword,nbyte,ibuf,obuf)
562           implicit none
563           integer,intent(in) :: nword
564           integer,intent(in) :: nbyte
565           character(len=1),dimension(0:nbyte-1,nword),intent(in ) :: ibuf
566           character(len=1),dimension(0:nbyte-1,nword),intent(out) :: obuf
567     
568     ! !REVISION HISTORY:
569     ! 	15Apr02	- Jing Guo <guo@dao.gsfc.nasa.gov>
570     !		- initial prototype/prolog/code
571     !EOP ___________________________________________________________________
572     
573       character(len=*),parameter :: myname_='ioutil_byteswap_'
574       integer :: mbyte,ibyte,jbyte
575     
576       mbyte=nbyte-1
577       do ibyte=0,mbyte
578         jbyte=mbyte-ibyte
579         obuf(jbyte,:)=ibuf(ibyte,:)
580       end do
581     
582     end subroutine ioutil_byteswap_
583     !.
584