io_matrix.F90 3.65 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
MODULE m_io_matrix
  USE m_types
9
  USE m_judft
Daniel Wortmann's avatar
Daniel Wortmann committed
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
  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
78
    OPEN(unit=open_DA,file=filename,access='direct',recl=datasize*(matsize*matsize+4))!Three to include matsize
Daniel Wortmann's avatar
Daniel Wortmann committed
79 80 81 82 83 84 85


  END FUNCTION open_DA

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

END MODULE m_io_matrix