io_matrix.F90 2.63 KB
Newer Older
Daniel Wortmann's avatar
Daniel Wortmann committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
MODULE m_io_matrix
  USE m_types
  IMPLICIT NONE
  private
  INTEGER:: mode=1
  public:: open_matrix,read_matrix,write_matrix
CONTAINS
  INTEGER FUNCTION OPEN_matrix(l_real,matsize,no_rec,filename)
    LOGICAL,INTENT(IN)          :: l_real
    INTEGER,INTENT(in)          :: matsize,no_rec
    CHARACTER(len=*),INTENT(in) :: filename
    SELECT CASE (mode)
    CASE (1)
       OPEN_matrix=open_DA(l_real,matsize,no_rec,filename)
    CASE default
       CALL judft_error("BUG in io_matrix")
    END SELECT
  END FUNCTION OPEN_MATRIX

  SUBROUTINE read_matrix(mat,rec,id)
    TYPE(t_Mat),INTENT(INOUT):: mat
    INTEGER,INTENT(IN)           :: rec,id

    CALL mat%alloc()
    SELECT CASE (mode)
    CASE (1)
       CALL read_matrix_DA(mat,rec,id)
    CASE default
       CALL judft_error("BUG in io_matrix")
    END SELECT
  END SUBROUTINE read_matrix

  SUBROUTINE write_matrix(mat,rec,id)
    TYPE(t_Mat),INTENT(IN):: mat
    INTEGER,INTENT(IN)        :: rec,id

    SELECT CASE (mode)
    CASE (1)
       CALL write_matrix_DA(mat,rec,id)
    CASE default
       CALL judft_error("BUG in io_matrix")
    END SELECT
  END SUBROUTINE write_matrix

  !Now the implementation in terms of fortran DA-files
  INTEGER FUNCTION open_DA(l_real,matsize,no_rec,filename)
    LOGICAL,INTENT(IN)           :: l_real
    INTEGER,INTENT(in)          :: matsize,no_rec
    CHARACTER(len=*),INTENT(in) :: filename

    LOGICAL :: used_unit
    REAL    :: r
    COMPLEX :: c
    INTEGER :: datasize

    !Determine size of data
    IF (l_real) THEN
       INQUIRE(IOLENGTH=datasize) r
    ELSE
       INQUIRE(IOLENGTH=datasize) c
    END IF

    !find free unit starting at 901
    open_DA=901
    DO
       INQUIRE(unit=open_DA,opened=used_unit)
       IF (.NOT.used_unit) EXIT
       open_DA=open_DA+1
    END DO
    !openfile
    OPEN(unit=open_DA,file=filename,access='direct',recl=datasize*matsize*matsize)


  END FUNCTION open_DA

  SUBROUTINE read_matrix_DA(mat,rec,id)
    TYPE(t_Mat),INTENT(INOUT):: mat
    INTEGER,INTENT(IN)           :: rec,id

    INTEGER:: err
    IF (mat%l_real) THEN
       READ(id,rec=rec,iostat=err) mat%data_r
    ELSE
       READ(id,rec=rec,iostat=err) mat%data_c
    END IF
    IF (err.NE.0) CALL judft_error("Failed in reading of matrix")
  END SUBROUTINE read_matrix_DA

  SUBROUTINE write_matrix_DA(mat,rec,id)
    TYPE(t_Mat),INTENT(IN):: mat
    INTEGER,INTENT(IN)        :: rec,id
    INTEGER:: err
    IF (mat%l_real) THEN
       WRITE(id,rec=rec,iostat=err) mat%data_r
    ELSE
       WRITE(id,rec=rec,iostat=err) mat%data_c
    END IF
    IF (err.NE.0) CALL judft_error("Failed in writing of matrix")
  END SUBROUTINE write_matrix_DA

END MODULE m_io_matrix