NCEPLIBS-bacio  2.6.0
baciof.F90
Go to the documentation of this file.
1 
4 
10 MODULE bacio_module
11 
13  INTEGER,PARAMETER :: fddim = 9999
14 
16  INTEGER,DIMENSION(FDDIM),SAVE:: fd = fddim*0
17 
20  INTEGER,DIMENSION(20),SAVE:: baopts = 0
21 
22  INTEGER,PARAMETER:: bacio_openr = 1
23  INTEGER,PARAMETER:: bacio_openw = 2
24  INTEGER,PARAMETER:: bacio_openrw = 4
25  INTEGER,PARAMETER:: bacio_close = 8
26  INTEGER,PARAMETER:: bacio_read = 16
27  INTEGER,PARAMETER:: bacio_write = 32
28  INTEGER,PARAMETER:: bacio_noseek = 64
29  INTEGER,PARAMETER:: bacio_openwt = 128
30  INTEGER,PARAMETER:: bacio_openwa = 256
31 
32  interface
33 
46  function baciol(mode, start, size, no, nactual, &
47  fdes, fname, datary) bind(C)
48  use, intrinsic :: iso_c_binding
49  integer(c_int), value, intent(in) :: mode
50  integer(c_long), value, intent(in) :: start
51  integer(c_int), value, intent(in) :: size
52  integer(c_long), value, intent(in) :: no
53  integer(c_long), intent(inout) :: nactual
54  integer(c_int), intent(inout) :: fdes
55  character(kind=C_char), intent(in) :: fname(*)
56  character(kind=C_char), intent(in) :: datary(*)
57  integer(c_int) :: baciol
58  end function baciol
59  end interface
60 END MODULE bacio_module
61 
78 SUBROUTINE baseto(NOPT, VOPT)
79  USE bacio_module
80  IMPLICIT NONE
81  INTEGER NOPT, VOPT
82 
83  IF (nopt .GE. 1 .AND. nopt .LE. 20) baopts(nopt) = vopt
84 END SUBROUTINE baseto
85 
107 SUBROUTINE baopen(LU, CFN, IRET)
108  USE bacio_module
109  use iso_c_binding, only: c_null_char
110  IMPLICIT NONE
111  INTEGER, intent(in) :: LU
112  CHARACTER, intent(in) :: CFN*(*)
113  INTEGER, intent(out) :: IRET
114  integer(kind=8) IB, NB, KA
115  CHARACTER :: A(1)
116 
117  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
118  iret = 6
119  RETURN
120  ENDIF
121 
122  ib = 0
123  nb = 0
124  iret = baciol(bacio_openrw, ib, 1, nb, ka, fd(lu), &
125  trim(cfn)//c_null_char, a)
126 END SUBROUTINE baopen
127 
149 SUBROUTINE baopenr(LU, CFN, IRET)
150  USE bacio_module
151  use iso_c_binding, only: c_null_char
152  IMPLICIT NONE
153  INTEGER, intent(in) :: LU
154  CHARACTER, intent(in) :: CFN*(*)
155  INTEGER, intent(out) :: IRET
156  integer(kind=8) IB, NB, KA
157  CHARACTER :: A(1)
158 
159  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
160  iret = 6
161  RETURN
162  ENDIF
163 
164  ib = 0
165  nb = 0
166  iret = baciol(bacio_openr, ib, 1, nb, ka, fd(lu), &
167  trim(cfn)//c_null_char, a)
168 END SUBROUTINE baopenr
169 
191 SUBROUTINE baopenw(LU, CFN, IRET)
192  USE bacio_module
193  use iso_c_binding, only: c_null_char
194  IMPLICIT NONE
195  INTEGER, intent(in) :: LU
196  CHARACTER, intent(in) :: CFN*(*)
197  INTEGER, intent(out) :: IRET
198  integer(kind=8) IB, NB, KA
199  CHARACTER :: A(1)
200 
201  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
202  iret = 6
203  RETURN
204  ENDIF
205 
206  ib = 0
207  nb = 0
208  iret = baciol(bacio_openw, ib, 1, nb, ka, fd(lu), &
209  trim(cfn)//c_null_char, a)
210 END SUBROUTINE baopenw
211 
233 SUBROUTINE baopenwt(LU, CFN, IRET)
234  USE bacio_module
235  use iso_c_binding, only: c_null_char
236  IMPLICIT NONE
237  INTEGER, intent(in) :: LU
238  CHARACTER, intent(in) :: CFN*(*)
239  INTEGER, intent(out) :: IRET
240  integer(kind=8) IB, NB, KA
241  CHARACTER :: A(1)
242 
243  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
244  iret = 6
245  RETURN
246  ENDIF
247 
248  ib = 0
249  nb = 0
250  iret = baciol(bacio_openwt, ib, 1, nb, ka, fd(lu), &
251  trim(cfn)//c_null_char, a)
252 END SUBROUTINE baopenwt
253 
275 SUBROUTINE baopenwa(LU, CFN, IRET)
276  USE bacio_module
277  use iso_c_binding, only: c_null_char
278  IMPLICIT NONE
279  INTEGER, intent(in) :: LU
280  CHARACTER, intent(in) :: CFN*(*)
281  INTEGER, intent(out) :: IRET
282  integer(kind=8) IB,NB,KA
283  CHARACTER :: A(1)
284 
285  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
286  iret = 6
287  RETURN
288  ENDIF
289 
290  ib = 0
291  nb = 0
292  iret = baciol(bacio_openwa, ib, 1, nb, ka, fd(lu), &
293  trim(cfn)//c_null_char, a)
294 END SUBROUTINE baopenwa
295 
315 SUBROUTINE baclose(LU, IRET)
316  USE bacio_module
317  IMPLICIT NONE
318  INTEGER, intent(in) :: LU
319  INTEGER, intent(out) :: IRET
320  integer(kind=8) IB, NB, KA
321  CHARACTER :: A(1)
322 
323  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
324  iret = 6
325  RETURN
326  ENDIF
327 
328  ib = 0
329  nb = 0
330  iret = baciol(bacio_close, ib, 1, nb, ka, fd(lu), char(0), a)
331  IF (iret .EQ. 0) fd(lu) = 0
332 END SUBROUTINE baclose
333 
357 SUBROUTINE baread(LU, IB, NB, KA, A)
358  IMPLICIT NONE
359  INTEGER,INTENT(IN) :: LU, IB, NB
360  INTEGER,INTENT(OUT) :: KA
361  CHARACTER,INTENT(OUT) :: A(NB)
362  INTEGER(KIND=8) :: LONG_IB, LONG_NB, LONG_KA
363 
364  if (nb < 0) THEN
365  print *,'WRONG: in BAREAD read data size NB < 0, STOP! '//&
366  'Consider using BAREADL and long integer'
367  ka = 0
368  return
369  ENDIF
370  long_ib = ib
371  long_nb = nb
372  CALL bareadl(lu, long_ib, long_nb, long_ka, a)
373  ka = int(long_ka)
374 END SUBROUTINE baread
375 
400 SUBROUTINE bareadl(LU, IB, NB, KA, A)
401  USE bacio_module
402  IMPLICIT NONE
403  INTEGER, intent(in) :: LU
404  INTEGER(kind=8), intent(in) :: IB,NB
405  INTEGER(kind=8), intent(out) :: KA
406  CHARACTER, intent(out) :: A(NB)
407  integer(kind=8), PARAMETER :: NY=4096, my=4
408  INTEGER(KIND=8) NS(MY), NN(MY)
409  INTEGER(kind=8) LONG_0, KY, I, K, IY, JY, LUX
410  INTEGER IRET
411  CHARACTER Y(NY, MY)
412  DATA lux/0/
413  SAVE jy, ns, nn, y, lux
414 
415  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
416  ka = 0
417  RETURN
418  ENDIF
419  IF (fd(lu) .LE. 0) THEN
420  ka = 0
421  RETURN
422  ENDIF
423  IF (ib .LT. 0 .AND. baopts(1) .EQ. 1) THEN
424  ka = 0
425  RETURN
426  ENDIF
427  IF (nb .LE. 0) THEN
428  ka = 0
429  RETURN
430  ENDIF
431 
432  long_0 = 0
433 
434  ! UNBUFFERED I/O
435  IF (baopts(1) .NE. 1) THEN
436  ka = 0
437  IF (ib .GE. 0) THEN
438  iret = baciol(bacio_read, ib, 1, nb, ka, fd(lu), char(0), a)
439  ELSE
440  iret = baciol(bacio_read + bacio_noseek, long_0, 1, nb, ka,&
441  fd(lu), char(0), a)
442  ENDIF
443 
444  ! BUFFERED I/O
445  ! GET DATA FROM PREVIOUS CALL IF POSSIBLE
446  ELSE
447  ka = 0
448  IF (lux .NE. lu) THEN
449  jy = 0
450  ns = 0
451  nn = 0
452  ELSE
453  DO i = 1, my
454  iy = mod(jy + i - 1, my) + 1
455  ky = ib + ka - ns(iy)
456  IF (ka .LT. nb .AND. ky .GE. long_0 .AND. ky .LT. nn(iy)) THEN
457  k = min(nb - ka, nn(iy) - ky)
458  a(ka + 1:ka + k) = y(ky + 1:ky + k, iy)
459  ka = ka + k
460  ENDIF
461  ENDDO
462  ENDIF
463 
464  ! SET POSITION AND READ BUFFER AND GET DATA
465  IF (ka .LT. nb) THEN
466  lux = abs(lu)
467  jy = mod(jy, my)+1
468  ns(jy) = ib+ka
469  iret = baciol(bacio_read, ns(jy), 1, ny, nn(jy), &
470  fd(lux), char(0), y(1, jy))
471  IF (nn(jy).GT.0) THEN
472  k = min(nb-ka, nn(jy))
473  a(ka+1:ka+k) = y(1:k, jy)
474  ka = ka+k
475  ENDIF
476 
477  ! CONTINUE TO READ BUFFER AND GET DATA
478  DO WHILE(nn(jy).EQ.ny.AND.ka.LT.nb)
479  jy = mod(jy, my)+1
480  ns(jy) = ns(jy)+nn(jy)
481  iret = baciol(bacio_read+bacio_noseek, ns(jy), 1, ny, nn(jy), &
482  fd(lux), char(0), y(1, jy))
483  IF (nn(jy).GT.0) THEN
484  k = min(nb-ka, nn(jy))
485  a(ka+1:ka+k) = y(1:k, jy)
486  ka = ka+k
487  ENDIF
488  ENDDO
489  ENDIF
490  ENDIF
491 END SUBROUTINE bareadl
492 
505 SUBROUTINE bawrite(LU, IB, NB, KA, A)
506  IMPLICIT NONE
507  INTEGER, INTENT(IN) :: LU, IB, NB
508  INTEGER, INTENT(OUT) :: KA
509  CHARACTER, INTENT(IN) :: A(NB)
510  INTEGER(KIND = 8) :: LONG_IB, LONG_NB, LONG_KA
511 
512  if (nb < 0) THEN
513  print *, 'WRONG: in BAWRITE read data size NB <0, STOP! '//&
514  'Consider using BAWRITEL and long integer'
515  ka = 0
516  return
517  ENDIF
518 
519  long_ib = ib
520  long_nb = nb
521  CALL bawritel(lu, long_ib, long_nb, long_ka, a)
522  ka = int(long_ka)
523 END SUBROUTINE bawrite
524 
536 SUBROUTINE bawritel(LU, IB, NB, KA, A)
537  USE bacio_module
538  IMPLICIT NONE
539  INTEGER, intent(in) :: LU
540  INTEGER(kind = 8), intent(in) :: IB, NB
541  INTEGER(kind = 8), intent(out):: KA
542  CHARACTER, intent(in) :: A(NB)
543  INTEGER(kind = 8) :: LONG_0
544  INTEGER :: IRET
545 
546  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
547  ka = 0
548  RETURN
549  ENDIF
550  IF (fd(lu) .LE. 0) THEN
551  ka = 0
552  RETURN
553  ENDIF
554  IF (nb .LE. 0) THEN
555  ka = 0
556  RETURN
557  ENDIF
558 
559  long_0 = 0
560 
561  IF (ib .GE. 0) THEN
562  ka = 0
563  iret = baciol(bacio_write, ib, 1, nb, ka, fd(lu), char(0), a)
564  ELSE
565  ka = 0
566  iret = baciol(bacio_write+bacio_noseek, long_0, 1, nb, ka, &
567  fd(lu), char(0), a)
568  ENDIF
569 END SUBROUTINE bawritel
570 
581 SUBROUTINE wryte(LU, NB, A)
582  USE bacio_module
583  IMPLICIT NONE
584 
585  INTEGER, intent(in) :: LU
586  INTEGER, intent(in) :: NB
587  CHARACTER, intent(in) :: A(NB)
588  INTEGER(kind = 8) :: LONG_NB
589 
590  IF (nb < 0) THEN
591  print *, 'WRONG: NB: the number of bytes to write <0, STOP!'
592  RETURN
593  ENDIF
594  long_nb = nb
595  CALL wrytel(lu, long_nb, a)
596 END SUBROUTINE wryte
597 
607 SUBROUTINE wrytel(LU, NB, A)
608  USE bacio_module
609  IMPLICIT NONE
610  INTEGER, intent(in) :: LU
611  INTEGER(kind = 8), intent(in) :: NB
612  CHARACTER, INTENT(in) :: A(NB)
613  INTEGER(kind = 8) :: LONG_0, KA
614  INTEGER :: IRET
615 
616  IF (lu .LT. 001 .OR. lu .GT. fddim) THEN
617  ka = 0
618  RETURN
619  ENDIF
620  IF (fd(lu) .LE. 0) THEN
621  RETURN
622  ENDIF
623  IF (nb .LE. 0) THEN
624  RETURN
625  ENDIF
626 
627  long_0 = 0
628  ka = 0
629  iret = baciol(bacio_write + bacio_noseek, long_0, 1, nb, ka, &
630  fd(lu), char(0), a)
631  RETURN
632 END SUBROUTINE wrytel
bacio_module::bacio_write
integer, parameter bacio_write
Write to the file.
Definition: baciof.F90:27
bawritel
subroutine bawritel(LU, IB, NB, KA, A)
This subrouytine writes a given number of bytes to an unblocked file, skipping a given number of byte...
Definition: baciof.F90:537
baopen
subroutine baopen(LU, CFN, IRET)
Open a byte-addressable file.
Definition: baciof.F90:108
baseto
subroutine baseto(NOPT, VOPT)
Set options for byte-addressable I/O.
Definition: baciof.F90:79
bacio_module::fd
integer, dimension(fddim), save fd
Array IDs of currently open files.
Definition: baciof.F90:16
baclose
subroutine baclose(LU, IRET)
Close a byte-addressable file.
Definition: baciof.F90:316
bawrite
subroutine bawrite(LU, IB, NB, KA, A)
This program is calling bawritel() to write a given number of bytes to an unblocked file,...
Definition: baciof.F90:506
bacio_module::bacio_openwt
integer, parameter bacio_openwt
Open for write only with truncation.
Definition: baciof.F90:29
baopenwt
subroutine baopenwt(LU, CFN, IRET)
Open a byte-addressable file for write only with truncation.
Definition: baciof.F90:234
bacio_module::bacio_noseek
integer, parameter bacio_noseek
Start I/O from previous spot.
Definition: baciof.F90:28
bacio_module::bacio_read
integer, parameter bacio_read
Read from the file.
Definition: baciof.F90:26
bacio_module::bacio_openw
integer, parameter bacio_openw
Open file for write only.
Definition: baciof.F90:23
bacio_module::bacio_openrw
integer, parameter bacio_openrw
Open file for read or write.
Definition: baciof.F90:24
bacio_module
Contains subroutines to read/write binary files.
Definition: baciof.F90:10
wrytel
subroutine wrytel(LU, NB, A)
Write a given number of bytes to an unblocked file.
Definition: baciof.F90:608
baopenw
subroutine baopenw(LU, CFN, IRET)
Open a byte-addressable file for write only.
Definition: baciof.F90:192
bacio_module::baciol
Definition: baciof.F90:46
baopenwa
subroutine baopenwa(LU, CFN, IRET)
Open a byte-addressable file for write only with append.
Definition: baciof.F90:276
baopenr
subroutine baopenr(LU, CFN, IRET)
Open a byte-addressable file for read only.
Definition: baciof.F90:150
bacio_module::bacio_openwa
integer, parameter bacio_openwa
Open for write only with append.
Definition: baciof.F90:30
bacio_module::bacio_openr
integer, parameter bacio_openr
Open file for read only.
Definition: baciof.F90:22
wryte
subroutine wryte(LU, NB, A)
This subroutine is calling wrytel() to write a given number of bytes to an unblocked file.
Definition: baciof.F90:582
baread
subroutine baread(LU, IB, NB, KA, A)
This subroutine calls bareadl() to read a given number of bytes from an unblocked file,...
Definition: baciof.F90:358
bacio_module::bacio_close
integer, parameter bacio_close
Close file.
Definition: baciof.F90:25
bacio_module::fddim
integer, parameter fddim
Maximum number of open files in bacio library.
Definition: baciof.F90:13
bareadl
subroutine bareadl(LU, IB, NB, KA, A)
This subrouytine is using updated baciol() I/O package to read a given number of bytes from an unbloc...
Definition: baciof.F90:401
bacio_module::baopts
integer, dimension(20), save baopts
Array of option settings.
Definition: baciof.F90:20