bafrio.F90

Go to the documentation of this file.

 
 
SUBROUTINE bafrindex(LU,IB,LX,IX)
  IMPLICIT NONE
  INTEGER,INTENT(IN):: LU,IB
  INTEGER,INTENT(INOUT):: LX
  INTEGER,INTENT(OUT):: IX
  integer(kind=8) :: LONG_IB,LONG_LX ,LONG_IX=0
 
  long_ib=ib
  long_lx=lx
  call bafrindexl(lu,long_ib,long_lx,long_ix)
  lx=int(long_lx)
  ix=int(long_ix)
 
  return
end SUBROUTINE bafrindex
 
SUBROUTINE bafrindexl(LU,IB,LX,IX)
  IMPLICIT NONE
  INTEGER,INTENT(IN):: LU
  INTEGER(KIND=8),INTENT(IN):: IB
  INTEGER(KIND=8),INTENT(INOUT):: LX
  INTEGER(KIND=8),INTENT(OUT):: IX
  INTEGER(KIND=8),PARAMETER:: LBCW=4
  INTEGER(KIND=LBCW):: BCW1,BCW2
  INTEGER(KIND=8):: KR
  CHARACTER(16) :: MACHINE_ENDIAN
  LOGICAL :: DO_BYTESWAP = .true.
  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !  COMPARE FIRST BLOCK CONTROL WORD AND TRAILING BLOCK CONTROL WORD
  IF(lu.GT.0) THEN
     !
     !-- set do_byteswap from machine endianness and file endianness
     CALL chk_endianc(machine_endian)
     IF( lu<=999) THEN
        IF( trim(machine_endian)=="big_endian") THEN
           do_byteswap=.false.
        ELSEIF( trim(machine_endian)=="little_endian") THEN
           do_byteswap=.true.
        ENDIF
     ELSEIF(lu<=1999) THEN
        IF( trim(machine_endian)=="big_endian") THEN
           do_byteswap=.true.
        ELSEIF( trim(machine_endian)=="little_endian") THEN
           do_byteswap=.false.
        ENDIF
     ENDIF
     ! 
     !
     !-- read out control word      
     CALL bareadl(lu,ib,lbcw,kr,bcw1)
     IF(do_byteswap) CALL byteswap(bcw1,lbcw,1)
     !
     IF(kr.NE.lbcw) THEN
        lx=-1
     ELSE
        CALL bareadl(lu,ib+lbcw+bcw1,lbcw,kr,bcw2)
        IF(do_byteswap) CALL byteswap(bcw2,lbcw,1)
        !
        IF(kr.NE.lbcw.OR.bcw1.NE.bcw2) THEN
           lx=-2
        ELSE
           lx=bcw1
        ENDIF
     ENDIF
     !
     !end luif
  ENDIF
 
  !  COMPUTE START BYTE FOR THE NEXT FORTRAN RECORD
  IF(lx.GE.0) ix=ib+lbcw+lx+lbcw
END SUBROUTINE bafrindexl
 
SUBROUTINE bafrread(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((ib<0.and.ib/=-1) .or. nb<0 ) THEN
     print *,'WRONG: in BAFRREAD starting postion IB or read '//    &
          'data size NB < 0, STOP! Consider use BAFREADL and long integer'
     ka=0
     return
  ENDIF
  long_ib=ib
  long_nb=nb
  CALL bafrreadl(lu,long_ib,long_nb,long_ka,a)
  ka=int(long_ka)
END SUBROUTINE bafrread
 
SUBROUTINE bafrreadl(LU,IB,NB,KA,A)
  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:: LBCW=4
  INTEGER(kind=8):: LX=0,ix
  INTEGER(kind=8):: KR
 
  !  VALIDATE FORTRAN RECORD
  CALL bafrindexl(lu,ib,lx,ix)
 
  !  READ IF VALID
  IF(lx.LT.0) THEN
     ka=lx
  ELSEIF(lx.LT.nb) THEN
     ka=-3
  ELSE
     CALL bareadl(lu,ib+lbcw,nb,kr,a)
     IF(kr.NE.nb) THEN
        ka=-1
     ELSE
        ka=lbcw+lx+lbcw
     ENDIF
  ENDIF
END SUBROUTINE bafrreadl
 
SUBROUTINE bafrwrite(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((ib<0.and.ib/=-1) .or. nb<0 ) THEN
     print *,'WRONG: in BAFRWRITE starting postion IB or read '//   &
          'data size NB <0, STOP! ' //                                    &
          'Consider use BAFRRWRITEL and long integer'
     ka=0
     return
  ENDIF
  long_ib=ib
  long_nb=nb
  CALL bafrwritel(lu,long_ib,long_nb,long_ka,a)
  ka=int(long_ka)
END SUBROUTINE bafrwrite
 
SUBROUTINE bafrwritel(LU,IB,NB,KA,A)
  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),PARAMETER:: LBCW=4
  INTEGER(kind=LBCW):: BCW
  INTEGER(kind=8):: KR
  CHARACTER(16) :: MACHINE_ENDIAN
  LOGICAL :: DO_BYTESWAP = .true.
 
  !  WRITE DATA BRACKETED BY BLOCK CONTROL WORDS
 
  !-- set do_byteswap from machine endianness and file endianness
  CALL chk_endianc(machine_endian)
  IF( lu<=999) THEN
     IF( trim(machine_endian)=="big_endian") THEN
        do_byteswap=.false.
     ELSEIF( trim(machine_endian)=="little_endian") THEN
        do_byteswap=.true.
     ENDIF
  ELSEIF(lu<=1999) THEN
     IF( trim(machine_endian)=="big_endian") THEN
        do_byteswap=.true.
     ELSEIF( trim(machine_endian)=="little_endian") THEN
        do_byteswap=.false.
     ENDIF
  ENDIF
 
  bcw=int(nb)
  IF(do_byteswap) CALL byteswap(bcw,lbcw,1)
  CALL bawritel(lu,ib,lbcw,kr,bcw)
  IF(kr.NE.lbcw) THEN
     ka=-1
  ELSE
     CALL bawritel(lu,ib+lbcw,nb,kr,a)
     IF(kr.NE.nb) THEN
        ka=-1
     ELSE
        CALL bawritel(lu,ib+lbcw+nb,lbcw,kr,bcw)
        IF(kr.NE.lbcw) THEN
           ka=-1
        ELSE
           ka=lbcw+nb+lbcw
        ENDIF
     ENDIF
  ENDIF
END SUBROUTINE  bafrwritel