baciof.f90

Go to the documentation of this file.

 
 
MODULE bacio_module
 
  INTEGER,PARAMETER :: fddim = 9999
 
  INTEGER,DIMENSION(FDDIM),SAVE:: fd = fddim*0
 
  INTEGER,DIMENSION(20),SAVE:: baopts = 0
 
  INTEGER,PARAMETER:: bacio_openr = 1
  INTEGER,PARAMETER:: bacio_openw = 2
  INTEGER,PARAMETER:: bacio_openrw = 4
  INTEGER,PARAMETER:: bacio_close = 8
  INTEGER,PARAMETER:: bacio_read = 16
  INTEGER,PARAMETER:: bacio_write = 32
  INTEGER,PARAMETER:: bacio_noseek = 64
  INTEGER,PARAMETER:: bacio_openwt = 128
  INTEGER,PARAMETER:: bacio_openwa = 256
 
  interface
 
     integer function baciol(mode, start, size, no, nactual, &
          fdes, fname, datary) bind(C)
       use, intrinsic :: iso_c_binding
       integer(c_int), value, intent(in) :: mode
       integer(c_long), value, intent(in) :: start
       integer(c_int), value, intent(in) :: size
       integer(c_long), value, intent(in) :: no
       integer(c_long), intent(inout) :: nactual
       integer(c_int), intent(inout) :: fdes
       character(kind=C_char), intent(in) :: fname(*)
       character(kind=C_char), intent(in) :: datary(*)
     end function baciol
  end interface
END MODULE bacio_module
 
SUBROUTINE baseto(NOPT, VOPT)
  USE bacio_module
  IMPLICIT NONE
  INTEGER NOPT, VOPT
 
  IF (nopt .GE. 1 .AND. nopt .LE. 20) baopts(nopt) = vopt
END SUBROUTINE baseto
 
SUBROUTINE baopen(LU, CFN, IRET)
  USE bacio_module
  use iso_c_binding, only: c_null_char  
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  CHARACTER, intent(in) :: CFN*(*)
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB, NB, KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_openrw, ib, 1, nb, ka, fd(lu), &
       trim(cfn)//c_null_char, a)
END SUBROUTINE baopen
 
SUBROUTINE baopenr(LU, CFN, IRET)
  USE bacio_module
  use iso_c_binding, only: c_null_char    
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  CHARACTER, intent(in) :: CFN*(*)
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB, NB, KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_openr, ib, 1, nb, ka, fd(lu), &
       trim(cfn)//c_null_char, a)
END SUBROUTINE baopenr
 
SUBROUTINE baopenw(LU, CFN, IRET)
  USE bacio_module
  use iso_c_binding, only: c_null_char    
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  CHARACTER, intent(in) :: CFN*(*)
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB, NB, KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_openw, ib, 1, nb, ka, fd(lu), &
       trim(cfn)//c_null_char, a)
END SUBROUTINE baopenw
 
SUBROUTINE baopenwt(LU, CFN, IRET)
  USE bacio_module
  use iso_c_binding, only: c_null_char    
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  CHARACTER, intent(in) :: CFN*(*)
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB, NB, KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_openwt, ib, 1, nb, ka, fd(lu), &
       trim(cfn)//c_null_char, a)
END SUBROUTINE baopenwt
 
SUBROUTINE baopenwa(LU, CFN, IRET)
  USE bacio_module
  use iso_c_binding, only: c_null_char    
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  CHARACTER, intent(in) :: CFN*(*)
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB,JB,NB,KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_openwa, ib, 1, nb, ka, fd(lu), &
       trim(cfn)//c_null_char, a)
END SUBROUTINE baopenwa
 
SUBROUTINE baclose(LU, IRET)
  USE bacio_module
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  INTEGER, intent(out) :: IRET
  integer(kind=8) IB, NB, KA
  CHARACTER :: A(1)
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     iret = 6
     RETURN
  ENDIF
 
  iret = baciol(bacio_close, ib, 1, nb, ka, fd(lu), char(0), a)
  IF (iret .EQ. 0) fd(lu) = 0
END SUBROUTINE baclose
 
SUBROUTINE baread(LU, IB, NB, KA, A)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: LU, IB, NB
  INTEGER,INTENT(OUT) :: KA
  CHARACTER,INTENT(OUT) :: A(NB)
  INTEGER(KIND=8) :: LONG_IB, LONG_NB, LONG_KA
 
  if (nb < 0) THEN
     print *,'WRONG: in BAREAD read data size NB < 0, STOP! '//&
          'Consider using BAREADL and long integer'
     ka = 0
     return
  ENDIF
  long_ib = ib
  long_nb = nb
  CALL bareadl(lu, long_ib, long_nb, long_ka, a)
  ka = int(long_ka)
END SUBROUTINE baread
 
SUBROUTINE bareadl(LU, IB, NB, KA, A)
  USE bacio_module
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  INTEGER(kind=8), intent(in) :: IB,NB
  INTEGER(kind=8), intent(out) :: KA
  CHARACTER, intent(out) :: A(NB)
  integer(kind=8), PARAMETER :: NY=4096, my=4
  INTEGER(KIND=8) NS(MY), NN(MY)
  INTEGER(kind=8) LONG_0, KY, I, K, IY, JY, LUX
  INTEGER IRET
  CHARACTER Y(NY, MY)
  DATA lux/0/
  SAVE jy, ns, nn, y, lux
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     ka = 0
     RETURN
  ENDIF
  IF (fd(lu) .LE. 0) THEN
     ka = 0
     RETURN
  ENDIF
  IF (ib .LT. 0 .AND. baopts(1) .EQ. 1) THEN
     ka = 0
     RETURN
  ENDIF
  IF (nb .LE. 0) THEN
     ka = 0
     RETURN
  ENDIF
 
  long_0 = 0
 
  !  UNBUFFERED I/O
  IF (baopts(1) .NE. 1) THEN
     ka = 0
     IF (ib .GE. 0) THEN
        iret = baciol(bacio_read, ib, 1, nb, ka, fd(lu), char(0), a)
     ELSE
        iret = baciol(bacio_read + bacio_noseek, long_0, 1, nb, ka,&
             fd(lu), char(0), a)
     ENDIF
 
     !  BUFFERED I/O
     !  GET DATA FROM PREVIOUS CALL IF POSSIBLE
  ELSE
     ka = 0
     IF (lux .NE. lu) THEN
        jy = 0
        ns = 0
        nn = 0
     ELSE
        DO i = 1, my
           iy = mod(jy + i - 1, my) + 1
           ky = ib + ka - ns(iy)
           IF (ka .LT. nb .AND. ky .GE. long_0 .AND. ky .LT. nn(iy)) THEN
              k = min(nb - ka, nn(iy) - ky)
              a(ka + 1:ka + k) = y(ky + 1:ky + k, iy)
              ka = ka + k
           ENDIF
        ENDDO
     ENDIF
 
     !  SET POSITION AND READ BUFFER AND GET DATA
     IF (ka .LT. nb) THEN
        lux = abs(lu)
        jy = mod(jy, my)+1
        ns(jy) = ib+ka
        iret = baciol(bacio_read, ns(jy), 1, ny, nn(jy), &
             fd(lux), char(0), y(1, jy))
        IF (nn(jy).GT.0) THEN
           k = min(nb-ka, nn(jy))
           a(ka+1:ka+k) = y(1:k, jy)
           ka = ka+k
        ENDIF
 
        !  CONTINUE TO READ BUFFER AND GET DATA
        DO WHILE(nn(jy).EQ.ny.AND.ka.LT.nb)
           jy = mod(jy, my)+1
           ns(jy) = ns(jy)+nn(jy)
           iret = baciol(bacio_read+bacio_noseek, ns(jy), 1, ny, nn(jy), &
                fd(lux), char(0), y(1, jy))
           IF (nn(jy).GT.0) THEN
              k = min(nb-ka, nn(jy))
              a(ka+1:ka+k) = y(1:k, jy)
              ka = ka+k
           ENDIF
        ENDDO
     ENDIF
  ENDIF
END SUBROUTINE bareadl
 
SUBROUTINE bawrite(LU, IB, NB, KA, A)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: LU, IB, NB
  INTEGER, INTENT(OUT) :: KA
  CHARACTER, INTENT(IN) :: A(NB)
  INTEGER(KIND = 8) :: LONG_IB, LONG_NB, LONG_KA
 
  if (nb < 0) THEN
     print *, 'WRONG: in BAWRITE read data size NB <0,  STOP! '//&
          'Consider using BAWRITEL and long integer'
     ka = 0
     return
  ENDIF
 
  long_ib = ib
  long_nb = nb
  CALL bawritel(lu, long_ib, long_nb, long_ka, a)
  ka = int(long_ka)
END SUBROUTINE bawrite
 
SUBROUTINE bawritel(LU, IB, NB, KA, A)
  USE bacio_module
  IMPLICIT NONE
  INTEGER, intent(in)         :: LU
  INTEGER(kind = 8), intent(in) :: IB, NB
  INTEGER(kind = 8), intent(out):: KA
  CHARACTER, intent(in) ::  A(NB)
  INTEGER(kind = 8) :: LONG_0
  INTEGER :: IRET
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     ka = 0
     RETURN
  ENDIF
  IF (fd(lu) .LE. 0) THEN
     ka = 0
     RETURN
  ENDIF
  IF (nb .LE. 0) THEN
     ka = 0
     RETURN
  ENDIF
 
  long_0 = 0
 
  IF (ib .GE. 0) THEN
     ka = 0
     iret = baciol(bacio_write, ib, 1, nb, ka, fd(lu), char(0), a)
  ELSE
     ka = 0
     iret = baciol(bacio_write+bacio_noseek, long_0, 1, nb, ka, &
          fd(lu), char(0), a)
  ENDIF
END SUBROUTINE  bawritel
 
 
SUBROUTINE wryte(LU, NB, A)
  USE bacio_module
  IMPLICIT NONE
 
  INTEGER, intent(in) :: LU
  INTEGER, intent(in) :: NB
  CHARACTER, intent(in) ::  A(NB)
  INTEGER(kind = 8) :: LONG_NB
 
  IF (nb < 0) THEN
     print *, 'WRONG: NB: the number of bytes to write  <0, STOP!'
     RETURN
  ENDIF
  long_nb = nb
  CALL wrytel(lu, long_nb, a)
END SUBROUTINE wryte
 
 
SUBROUTINE wrytel(LU, NB, A)
  USE bacio_module
  IMPLICIT NONE
  INTEGER, intent(in) :: LU
  INTEGER(kind = 8), intent(in) :: NB
  CHARACTER, INTENT(in)       :: A(NB)
  INTEGER(kind = 8) :: LONG_0, KA
  INTEGER :: IRET
 
  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
     ka = 0
     RETURN
  ENDIF
  IF (fd(lu) .LE. 0) THEN
     RETURN
  ENDIF
  IF (nb .LE. 0) THEN
     RETURN
  ENDIF
 
  long_0 = 0
  ka = 0
  iret = baciol(bacio_write + bacio_noseek, long_0, 1, nb, ka, &
       fd(lu), char(0), a)
  RETURN
END SUBROUTINE wrytel