!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !MODULE: m_ioutil - a F90 module for several convenient I/O functions ! ! !DESCRIPTION: ! ! m\_ioutil is a module containing several portable interfaces for ! some highly system dependent, but frequently used I/O functions. ! ! !INTERFACE: module m_ioutil implicit none private ! except public :: opntext,clstext ! open/close a text file public :: opnieee,clsieee ! open/close a binary sequential file public :: luavail ! return a free logical unit public :: luflush ! flush the buffer of a given unit !public :: MX_LU ! !REVISION HISTORY: ! 16Jul96 - J. Guo - (to do) ! 02Apr97 - Jing Guo - finished the coding ! 11Feb97 - Jing Guo - added luflush() !EOP !_______________________________________________________________________ character(len=*),parameter :: myname="m_ioutil" integer,parameter :: MX_LU=255 contains !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: opnieee - portablly open an IEEE format file ! ! !DESCRIPTION: ! ! Open a file in `IEEE' format. ! ! `IEEE' format is refered as a FORTRAN "unformatted" file with ! "sequantial" access and variable record lengths. Under common ! Unix, it is only a file with records packed with a leading 4- ! byte word and a trailing 4-byte word indicating the size of ! the record in bytes. However, under UNICOS, it is also assumed ! to have numerical data representations represented according to ! the IEEE standard corresponding KIND conversions. Under a DEC ! machine, it means that compilations of the source code should ! have the "-bigendian" option specified. ! ! !INTERFACE: subroutine opnieee(lu,fname,status,ier,recl) use m_stdio,only : stderr implicit none integer, intent(in) :: lu ! logical unit number character(len=*),intent(in) :: fname ! filename to be opended character(len=*),intent(in) :: status ! the value for STATUS= integer, intent(out):: ier ! the status integer,optional,intent(in) :: recl ! record length ! !REVISION HISTORY: ! 02Feb95 - Jing G. - First version included in PSAS. It is not ! used in the libpsas.a calls, since no binary data input/ ! output is to be handled. ! ! 09Oct96 - J. Guo - Check for any previous assign() call under ! UNICOS. !EOP !_______________________________________________________________________ ! local parameter character(len=*),parameter :: myname_=myname//'::opnieee' integer,parameter :: iA=ichar('a') integer,parameter :: mA=ichar('A') integer,parameter :: iZ=ichar('z') logical :: direct character(len=16) :: clen character(len=len(status)) :: Ustat integer :: i,ic direct=.false. if(present(recl)) then if(recl<0) then clen='****************' write(clen,'(i16)',iostat=ier) recl write(stderr,'(3a)') myname_, & ': invalid recl, ',trim(adjustl(clen)) ier=-1 return endif direct = recl>0 endif #ifdef _UNICOS character(len=128) :: attr call asnqunit(lu,attr,ier) ! test the unit if(ier.eq.-1) then ! the unit is not used if(direct) then call asnunit(lu,'-N ieee -F null',ier) else call asnunit(lu,'-N ieee -F f77',ier) endif ier=0 elseif(ier.ge.0) then ! the unit is already assigned ier=-1 endif if(ier.ne.0) return #endif do i=1,len(status) ic=ichar(status(i:i)) if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA) Ustat(i:i)=char(ic) end do select case(Ustat) case ('APPEND') if(direct) then write(stderr,'(2a)') myname_, & ': invalid arguments, (status=="APPEND",recl>0)' ier=1 return endif open( & unit =lu, & file =fname, & form ='unformatted', & access ='sequential', & status ='unknown', & position ='append', & iostat =ier ) case default if(direct) then open( & unit =lu, & file =fname, & form ='unformatted', & access ='direct', & status =status, & recl =recl, & iostat =ier ) else open( & unit =lu, & file =fname, & form ='unformatted', & access ='sequential', & status =status, & position ='asis', & iostat =ier ) endif end select end subroutine opnieee !----------------------------------------------------------------------- !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: clsieee - Close a logical unit opened by opnieee() ! ! !DESCRIPTION: ! ! The reason for a paired clsieee() for opnieee() instead of a ! simple close(), is for the portability reason. For example, ! under UNICOS, special system calls may be need to set up the ! unit right, and the status of the unit should be restored upon ! close. ! ! !INTERFACE: subroutine clsieee(lu,ier,status) implicit none integer, intent(in) :: lu ! the unit used by opnieee() integer, intent(out) :: ier ! the status Character(len=*), optional, intent(In) :: status ! keep/delete ! !REVISION HISTORY: ! 10Oct96 - J. Guo - (to do) !EOP !_______________________________________________________________________ character(len=*), parameter :: myname_ = myname//'::clsieee' Character(Len=6) :: status_ status_ = 'KEEP' If (Present(status)) Then Select Case (Trim(status)) Case ('DELETE','delete') status_ = 'DELETE' Case ('KEEP','keep') status_ = 'KEEP' Case Default ier = -997 return End Select End If close(lu,iostat=ier,status=status_) #ifdef _UNICOS if(ier==0) call asnunit(lu,'-R',ier) ! remove attributes #endif end subroutine clsieee !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: opntext - portablly open a text file ! ! !DESCRIPTION: ! ! Open a text (ASCII) file. Under FORTRAN, it is defined as ! "formatted" with "sequential" access. ! ! !INTERFACE: subroutine opntext(lu,fname,status,ier) implicit none integer, intent(in) :: lu ! logical unit number character(len=*),intent(in) :: fname ! filename to be opended character(len=*),intent(in) :: status ! the value for STATUS=<> integer, intent(out):: ier ! the status ! !REVISION HISTORY: ! ! 02Feb95 - Jing G. - First version included in PSAS and libpsas.a ! 09Oct96 - J. Guo - modified to allow assign() call under UNICOS ! = and now, it is a module in Fortran 90. !EOP !_______________________________________________________________________ ! local parameter character(len=*),parameter :: myname_=myname//'::opntext' integer,parameter :: iA=ichar('a') integer,parameter :: mA=ichar('A') integer,parameter :: iZ=ichar('z') character(len=len(status)) :: Ustat integer :: i,ic #ifdef _UNICOS call asnunit(lu,'-R',ier) ! remove any set attributes if(ier.ne.0) return ! let the parent handle it #endif do i=1,len(status) ic=ichar(status(i:i)) if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA) Ustat(i:i)=char(ic) end do select case(Ustat) case ('APPEND') open( & unit =lu, & file =fname, & form ='formatted', & access ='sequential', & status ='unknown', & position ='append', & iostat =ier ) case default open( & unit =lu, & file =fname, & form ='formatted', & access ='sequential', & status =status, & position ='asis', & iostat =ier ) end select end subroutine opntext !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: clstext - close a text file opend with an opntext() call ! ! !DESCRIPTION: ! ! !INTERFACE: subroutine clstext(lu,ier,status) implicit none integer, intent(in) :: lu ! a logical unit to close integer, intent(out) :: ier ! the status Character(len=*), optional, intent(In) :: status ! keep/delete ! !REVISION HISTORY: ! 09Oct96 - J. Guo - (to do) !EOP !_______________________________________________________________________ character(len=*), parameter :: myname_ = myname//'::clsitext' Character(Len=6) :: status_ status_ = 'KEEP' If (Present(status)) Then Select Case (Trim(status)) Case ('DELETE','delete') status_ = 'DELETE' Case ('KEEP','keep') status_ = 'KEEP' Case Default ier = -997 return End Select End If close(lu,iostat=ier,status=status_) #ifdef _UNICOS if(ier == 0) call asnunit(lu,'-R',ier) ! remove any attributes #endif end subroutine clstext !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !BOP ------------------------------------------------------------------- ! ! !IROUTINE: luavail - locate the next available unit ! ! !DESCRIPTION: ! ! luavail() Look for an available (not opened and not statically ! assigned to any I/O attributes to) logical unit. ! ! !INTERFACE: function luavail() use m_stdio implicit none integer :: luavail ! result ! !REVISION HISTORY: ! 23Apr98 - Jing Guo - new prototype/prolog/code ! - with additional unit constraints for SunOS. ! ! : Jing Guo, [09-Oct-96] ! + Checking also Cray assign() attributes, with some ! changes to the code. See also other routines. ! ! : Jing Guo, [01-Apr-94] ! + Initial code. !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::luavail' integer lu,ios logical inuse character*8 attr lu=-1 ios=0 inuse=.true. do while(ios.eq.0.and.inuse) lu=lu+1 ! Test #1, reserved inuse = lu.eq.stdout .or. lu.eq.stdin .or. lu.eq.stderr #ifdef sysSunOS ! Reserved units under SunOS inuse = lu.eq.100 .or. lu.eq.101 .or. lu.eq.102 #endif ! Test #2, in-use if(.not.inuse) inquire(unit=lu,opened=inuse,iostat=ios) #ifdef _UNICOS ! Test #3, if the user has reserved the unit through ! UNICOS' assign(). if(ios.eq.0 .and. .not.inuse) then call asnqunit(lu,attr,ios) ! see asnqunig(3f): ! ! ios == 0, has been assigned to some attributes ! -1, not been assigned any attributes ! > 0, an error condition, but who cares why. inuse=ios.ne.-1 ! the unit is in-use if(ios >= -1) ios=0 ! still a valid test endif #endif if(lu >= MX_LU) ios=-1 end do if(ios.ne.0) lu=-1 luavail=lu end function luavail !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: luflush - a uniform interface of system flush() ! ! !DESCRIPTION: ! ! Flush() calls available on many systems are often implementation ! dependent. This subroutine provides a uniform interface. It ! also ignores invalid logical unit value. ! ! !INTERFACE: subroutine luflush(unit) use m_stdio, only : stdout implicit none integer,optional,intent(in) :: unit ! !REVISION HISTORY: ! 13Mar98 - Jing Guo - initial prototype/prolog/code !EOP !_______________________________________________________________________ character(len=*),parameter :: myname_=myname//'::luflush' integer :: ier integer :: lu ! Which logical unit number? lu=stdout if(present(unit)) lu=unit if(lu < 0) return ! The following call may be system dependent. #ifdef sysIRIX64 call flush(lu,ier) #else #if sysAIX call flush_(lu) ! Function defined in xlf reference document. #else call flush(lu) #endif #endif end subroutine luflush !----------------------------------------------------------------------- end module m_ioutil !.