diff options
Diffstat (limited to 'Ganlib/src/KDROPN.f90')
| -rw-r--r-- | Ganlib/src/KDROPN.f90 | 311 |
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 |