Initial commit from Polytechnique Montreal

1 files changed, 311 insertions, 0 deletions

diff --git a/Ganlib/src/KDROPN.f90 b/Ganlib/src/KDROPN.f90
new file mode 100644
index 0000000..126f1b2
--- /dev/null
+++ b/Ganlib/src/KDROPN.f90
@@ -0,0 +1,311 @@
+!
+!---------------------------  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
+!----
+   if(luname < 8) go to 120
+   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
+   120 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