summaryrefslogtreecommitdiff
path: root/Ganlib/src/OPNMOD.f90
diff options
context:
space:
mode:
Diffstat (limited to 'Ganlib/src/OPNMOD.f90')
-rw-r--r--Ganlib/src/OPNMOD.f90263
1 files changed, 263 insertions, 0 deletions
diff --git a/Ganlib/src/OPNMOD.f90 b/Ganlib/src/OPNMOD.f90
new file mode 100644
index 0000000..6c73a15
--- /dev/null
+++ b/Ganlib/src/OPNMOD.f90
@@ -0,0 +1,263 @@
+!
+!-----------------------------------------------------------------------
+!
+!Purpose:
+! Fortran-2003 bindings for fortran direct access in WIMS-AECL. Open,
+! read or close indexed random file using fortran direct access files
+! Subroutines:
+! OPNIND: open file and read master index
+! REDIND: read data on indexed file
+! CLSIND: close file
+!
+!Copyright:
+! Copyright (C) 2020 Ecole Polytechnique de Montreal
+! This library is free software; you can redistribute it and/or
+! modify it under the terms of the GNU Lesser General Public
+! License as published by the Free Software Foundation; either
+! version 2.1 of the License, or (at your option) any later version.
+!
+!Author(s): J. Donnelly
+!
+!Parameters: input/output
+! IUNIT read unit
+! INDEX index table (master index for OPNIND)
+! LINDEX length of index table (LINDEX >=(# of entries) + 1)
+! DATA data array to retreive from file
+! NWORDS lenght of data array to retreive from file
+! KEY location of data array in index
+!
+!Internal parameter description
+! IOUT output unit = 6
+! NBLOCKS number of blocks per record = 256
+! IOFSET offset for index length = 65536
+!
+!-----------------------------------------------------------------------
+!
+module OPNMOD
+ private
+ integer iunitr
+ public :: OPNIND, REDIND, CLSIND
+ interface REDIND
+ ! read data on indexed file
+ module procedure REDIND_I1, REDIND_R1
+ end interface
+contains
+ subroutine OPNIND(iunit,index,lindex)
+ parameter (iout=6,nblock=256,iofset=65536)
+ integer iunit,index(lindex),lindex
+ logical exst, opnd
+ character dirst*7
+ !----
+ ! unit number must be > zero
+ !----
+ if(iunit.le.0) then
+ write(iout,6000) iunit
+ call XABORT('OPNIND: (readonly) illegal unit number')
+ endif
+ !----
+ ! find out file status, and if unit already associated with
+ ! an open file
+ !----
+ inquire(unit=iunit,exist=exst,opened=opnd,direct=dirst)
+ if(.not.opnd) then
+ !----
+ ! file closed
+ !----
+ write(iout,6010) iunit
+ call XABORT('OPNIND: (readonly) file not opened')
+ endif
+ if( exst .and. dirst .eq. 'no' ) then
+ !----
+ ! file already exists, but is not direct access
+ !----
+ write(iout,6020) iunit
+ call XABORT('OPNIND: (readonly) file is nor direct access')
+ endif
+ if(.not.exst) then
+ !----
+ ! file does not exists
+ !----
+ write(iout,6030) iunit
+ call XABORT('OPNIND: (readonly) file does not exists ')
+ endif
+ !----
+ ! process the file master index
+ !----
+ iunitr=iunit
+ irec = 1
+ minw = 1
+ 40 continue
+ maxw = min0( minw + nblock - 1 , lindex )
+ ierr=0
+ read(iunit,rec=irec,iostat=ierr) (index(i),i=minw,maxw)
+ if(ierr.ne.0) then
+ write(iout,6040) iunit,ierr
+ call XABORT('OPNIND: read master record error')
+ endif
+ irec = irec + 1
+ if( maxw .ne. lindex ) then
+ minw = maxw + 1
+ go to 40
+ endif
+ return
+ !----
+ ! format
+ !----
+ 6000 format(' //// OPNIND: file, ',i5,' invalid')
+ 6010 format(' //// OPNIND: file, ',i5,' has not been opened with KDROPN')
+ 6020 format(' //// OPNIND: unit ',i5,' is not a direct access file')
+ 6030 format(' //// OPNIND: unit ',i5,' does not exists (readonly version)')
+ 6040 format(' //// OPNIND: error during reading of master index ', &
+ 'of unit ',i5,' status = ',i5)
+ end subroutine OPNIND
+ !----
+ subroutine CLSIND(iunit)
+ parameter (iout=6)
+ integer iunit
+ if(iunitr.ne.iunit) then
+ write(iout,6100) iunit
+ call XABORT('CLSIND: file not opened by OPNIND')
+ endif
+ iunitr=kdrcls(iunit,1)
+ if(iunitr.ne.0) then
+ write(iout,6110) iunitr
+ call XABORT('CLSIND: error in file closing')
+ endif
+ return
+ !----
+ ! format
+ !----
+ 6100 format(' //// CLSIND: unit ',i5,' not found')
+ 6110 format(' //// CLSIND: error status =',i5,' from kdrcls')
+ end subroutine CLSIND
+ !----
+ subroutine REDIND_I1(iunit,index,lindex,data,nwords,key)
+ parameter (iout=6,nblock=256,iofset=65536)
+ integer iunit,index(lindex),lindex,nwords,key
+ integer data(nwords)
+ !
+ if(iunitr.ne.iunit) then
+ write(iout,6200) iunit
+ call XABORT('REDIND_I1: file not opened by OPNIND')
+ endif
+ !----
+ ! validate key number
+ !----
+ if(key.le.0.or.key.ge.lindex) then
+ write(iout,6210) iunit, key
+ call XABORT('REDIND_I1: invalid key')
+ endif
+ !----
+ ! key number valid, validate record number
+ !----
+ indr=index(key+1)
+ if(indr.eq.0) then
+ write(iout,6220) iunit, key
+ call XABORT('REDIND_I1: invalid record number for key')
+ endif
+ !----
+ ! validate record length
+ !----
+ lrecrd = (nwords-1)/nblock + 1
+ loldrc = indr/iofset
+ if(loldrc.lt.lrecrd) then
+ write(iout,6230) iunit, key
+ call XABORT('REDIND_I1: invalid record length')
+ endif
+ !----
+ ! record found, read the data
+ !----
+ nrec = mod( indr, iofset )
+ minw = 1
+ 50 continue
+ maxw = min0( minw + nblock - 1 , nwords )
+ ierr=0
+ read(iunit,rec=nrec,iostat=ierr) (data(i),i=minw,maxw)
+ if(ierr.ne.0) then
+ write(iout,6240) iunit,ierr
+ call XABORT('REDIND_I1: read record error')
+ endif
+ nrec = nrec + 1
+ if( maxw .ne. nwords ) then
+ minw = maxw + 1
+ go to 50
+ endif
+ return
+ !----
+ ! format
+ !----
+ 6200 format(' //// REDIND_I1: unit ',i5,' not found')
+ 6210 format(' //// REDIND_I1: invalid record number, unit ',i5,' key= ',i10)
+ 6220 format(' //// REDIND_I1: non-existant record, unit ',i5, &
+ ' record key =',i10)
+ 6230 format(' //// REDIND_I1: data count exceeds record, unit ',i5, &
+ ' record key =',i10)
+ 6240 format(' //// REDIND_I1: error during reading of record ', &
+ 'of unit ',i5,' status = ',i5)
+ end subroutine REDIND_I1
+ !----
+ subroutine REDIND_R1(iunit,index,lindex,data,nwords,key)
+ parameter (iout=6,nblock=256,iofset=65536)
+ integer iunit,index(lindex),lindex,nwords,key
+ real data(nwords)
+ !
+ if(iunitr.ne.iunit) then
+ write(iout,6200) iunit
+ call XABORT('REDIND_R1: file not opened by OPNIND')
+ endif
+ !----
+ ! validate key number
+ !----
+ if(key.le.0.or.key.ge.lindex) then
+ write(iout,6210) iunit, key
+ call XABORT('REDIND_R1: invalid key')
+ endif
+ !----
+ ! key number valid, validate record number
+ !----
+ indr=index(key+1)
+ if(indr.eq.0) then
+ write(iout,6220) iunit, key
+ call XABORT('REDIND_R1: invalid record number for key')
+ endif
+ !----
+ ! validate record length
+ !----
+ lrecrd = (nwords-1)/nblock + 1
+ loldrc = indr/iofset
+ if(loldrc.lt.lrecrd) then
+ write(iout,6230) iunit, key
+ call XABORT('REDIND_R1: invalid record length')
+ endif
+ !----
+ ! record found, read the data
+ !----
+ nrec = mod( indr, iofset )
+ minw = 1
+ 50 continue
+ maxw = min0( minw + nblock - 1 , nwords )
+ ierr=0
+ read(iunit,rec=nrec,iostat=ierr) (data(i),i=minw,maxw)
+ if(ierr.ne.0) then
+ write(iout,6240) iunit,ierr
+ call XABORT('REDIND_R1: read record error')
+ endif
+ nrec = nrec + 1
+ if( maxw .ne. nwords ) then
+ minw = maxw + 1
+ go to 50
+ endif
+ return
+ !----
+ ! format
+ !----
+ 6200 format(' //// REDIND_R1: unit ',i5,' not found')
+ 6210 format(' //// REDIND_R1: invalid record number, unit ',i5,' key= ',i10)
+ 6220 format(' //// REDIND_R1: non-existant record, unit ',i5, &
+ ' record key =',i10)
+ 6230 format(' //// REDIND_R1: data count exceeds record, unit ',i5, &
+ ' record key =',i10)
+ 6240 format(' //// REDIND_R1: error during reading of record ', &
+ 'of unit ',i5,' status = ',i5)
+ end subroutine REDIND_R1
+end module OPNMOD
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:16:41 +0000