!> @file posix_interface_mod.f90 !------------------------------------------------------------------------------! ! This file is part of the PALM model system. ! ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General ! Public License as published by the Free Software Foundation, either version 3 of the License, or ! (at your option) any later version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General ! Public License for more details. ! ! You should have received a copy of the GNU General Public License along with PALM. If not, see ! . ! ! Copyright 1997-2020 Leibniz Universitaet Hannover ! -------------------------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: posix_interface_mod.f90 4495 2020-04-13 20:11:20Z raasch $ ! Initial version (K. Ketelsen) ! ! ! ! Description: ! ------------ !> Interface to some POSIX system calls, mainly used for read/write of restart files !> in non-parallel mode in MPI-IO compatible format. !--------------------------------------------------------------------------------------------------! MODULE posix_interface USE ISO_C_BINDING USE kinds IMPLICIT NONE PRIVATE SAVE ! !-- Definitions copied from C include file fcntl.h INTEGER, PARAMETER :: O_RDONLY = 0 INTEGER, PARAMETER :: O_WRONLY = 1 INTEGER, PARAMETER :: O_RDWR = 2 INTEGER, PARAMETER :: O_CREAT = 64 !> 0100 octal INTEGER, PARAMETER :: SEEK_SET = 0 ! !-- Interfaces for POSIX calls INTERFACE INTEGER(C_INT) FUNCTION C_OPEN( pathname, flags, mode ) BIND( C, NAME = 'open' ) USE ISO_C_BINDING IMPLICIT NONE CHARACTER(KIND=C_CHAR), DIMENSION(128) :: pathname INTEGER(KIND=C_INT), VALUE :: flags INTEGER(KIND=C_INT), VALUE :: mode END FUNCTION C_OPEN END INTERFACE INTERFACE INTEGER(C_SIZE_T) FUNCTION C_LSEEK( fd, offset, whence ) BIND( C, NAME = 'lseek' ) USE ISO_C_BINDING IMPLICIT NONE INTEGER(KIND=C_INT), VALUE :: fd INTEGER(KIND=C_SIZE_T), VALUE :: offset INTEGER(KIND=C_INT), VALUE :: whence END FUNCTION C_LSEEK END INTERFACE ! !-- The read system call uses values of type off_t. There is no Fortran C_OFF_T, therefore C_SIZE_T !-- has been used here, assuming both are 8 byte integers. INTERFACE INTEGER(C_SIZE_T) FUNCTION C_READ( fd, buf, nr_byte ) BIND(C, NAME = 'read' ) USE ISO_C_BINDING IMPLICIT NONE INTEGER(KIND=C_INT), VALUE :: fd TYPE(C_PTR), VALUE :: buf INTEGER(KIND=C_SIZE_T), VALUE :: nr_byte END FUNCTION C_READ END INTERFACE INTERFACE INTEGER(C_SIZE_T) FUNCTION C_WRITE( fd, buf, nr_byte ) BIND( C, NAME = 'write' ) USE ISO_C_BINDING IMPLICIT NONE INTEGER(KIND=C_INT), VALUE :: fd TYPE(C_PTR), VALUE :: buf INTEGER(KIND=C_SIZE_T), VALUE :: nr_byte END FUNCTION C_WRITE END INTERFACE INTERFACE INTEGER(C_INT) FUNCTION C_CLOSE( fd ) BIND( C, NAME = 'close' ) USE ISO_C_BINDING IMPLICIT NONE INTEGER(KIND=C_INT), VALUE :: fd END FUNCTION C_CLOSE END INTERFACE ! !-- PALM interfaces INTERFACE posix_close MODULE PROCEDURE posix_close END INTERFACE posix_close INTERFACE posix_lseek MODULE PROCEDURE posix_lseek END INTERFACE posix_lseek INTERFACE posix_open MODULE PROCEDURE posix_open END INTERFACE posix_open INTERFACE posix_read MODULE PROCEDURE posix_read MODULE PROCEDURE posix_read_char_array MODULE PROCEDURE posix_read_int_1d MODULE PROCEDURE posix_read_int_2d MODULE PROCEDURE posix_read_offset_1d MODULE PROCEDURE posix_read_real_1d MODULE PROCEDURE posix_read_real_2d MODULE PROCEDURE posix_read_real_3d END INTERFACE posix_read INTERFACE posix_write MODULE PROCEDURE posix_write MODULE PROCEDURE posix_write_char_array MODULE PROCEDURE posix_write_int_1d MODULE PROCEDURE posix_write_int_2d MODULE PROCEDURE posix_write_offset_1d MODULE PROCEDURE posix_write_real_1d MODULE PROCEDURE posix_write_real_2d MODULE PROCEDURE posix_write_real_3d END INTERFACE posix_write PUBLIC posix_close, posix_lseek, posix_open, posix_read, posix_write CONTAINS INTEGER FUNCTION posix_open( file_name, rd_flag ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: file_name CHARACTER(LEN=1), DIMENSION(:), POINTER :: f_string CHARACTER(LEN=128), TARGET :: lo_file_name INTEGER(C_INT) :: fd INTEGER(C_INT) :: flags INTEGER(C_INT) :: name_len INTEGER(C_INT) :: mode INTEGER, DIMENSION(1) :: bufshape LOGICAL, INTENT(IN) :: rd_flag TYPE(C_PTR) :: ptr ! !-- Note: There might be better solutions to convert FORTRAN string to C string but this works on !-- different FORTRAN compiler name_len = LEN( TRIM( file_name ) ) + 1 lo_file_name = TRIM( file_name ) // CHAR(0) ptr = C_LOC( lo_file_name(1:1) ) bufshape(1) = name_len CALL C_F_POINTER( ptr, f_string, bufshape ) mode = 420 ! Mode 644 IF ( rd_flag ) THEN flags = O_RDONLY fd = C_OPEN (f_string, flags, mode) ! Open for reading ELSE flags = O_WRONLY + O_CREAT fd = C_OPEN (f_string, flags, mode) ! Open for writing ENDIF posix_open = fd END FUNCTION posix_open SUBROUTINE posix_lseek( fid, offset ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER(KIND=C_INT) :: my_fid INTEGER(KIND=C_SIZE_T), INTENT(IN) :: offset INTEGER(KIND=C_SIZE_T) :: retval INTEGER(KIND=C_INT) :: whence my_fid = fid whence = SEEK_SET retval = C_LSEEK( my_fid, offset, whence ) END SUBROUTINE posix_lseek SUBROUTINE posix_read_int_1d( fid, data, nw ) IMPLICIT NONE INTEGER(KIND=iwp), INTENT(IN), TARGET, DIMENSION(:) :: data INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw TYPE(C_PTR) :: buf nr_byte = nw*iwp buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_int_1d SUBROUTINE posix_read_int_2d (fid, data, nw) IMPLICIT NONE INTEGER(KIND=iwp), INTENT(IN), TARGET, DIMENSION(:,:) :: data INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw TYPE(C_PTR) :: buf nr_byte = nw * iwp buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_int_2d SUBROUTINE posix_read_offset_1d( fid, data, nw ) IMPLICIT NONE INTEGER(KIND=C_SIZE_T), INTENT(IN), TARGET, DIMENSION(:) :: data INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw TYPE(C_PTR) :: buf nr_byte = nw * C_SIZE_T buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_offset_1d SUBROUTINE posix_read_real_1d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(IN), TARGET, DIMENSION(:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_real_1d SUBROUTINE posix_read_real_2d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(INOUT), TARGET, DIMENSION(:,:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_real_2d SUBROUTINE posix_read_real_3d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(INOUT), TARGET, DIMENSION(:,:,:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_read( fid, buf, nr_byte ) END SUBROUTINE posix_read_real_3d SUBROUTINE posix_read( fid, buf, nb ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER(KIND=C_INT) :: my_fid INTEGER , INTENT(IN) :: nb INTEGER(KIND=C_SIZE_T) :: nr_byte INTEGER(KIND=C_SIZE_T) :: retval TYPE(C_PTR) :: buf my_fid = fid nr_byte = nb retval = C_READ( my_fid, buf, nr_byte ) ! !-- The posix standard says that is not guaranteed that all bytes are read in one read system call. !-- If retval is not equal to nr_byte, another system call has to be issued. !-- However, in all Unix distributions it is commonly accepted, that all bytes are read in one call !-- during during disk-IO. Therefore, here is only an error query and no reading in a while loop. IF ( retval /= nr_byte ) THEN WRITE(6,*) 'Number of bytes read does not match the number of requested bytes' CALL abort ENDIF END SUBROUTINE posix_read SUBROUTINE posix_read_char_array( fid, data ) IMPLICIT NONE CHARACTER(LEN=*), DIMENSION(:) :: data CHARACTER(LEN=LEN(data)), TARGET :: data_buf INTEGER, INTENT(IN) :: fid INTEGER :: i INTEGER(KIND=C_INT) :: my_fid INTEGER(KIND=C_SIZE_T) :: name_len INTEGER(KIND=C_SIZE_T) :: retval TYPE(C_PTR) :: ptr my_fid = fid DO i = 1, SIZE( data ) data_buf = data(i) name_len = LEN(data(i)) ptr = C_LOC( data_buf(1:1) ) retval = C_READ( my_fid, ptr, name_len ) data(i) = data_buf ENDDO END SUBROUTINE posix_read_char_array SUBROUTINE posix_write_int_1d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER(KIND=C_INT) :: my_fid INTEGER(KIND=C_SIZE_T) :: nr_byte INTEGER , INTENT(IN) :: nw INTEGER(KIND=C_SIZE_T) :: retval INTEGER(KIND=iwp), INTENT(IN), TARGET, DIMENSION(:) :: data TYPE(C_PTR) :: buf my_fid = fid nr_byte = nw * iwp buf = C_LOC( data ) retval = C_WRITE( my_fid, buf, nr_byte ) END SUBROUTINE posix_write_int_1d SUBROUTINE posix_write_int_2d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw INTEGER(KIND=iwp), INTENT(IN), TARGET, DIMENSION(:,:) :: data TYPE(C_PTR) :: buf nr_byte = nw * iwp buf = C_LOC( data ) CALL posix_write( fid, buf, nr_byte ) END SUBROUTINE posix_write_int_2d SUBROUTINE posix_write_offset_1d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw INTEGER(KIND=C_SIZE_T), INTENT(IN), TARGET, DIMENSION(:) :: data TYPE(C_PTR) :: buf nr_byte = nw * STORAGE_SIZE( data(1) ) / 8 buf = C_LOC( data ) CALL posix_write(fid, buf, nr_byte ) END SUBROUTINE posix_write_offset_1d SUBROUTINE posix_write_real_1d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(IN), TARGET, DIMENSION(:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_write( fid, buf, nr_byte ) END SUBROUTINE posix_write_real_1d SUBROUTINE posix_write_real_2d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(INOUT), TARGET, DIMENSION(:,:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_write( fid, buf, nr_byte ) END SUBROUTINE posix_write_real_2d SUBROUTINE posix_write_real_3d( fid, data, nw ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER :: nr_byte INTEGER, INTENT(IN) :: nw REAL(KIND=wp), INTENT(INOUT), TARGET, DIMENSION(:,:,:) :: data TYPE(C_PTR) :: buf nr_byte = nw * wp buf = C_LOC( data ) CALL posix_write( fid, buf, nr_byte ) END SUBROUTINE posix_write_real_3d SUBROUTINE posix_write( fid, buf, nb ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER(KIND=C_INT) :: my_fid INTEGER , INTENT(IN) :: nb INTEGER(KIND=C_SIZE_T) :: nr_byte INTEGER(KIND=C_SIZE_T) :: retval TYPE(C_PTR) :: buf my_fid = fid nr_byte = nb retval = C_WRITE( my_fid, buf, nr_byte ) IF ( retval /= nr_byte ) THEN WRITE(6,*) 'Number of bytes to write does not match the number of requested bytes' CALL abort ENDIF END SUBROUTINE posix_write SUBROUTINE posix_write_char_array( fid, data ) IMPLICIT NONE CHARACTER(LEN=*), DIMENSION(:) :: data CHARACTER(LEN=LEN(data)+1), TARGET :: data_buf INTEGER, INTENT(IN) :: fid INTEGER :: i INTEGER(KIND=C_INT) :: my_fid INTEGER(KIND=C_SIZE_T) :: name_len INTEGER(KIND=C_SIZE_T) :: retval TYPE(C_PTR) :: ptr my_fid = fid DO i = 1, SIZE( data ) data_buf = data(i) // CHAR( 0 ) name_len = LEN( data(i) ) ptr = C_LOC( data_buf(1:1) ) retval = C_WRITE( my_fid, ptr, name_len ) ENDDO END SUBROUTINE posix_write_char_array SUBROUTINE posix_close( fid ) IMPLICIT NONE INTEGER, INTENT(IN) :: fid INTEGER(KIND=C_INT) :: my_fid INTEGER(KIND=C_INT) :: retval my_fid = fid retval = C_CLOSE( my_fid ) END SUBROUTINE posix_close END MODULE posix_interface