!
!---------------------------  KDROPN  ----------------------------------
!
! 1- programme statistics:
!     name     : KDROPN, KDRCLS
!     use      : allocate and release file units associated to a given
!                file name. word addressable (KDI), sequential (formatted
!                or not) and direct access (DA) files are permitted
!     modified : 91-01-24
!     author   : G. Marleau and A. Hebert
!
! 2- routine parameters:
!
! - function KDROPN(cuname,iactio,iutype,lrda)
!
!   open file and allocate unit number. allocate unit number to file
!   name if unit is already opened, returns unit number.
!
!   input
!     cuname   : filename                                     c*12
!                if cuname=' ', use a default name
!     iactio   : action on file                               i
!                =0 to allocate a new file
!                =1 to access and modify an existing file
!                =2 to access an existing file in
!                   read-only mode
!                =3 unknown
!     iutype   : file type                                    i
!                =1  KDI word addressable file
!                =2  sequential unformatted
!                =3  sequential formatted
!                =4  direct access (DA) unformatted file
!     ldra     : number of words in DA record                 i
!                required for  iutype = 4 only
!   output
!     KDROPN   : unit number/error status                     type(c_ptr)
!                address of file (successful allocation)
!                == NULL  allocation failure
!
!   error codes:
!                = -1  no more unit available
!                = -2  file type requested inconsistent with file type of this file
!                = -3  this file has been already opened
!                = -4  file name is reserved or too long (FT06F00, FT07F00)
!                = -5  illegal file type 1 < iutype < 4
!                = -6  (not used)
!                = -7  error on open of unformatted sequential file
!                = -8  error on open of formatted sequential file
!                = -9  error on open of direct access file
!                =-10  invalid number of word in direct access record
!                      lrda must be > 0
!
!---------------------------  KDROPN  ----------------------------------
!
integer function KDROPN(cuname,iactio,iutype,lrda)
!----
!   subroutine arguments
!----
   character(len=*) :: cuname
   integer :: iactio,iutype,lrda
!----
!   local variables
!----
   integer :: ret_val=0
   integer, parameter :: nbtape=99,nreser=2,ndummy=4
   character :: crdnam*72,cform*11,cstatu*12
   integer :: itapno
   logical :: lfilop
   character(len=8),save,dimension(ndummy) :: cdummy= &
      (/ 'DUMMYKDI','DUMMYSQ ','DUMMYCA ','DUMMYIN ' /)
   character(len=8),save,dimension(nreser) :: creser= &
      (/ 'FT05F001','FT06F001' /)
   character(len=22),save,dimension(ndummy) :: ctype= &
      (/ 'WORD ADDRESSABLE KDI  ','SEQUENTIAL UNFORMATTED', &
         'SEQUENTIAL CHARACTER  ','DIRECT ACCESS DA      ' /)
!----
!  check if iutype is valid
!----
   if((iutype > 4).or.(iutype <= 1)) then
      ret_val=-5
      go to 6000
   endif
!----
!  check if lrda is valid
!----
   if((iutype == 4).and.(lrda < 1)) then
      ret_val=-10
      go to 6000
   endif
!----
!  check if file name is more than 72 characters
!----
   luname= len(cuname)
   if(luname > 72) then
      ret_val=-4
      go to 6000
   endif
!----
!  check if file name not forbidden
!----
   do ireser=1,nreser
      if(cuname(:8) == creser(ireser)) then
         ret_val=-4
         go to 6000
      endif
   enddo
!----
!  check for dummy file name/allocate dummy file name if requested
!----
   do idummy=1,ndummy
      if(cuname(:8) == cdummy(idummy)) then
         if(idummy /= iutype) then
            ret_val=-2
            go to 6000
         endif
      endif
   enddo
   if(cuname == ' ') then
      crdnam=cdummy(iutype)
   else
      crdnam=cuname
   endif
!----
!  check if file opened/permitted
!----
   inquire(file=crdnam,opened=lfilop)
   if(lfilop) then
      ret_val = -3
      go to 6000
   endif
!----
!  look for never allocated unit location
!----
   do jboucl=nbtape,1,-1
      itapno=jboucl
      inquire(unit=itapno,opened=lfilop)
      if(.not.lfilop) go to 121
   enddo
!----
!  error - no unit number available
!----
   ret_val = -1
   go to 6000
!
   121 if(iutype == 2) then
!----
!  open sequential unformatted file
!----
      ret_val=-7
      cform='UNFORMATTED'
   else if(iutype == 3) then
!----
!  open sequential formatted file
!----
      ret_val=-8
      cform='FORMATTED'
   else if(iutype == 4) then
!----
!  open DA file
!----
      ret_val=-9
      cform='UNFORMATTED'
   endif
   if(iactio == 0) then
      cstatu='NEW'
   else if(iactio == 1) then
      cstatu='OLD'
   else if(iactio == 2) then
      cstatu='OLD'
   else
      cstatu='UNKNOWN'
   endif
   if((iutype == 4).and.(iactio == 2)) then
      idummy=0
      inquire(iolength=lrecl) (idummy,i=1,lrda)
      open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, &
      access='DIRECT',recl=lrecl,status=cstatu,action='READ')
   else if(iutype == 4) then
      idummy=0
      inquire(iolength=lrecl) (idummy,i=1,lrda)
      open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, &
      access='DIRECT',recl=lrecl,status=cstatu)
   else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 0)) then
      open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, &
      access='SEQUENTIAL',status=cstatu)
   else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 1)) then
      open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, &
      access='SEQUENTIAL',position='APPEND',status=cstatu)
   else if(((iutype == 2).or.(iutype == 3)).and.(iactio == 2)) then
      open(unit=itapno,file=crdnam,err=7000,iostat=iercod,form=cform, &
      access='SEQUENTIAL',status=cstatu,action='READ')
      rewind(itapno)
   endif
   KDROPN=itapno
   return
   6000 write(6,8000) crdnam,ctype(iutype),ret_val
   KDROPN=ret_val
   return
   7000 write(6,9000) crdnam,ctype(iutype),ret_val,iercod
   KDROPN=ret_val
   return
!----
!  error format
!----
   8000 format('1',5x,'ERROR IN OPENING OF FILE IN KDROPN'/ &
               6x,'FILE NAME = ',a/6x,'FILE TYPE = ',a22/ &
               6x,'ERROR CODE= ',i7)
   9000 format('1',5x,'ERROR IN OPENING OF FILE IN KDROPN'/ &
               6x,'FILE NAME = ',a/6x,'FILE TYPE = ',a22/ &
               6x,'ERROR CODE= ',i7,'   IERCOD = ',i7)
end function KDROPN
!
!-------------------------- KDRCLS -------------------------------------
!
! - function KDRCLS(itapno,iactio)
!
!   close file and release unit number.
!
!   input
!     itapno   : unit number                                  i
!                = 0    close all units
!                > 0    unit to close
!     iactio   : action on file                               i
!                = 1    to keep the file;
!                = 2    to delete the file.
!   output
!     KDRCLS   : error status                                 i
!                =  0  unit closed
!                = -2  file not opened
!                = -3  this file has been opened by routines other than KDROPN
!                = -4  file unit is reserved (5,6)
!                = -5  illegal unit number
!                = -6  (not used)
!                = -7  error on close of unformatted sequential file
!                = -8  error on close of formatted sequential file
!                = -9  error on close of DA file
!                =-10  invalid close action (iactio=1,2 permitted only)
!                =-11  type of file not supported
!
!-------------------------- KDRCLS -------------------------------------
!
integer function KDRCLS(itapno,iactio)
!----
!   subroutine arguments
!----
   integer :: itapno,iactio
!----
!   local variables
!----
   integer, parameter :: ndummy=4
   character(len=10) :: acc
   character(len=11) :: frm
   character(len=22),save,dimension(ndummy) :: ctype= &
    (/ '                      ','SEQUENTIAL UNFORMATTED', 'SEQUENTIAL CHARACTER  ', &
       'DIRECT ACCESS DA      ' /)
!
   integer, parameter :: nbtape=99
   integer :: ret_val=0,itapet=0
   logical :: lfilop,lnmd
   character (len=72) :: cuname
!----
!  invalid unit number
!----
   if((itapno <= 0).or.(itapno > nbtape)) then
      ret_val=-5
      go to 7000
   endif
   inquire(unit=itapno,opened=lfilop,named=lnmd)
   if((.not.lfilop).or.(.not.lnmd)) then
      ret_val=-2
      go to 7000
   endif
!----
!  close the file
!----
   inquire(unit=itapno,access=acc,form=frm)
   if((acc == 'SEQUENTIAL').and.(frm == 'UNFORMATTED')) then
      itapet=2
      ret_val=-7
   else if((acc == 'SEQUENTIAL').and.(frm == 'FORMATTED')) then
      itapet=3
      ret_val=-8
   else if((acc == 'DIRECT').and.(frm == 'UNFORMATTED')) then
      itapet=4
      ret_val=-9
   else
      ret_val=-11
      go to 7000
   endif
   if(iactio == 1) then
       close(itapno,iostat=iercod,status='KEEP',err=7000)
   else if(iactio == 2) then
       close(itapno,iostat=iercod,status='DELETE',err=7000)
   else
      ret_val=-10
      go to 7000
   endif
   KDRCLS=0
   return
   7000 inquire(unit=itapno,name=cuname)
   write(6,9000) itapno,cuname,ctype(itapet),ret_val,iercod
   KDRCLS=ret_val
   return
!----
!  error format
!----
   9000 format('1',5x,'ERROR IN CLOSE OF FILE IN KDROPN'/ &
        6x,'UNIT NB.  = ',i10/6x,'FILE NAME = ',a7/6x,'FILE TYPE = ',a22/ &
        6x,'ERROR CODE= ',i7,'   IERCOD = ',i7)
end function KDRCLS
