io_matrix.F90 3.64 KB
Newer Older
1 2 3 4 5 6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

Daniel Wortmann's avatar
Daniel Wortmann committed
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
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
77
    OPEN(unit=open_DA,file=filename,access='direct',recl=datasize*(matsize*matsize+4))!Three to include matsize
Daniel Wortmann's avatar
Daniel Wortmann committed
78 79 80 81 82 83 84


  END FUNCTION open_DA

  SUBROUTINE read_matrix_DA(mat,rec,id)
    TYPE(t_Mat),INTENT(INOUT):: mat
    INTEGER,INTENT(IN)           :: rec,id
85 86 87 88 89
    LOGICAL :: l_real
    INTEGER:: err,matsize1,matsize2
    l_real=mat%l_real
    READ(id,rec=rec,iostat=err) matsize1,matsize2
    if (matsize1<1) call judft_error("Data not found in file")
90 91 92 93 94 95 96
    IF (mat%matsize1.NE.matsize1.OR.mat%matsize2.NE.matsize2) THEN
       WRITE(*,*) 'mat%matsize1 = ', mat%matsize1
       WRITE(*,*) 'mat%matsize2 = ', mat%matsize2
       WRITE(*,*) 'stored matsize1 = ', matsize1
       WRITE(*,*) 'stored matsize2 = ', matsize2
       CALL juDFT_error("matrix size wrong", calledby="read_matrix_DA")
    END IF
Daniel Wortmann's avatar
Daniel Wortmann committed
97
    IF (mat%l_real) THEN
98
       READ(id,rec=rec,iostat=err) matsize1,matsize2,mat%data_r
Daniel Wortmann's avatar
Daniel Wortmann committed
99
    ELSE
100
       READ(id,rec=rec,iostat=err) matsize1,matsize2,mat%data_c
Daniel Wortmann's avatar
Daniel Wortmann committed
101 102 103 104 105 106 107 108 109
    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
110
       WRITE(id,rec=rec,iostat=err) mat%matsize1,mat%matsize2,mat%data_r
Daniel Wortmann's avatar
Daniel Wortmann committed
111
    ELSE
112
       WRITE(id,rec=rec,iostat=err) mat%matsize1,mat%matsize2,mat%data_c
Daniel Wortmann's avatar
Daniel Wortmann committed
113 114 115 116 117
    END IF
    IF (err.NE.0) CALL judft_error("Failed in writing of matrix")
  END SUBROUTINE write_matrix_DA

END MODULE m_io_matrix