     program demo_disp_get
     real :: xx(2,3), yy(2,3)
        xx(1,:)=[ 1.0, 6.0, 5.0  ]
        xx(2,:)=[ 2.4, 4.0, 6.0  ]
        yy(1,:)=[ 0.0, 3.5, 2.0  ]
        yy(2,:)=[ 7.0, 4.0, 8.22 ]
        call disp_xy(xx,yy)
     contains

     subroutine disp_xy(x,y)
     use M_display
     real x(:,:), y(:,:)
     type(disp_settings) ds
        ds = disp_get()
        call disp_set(digmax=4, sep=',')
        call disp('x=',x)
        write(*,*)
        call disp('y=',y)
        call disp_set(ds)
     end subroutine disp_xy

     end program demo_disp_get


text:
!------------------------------------------------------------------------------
!M+
! NAME:
!       Tau_Production_Utility
!
! PURPOSE:
!       Module continaing utility routines for the LBL transmittance
!       production runs
!
! CATEGORY:
!       Transmittance Production
!
! LANGUAGE:
!       Fortran-95
!
! CALLING SEQUENCE:
!       USE Tau_Production_Utility
!
! MODULES:
!       Type_Kinds:                 Module containing definitions for kinds
!                                   of variable types.
!
!       File_Utility:               Module containing generic file utility routines
!
!       Message_Handler:              Module to define simple error codes and
!                                   handle error conditions
!                                   USEs: FILE_UTILITY module
!
!       Compare_Float_Numbers:      Module containing routines to perform equality
!                                   and relational comparisons on floating point
!                                   numbers.
!                                   USEs: TYPE_KINDS module
!
!       Tau_Production_Parameters:  Module defining parameters used in the LBL
!                                   transmittance production runs.
!                                   USEs: TYPE_KINDS module
!                                         LBLRTM_PARAMETERS module
!
! CONTAINS:
!       Create_Signal_File:         Function to create a "signal" file that
!                                   can be checked for in the transmittance
!                                   production scripts. The presence of a signal
!                                   file indicates the program completed
!                                   successfully.
!
!       Compute_LBL_Band:           Function to determine what LBLband a
!                                   particular frequency is within.
!
!       Compute_dF_Index:           Function to determine which frequency
!                                   interval index is being used. More than
!                                   one frequency interval is valid for the
!                                   transmittance production code -- this
!                                   utility determines which one is being used.
!
!       Compute_Frequency_Index:    Function to determine the array index of
!                                   a particular frequency value.
!
!       Find_Indices:               Function to determine the indices of the
!                                   passed logical mask array that are .TRUE.
!
! INCLUDE FILES:
!       None.
!
! EXTERNALS:
!       None.
!
! COMMON BLOCKS:
!       None.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 15-May-2002
!                       paul.vandelst@ssec.wisc.edu
!
!  Copyright (C) 2002 Paul van Delst
!
!M-
!------------------------------------------------------------------------------

MODULE Tau_Production_Utility

  ! ------------
  ! Module usage
  ! ------------

  USE Type_Kinds
  USE File_Utility
  USE Message_Handler
  USE Compare_Float_Numbers

  USE Tau_Production_Parameters

  ! ---------------------------
  ! Disable all implicit typing
  ! ---------------------------

  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------

  PRIVATE
  PUBLIC :: Create_Signal_File
  PUBLIC :: Compute_LBL_Band
  PUBLIC :: Compute_dF_Index
  PUBLIC :: Compute_Frequency_Index
  PUBLIC :: Find_Indices

  INTERFACE Compute_LBL_Band
    MODULE PROCEDURE Compute_LBL_Band_Real
    MODULE PROCEDURE Compute_LBL_Band_Int
  END INTERFACE Compute_LBL_Band

CONTAINS

  FUNCTION Create_Signal_File( Filename,     &  ! Input
                               Message_Log ) &  ! Error messaging
                             RESULT ( Error_Status )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    CHARACTER( * ),           INTENT( IN ) :: Filename
    CHARACTER( * ), OPTIONAL, INTENT( IN ) :: Message_Log

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Error_Status

    ! ----------------
    ! Local parameters
    ! ----------------

    CHARACTER( * ), PARAMETER :: ROUTINE_NAME = 'Create_Signal_File'

    ! ---------------
    ! Local variables
    ! ---------------

    INTEGER :: FileID
    INTEGER :: IO_Status

    !#--------------------------------------------------------------------------#
    !#                  -- DEFINE A SUCCESSFUL EXIT STATUS --                   #
    !#--------------------------------------------------------------------------#

    Error_Status = SUCCESS

    !#--------------------------------------------------------------------------#
    !#                      -- CREATE THE SIGNAL FILE --                        #
    !#--------------------------------------------------------------------------#

    ! ----------------------
    ! Get a free unit number
    ! ----------------------

    FileID = Get_Lun()

    IF ( FileID < 0 ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Error obtaining file unit for '//&
                            TRIM( Filename )//' signal file.', &
                            Error_Status, &
                            Message_Log = Message_Log )
      RETURN
    END IF

    ! -------------
    ! Open the file
    ! -------------

    OPEN( FileID, FILE   = TRIM( Filename )//'.signal', &
                  STATUS = 'REPLACE', &
                  FORM   = 'FORMATTED', &
                  ACCESS = 'SEQUENTIAL', &
                  IOSTAT = IO_Status )

    IF ( IO_Status /= 0 ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Error opening '//&
                            TRIM( Filename )//' signal file.', &
                            Error_Status, &
                            Message_Log = Message_Log )
      RETURN
    END IF

    ! ---------------------------------------------
    ! Write the program filename to the signal file
    ! ---------------------------------------------

    WRITE( FileID, FMT    = '( a )',  &
                   IOSTAT = IO_Status ) Filename

    IF ( IO_Status /= 0 ) THEN
      Error_Status = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Error writing to '//&
                            TRIM( Filename )//' signal file.', &
                            Error_Status, &
                            Message_Log = Message_Log )
      CLOSE( FileID, STATUS = 'DELETE' )
    END IF

    ! ---------------------
    ! Close the signal file
    ! ---------------------

    CLOSE( FileID, STATUS = 'KEEP' )

  END FUNCTION Create_Signal_File

  FUNCTION Compute_LBL_Band_Real( Frequency, dF ) &  ! Input
                           RESULT ( LBL_Band )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    REAL( fp_kind ), INTENT( IN ) :: Frequency
    REAL( fp_kind ), INTENT( IN ) :: dF

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: LBL_Band

    ! ---------------
    ! Local variables
    ! ---------------

    INTEGER :: n, dF_Index
    REAL( fp_kind ) :: Numerator
    REAL( fp_kind ) :: Denominator

    !#--------------------------------------------------------------------------#
    !#                    -- DEFINE AN INVALID LBL BAND --                      #
    !#--------------------------------------------------------------------------#

    LBL_Band = -1

    !#--------------------------------------------------------------------------#
    !#               -- DETERMINE THE FREQUENCY INTERVAL INDEX --               #
    !#--------------------------------------------------------------------------#

    dF_Index = Compute_dF_Index( dF )

    ! -- Check the result
    IF ( dF_Index < 0 ) RETURN

    !#--------------------------------------------------------------------------#
    !#                       -- COMPUTE THE LBL BAND --                         #
    !#--------------------------------------------------------------------------#

    Numerator   = Frequency - FREQUENCY_BEGIN
    Denominator = FREQUENCY_BANDWIDTH(dF_Index) + FREQUENCY_INTERVAL(dF_Index)

    LBL_Band = INT( Numerator / Denominator ) + 1

  END FUNCTION Compute_LBL_Band_Real

  FUNCTION Compute_LBL_Band_Int( Frequency, dF_Index ) &  ! Input
                           RESULT ( LBL_Band )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    REAL( fp_kind ), INTENT( IN ) :: Frequency
    INTEGER,         INTENT( IN ) :: dF_Index

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: LBL_Band

    ! ---------------
    ! Local variables
    ! ---------------

    INTEGER :: n
    REAL( fp_kind ) :: Numerator
    REAL( fp_kind ) :: Denominator

    !#--------------------------------------------------------------------------#
    !#                    -- DEFINE AN INVALID LBL BAND --                      #
    !#--------------------------------------------------------------------------#

    LBL_Band = -1

    !#--------------------------------------------------------------------------#
    !#               -- DETERMINE THE FREQUENCY INTERVAL INDEX --               #
    !#--------------------------------------------------------------------------#

    ! -- Check the result
    IF ( dF_Index < 0 ) RETURN

    !#--------------------------------------------------------------------------#
    !#                       -- COMPUTE THE LBL BAND --                         #
    !#--------------------------------------------------------------------------#

    Numerator   = Frequency - FREQUENCY_BEGIN
    Denominator = FREQUENCY_BANDWIDTH(dF_Index) + FREQUENCY_INTERVAL(dF_Index)

    LBL_Band = INT( Numerator / Denominator ) + 1

  END FUNCTION Compute_LBL_Band_Int

  FUNCTION Compute_dF_Index( dF ) RESULT ( dF_Index )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    REAL( fp_kind ), INTENT( IN ) :: dF

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: dF_Index

    ! ---------------
    ! Local variables
    ! ---------------

    INTEGER :: n

    !#--------------------------------------------------------------------------#
    !#                    -- DEFINE AN INVALID dF_Index --                      #
    !#--------------------------------------------------------------------------#

    dF_Index = -1

    !#--------------------------------------------------------------------------#
    !#               -- DETERMINE THE FREQUENCY INTERVAL INDEX --               #
    !#--------------------------------------------------------------------------#

    ! -- Compare the numbers. Adjust ULP as required.
    Index_Search: DO n = 1, N_FREQUENCY_INTERVALS
      IF ( Compare_Float( dF, FREQUENCY_INTERVAL(n), ULP = 10000 ) ) THEN
        dF_Index = n
        EXIT Index_Search
      END IF
    END DO Index_Search

  END FUNCTION Compute_dF_index

  FUNCTION Compute_Frequency_Index( Begin_Frequency, &  ! Input
                                    dF,              &  ! Input
                                    Frequency )      &  ! Input
                                  RESULT ( Frequency_Index )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    REAL( fp_kind ), INTENT( IN ) :: Begin_Frequency
    REAL( fp_kind ), INTENT( IN ) :: dF
    REAL( fp_kind ), INTENT( IN ) :: Frequency

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Frequency_Index

    ! ----------------
    ! Local parameters
    ! ----------------

    REAL( fp_kind ), PARAMETER :: ONEpointFIVE = 1.5_fp_kind

    !#--------------------------------------------------------------------------#
    !#                     -- COMPUTE THE POSITION INDEX --                     #
    !#--------------------------------------------------------------------------#

    Frequency_Index = INT( ( ( Frequency - Begin_Frequency ) / dF ) + ONEpointFIVE )

  END FUNCTION Compute_Frequency_Index

  FUNCTION Find_Indices( Mask,         &
                         Indices,      &
                         Message_Log ) &
                       RESULT ( Error_Status )

    !#--------------------------------------------------------------------------#
    !#                         -- TYPE DECLARATIONS --                          #
    !#--------------------------------------------------------------------------#

    ! ---------
    ! Arguments
    ! ---------

    ! -- Input
    LOGICAL, DIMENSION( : ),  INTENT( IN )  :: Mask

    ! -- Output
    INTEGER, DIMENSION( : ),  INTENT( OUT ) :: Indices

    ! -- Error messaging
    CHARACTER( * ), OPTIONAL, INTENT( IN )  :: Message_Log

    ! ---------------
    ! Function result
    ! ---------------

    INTEGER :: Error_Status

    ! ----------------
    ! Local parameters
    ! ----------------

    CHARACTER( * ), PARAMETER :: ROUTINE_NAME = 'Find_Indices'

    ! ---------------
    ! Local variables
    ! ---------------

    CHARACTER( 256 ) :: Message
    INTEGER :: i, n

    !#--------------------------------------------------------------------------#
    !#                  -- DEFINE A SUCCESSFUL EXIT STATUS --                   #
    !#--------------------------------------------------------------------------#

    Error_Status = SUCCESS

    !#--------------------------------------------------------------------------#
    !#                            -- CHECK INPUT --                             #
    !#--------------------------------------------------------------------------#

    n = COUNT( Mask )

    ! -- Issue warning if mask is all FALSE
    IF ( n == 0 ) THEN
      Error_Status = WARNING
      CALL Display_Message( ROUTINE_NAME, &
                            'All MASK values are .FALSE.', &
                            Error_Status, &
                            Message_Log = Message_Log )
      RETURN
    END IF

    ! -- Are the sizes consistent?
    IF ( n /= SIZE( Indices ) ) THEN
      Error_Status = FAILURE
      WRITE( Message, '( "Number of .TRUE. MASK values, ", i4, &
                        &", is different from the size of", &
                        &" the INDICES array, ", i4, "." )' ) &
                      n, SIZE( Indices )
      CALL Display_Message( ROUTINE_NAME, &
                            TRIM( Message ), &
                            Error_Status, &
                            Message_Log = Message_Log )
      RETURN
    END IF

    !#--------------------------------------------------------------------------#
    !#                     -- FIND THE .TRUE. VALUE INDICES --                  #
    !#--------------------------------------------------------------------------#

    n = 0
    DO i = 1, SIZE( Mask )
      IF ( Mask( i ) ) THEN
        n = n + 1
        Indices( n ) = i
      END IF
    END DO

  END FUNCTION Find_Indices

END MODULE Tau_Production_Utility

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm


text:
!   -*- Mode: Fortran; -*-
!
!   (C) 2014 by Argonne National Laboratory.
!   See COPYRIGHT in top-level directory.
!
subroutine MPI_File_read_all_end_f08ts(fh, buf, status, ierror)
    use, intrinsic :: iso_c_binding, only : c_loc, c_associated
    use, intrinsic :: iso_c_binding, only : c_int, c_ptr
    use :: mpi_f08, only : MPI_File, MPI_Status
    use :: mpi_f08, only : MPI_STATUS_IGNORE, MPIR_C_MPI_STATUS_IGNORE, assignment(=)
    use :: mpi_f08, only : MPI_File_f2c, MPI_File_c2f
    use :: mpi_c_interface, only : c_File
    use :: mpi_c_interface, only : c_Status
    use :: mpi_c_interface, only : MPIR_File_read_all_end_cdesc

    implicit none

    type(MPI_File), intent(in) :: fh
    type(*), dimension(..) :: buf
    type(MPI_Status), target :: status
    integer, optional, intent(out) :: ierror

    integer(c_File) :: fh_c
    type(c_Status), target :: status_c
    integer(c_int) :: ierror_c

    fh_c = MPI_File_f2c(fh%MPI_VAL)
    if (c_associated(c_loc(status), c_loc(MPI_STATUS_IGNORE))) then
        ierror_c = MPIR_File_read_all_end_cdesc(fh_c, buf, MPIR_C_MPI_STATUS_IGNORE)
    else
        ierror_c = MPIR_File_read_all_end_cdesc(fh_c, buf, c_loc(status_c))
        status = status_c
    end if

    if (present(ierror)) ierror = ierror_c

end subroutine MPI_File_read_all_end_f08ts

max_stars_repo_name: humairakamal/FG-MPI

max_issues_repo_name: ucd-plse/mpi-error-prop

max_forks_repo_name: ucd-plse/mpi-error-prop


text:
c     Subroutine to get data vectors from 1 file
c     AJ_Kettle, 03Dec2018

      SUBROUTINE get_lines_1file2(s_pathandname,l_lines_rgh,l_lines,
     +  s_arch_id,s_arch_date_yyyymmdd,s_arch_element,s_arch_datavalue,
     +  s_arch_mflag,s_arch_qflag,s_arch_sflag,s_arch_obstime)

      IMPLICIT NONE
c************************************************************************
c     Declare variables passed into program

      CHARACTER(LEN=300)  :: s_pathandname

      INTEGER             :: l_lines_rgh
      INTEGER             :: l_lines

      CHARACTER(LEN=12)   :: s_arch_id(l_lines_rgh)
      CHARACTER(LEN=8)    :: s_arch_date_yyyymmdd(l_lines_rgh)
      CHARACTER(LEN=4)    :: s_arch_element(l_lines_rgh)
      CHARACTER(LEN=5)    :: s_arch_datavalue(l_lines_rgh)
      CHARACTER(LEN=1)    :: s_arch_mflag(l_lines_rgh)
      CHARACTER(LEN=1)    :: s_arch_qflag(l_lines_rgh)
      CHARACTER(LEN=1)    :: s_arch_sflag(l_lines_rgh)
      CHARACTER(LEN=4)    :: s_arch_obstime(l_lines_rgh)

c*****
c     Variables used in subroutine

      INTEGER             :: i,j,k,ii,jj,kk
      INTEGER             :: io

      CHARACTER(LEN=50)   :: s_linget

      INTEGER             :: i_len
      INTEGER             :: i_len_max,i_len_min

      CHARACTER(LEN=12)   :: s_sing_id
      CHARACTER(LEN=8)    :: s_sing_date_yyyymmdd
      CHARACTER(LEN=4)    :: s_sing_element
      CHARACTER(LEN=5)    :: s_sing_datavalue
      CHARACTER(LEN=1)    :: s_sing_mflag
      CHARACTER(LEN=1)    :: s_sing_qflag
      CHARACTER(LEN=1)    :: s_sing_sflag
      CHARACTER(LEN=4)    :: s_sing_obstime

c************************************************************************
c      print*,'just entered get_lines_1file'

      OPEN(UNIT=1,FILE=TRIM(s_pathandname),FORM='formatted',
     +   STATUS='OLD',ACTION='READ')

      ii=0
      i_len_max=0
      i_len_min=100

      DO
c      Read data line
       READ(1,1002,IOSTAT=io) s_linget
1002   FORMAT(a50)
       IF (io .GT. 0) THEN
        WRITE(*,*) 'Check input. Something went wrong'
        GOTO 100
       ELSE IF (io .LT. 0) THEN
c        WRITE(*,*) 'end of file reached'
        GOTO 100
       ELSE
        ii=ii+1

        IF (ii.GE.l_lines_rgh) THEN
         STOP 'get_lines_1file2; ii GE l_lines_rgh'
        ENDIF

        i_len=LEN_TRIM(s_linget)
        i_len_max=MAX(i_len,i_len_max)
        i_len_min=MIN(i_len,i_len_min)

        IF (i_len.GE.50) THEN
         STOP 'get_lines_1file; data line too long'
        ENDIF

c       Extract vectors from daily lines
        CALL get_fields_from_ghcnd_line2(s_linget,
     +   s_sing_id,s_sing_date_yyyymmdd,s_sing_element,s_sing_datavalue,
     +   s_sing_mflag,s_sing_qflag,s_sing_sflag,s_sing_obstime)

c        print*,'s_linget=',TRIM(s_linget)
c        PRINT*,'line elements',
c     +   s_sing_id,s_sing_date_yyyymmdd,s_sing_element,s_sing_datavalue,
c     +   s_sing_mflag,s_sing_qflag,s_sing_sflag,s_sing_obstime

c        STOP 'get_lines_1file2'
c        CALL SLEEP(1)

c       Archive values from lines
        s_arch_id(ii)           =s_sing_id
        s_arch_date_yyyymmdd(ii)=s_sing_date_yyyymmdd
        s_arch_element(ii)      =s_sing_element
        s_arch_datavalue(ii)    =s_sing_datavalue
        s_arch_mflag(ii)        =s_sing_mflag
        s_arch_qflag(ii)        =s_sing_qflag
        s_arch_sflag(ii)        =s_sing_sflag
        s_arch_obstime(ii)      =s_sing_obstime

       ENDIF
      ENDDO
100   CONTINUE

      CLOSE(UNIT=1)

      l_lines=ii

c*****
c     Crash program if l_lines greater than array size
      IF (l_lines.GT.l_lines_rgh) THEN
       print*,'l_lines over limit'
       STOP 'get_lines_1file2'
      ENDIF
c*****
c      print*,'l_lines=',l_lines
c      print*,'i_len_max,i_len_min=',i_len_max,i_len_min

c      print*,'just leaving get_lines_1file'

      RETURN
      END

ext: f

max_stars_repo_name: glamod/glamod-nuim

max_issues_repo_name: glamod/glamod-nuim

max_forks_repo_name: glamod/glamod-nuim


!===============================================================================
!
! Module:
!
! symmetries_m        Originally By DAS        12/20/2011
!
!   Find symmetry operations from lattice vectors and atomic positions,
!   using spglib 1.0.9. For use in mean-field codes such as EPM and SIESTA wrapper.
!
!===============================================================================

#include "f_defs.h"

module symmetries_m

  use global_m
  use misc_m
  use sort_m

  implicit none

  private

  public :: get_symmetries

  real(DP), parameter :: symprec = 1d-5
  ! this is the same tolerance used by the Quantum ESPRESSO routines

  interface
     ! these functions are defined in spglib_f.c

     subroutine spg_get_multiplicity_f(size, lattice, position, types, num_atom, symprec)
       implicit none
       integer, intent(out) :: size
       real(8), intent(in) :: lattice
       real(8), intent(in) :: position
       integer, intent(in) :: types
       integer, intent(in) :: num_atom
       real(8), intent(in) :: symprec
     end subroutine spg_get_multiplicity_f

     subroutine spg_get_symmetry_f(nsym, rotation, translation, max_size, lattice, position, types, num_atom, symprec)
       implicit none
       integer, intent(out) :: nsym
       integer, intent(out) :: rotation
       real(8), intent(out) :: translation
       integer, intent(in)  :: max_size
       real(8), intent(in)  :: lattice
       real(8), intent(in)  :: position
       integer, intent(in)  :: types
       integer, intent(in)  :: num_atom
       real(8), intent(in)  :: symprec
     end subroutine spg_get_symmetry_f

     subroutine spg_get_international_f(spacegroup, symbol, lattice, position, types, num_atom, symprec)
       implicit none
       integer, intent(out) :: spacegroup
       character*11, intent(out) :: symbol
       real(8), intent(in) :: lattice
       real(8), intent(in) :: position
       integer, intent(in) :: types
       integer, intent(in) :: num_atom
       real(8), intent(in) :: symprec
     end subroutine spg_get_international_f

  end interface

contains

  subroutine get_symmetries(nat, atyp, apos, avec, nfft, cell_symmetry, ntran, mtrx, tnp, spacegroup, symbol)
    integer, intent(in) :: nat            !< number of atoms
    integer, intent(in) :: atyp(:)        !< atomic species
    real(DP), intent(in) :: apos(:,:)     !< (1:3,1:nat) atomic positions in crystal coordinates
    real(DP), intent(in) :: avec(3,3)     !< lattice vectors in real space
    integer, intent(in) :: nfft(3)        !< FFT grid (if = 0, not used)
    integer, intent(out) :: cell_symmetry !< 0 = cubic, 1 = hexagonal
    integer, intent(out) :: ntran         !< number of symmetry operations
    integer, intent(out) :: mtrx(:,:,:)   !< rotation matrices (3, 3, 48)
    real(DP), intent(out) :: tnp(:,:)     !< frational translations (3, 48)
    integer, intent(out) :: spacegroup    !< spacegroup international index
    character, intent(out) :: symbol*21   !< spacegroup symbol in Schoenflies notation

    integer :: isym, ntran_temp, ntran_temp2, identity(3,3)
    real(DP) :: C_avec(3,3), frac_fft(3)
    integer, allocatable :: mtrx_inv(:,:,:) ! allocatable since more than 48 ops may be returned
    real(DP), allocatable :: tnp_temp(:,:)
    logical :: use_this_sym, disable_frac, found_identity

    PUSH_SUB(get_symmetries)

    C_avec = TRANSPOSE(avec)

    call spg_get_international_f(spacegroup, symbol, C_avec(1, 1), apos(1, 1), atyp(1), nat, symprec)

    ! http://en.wikipedia.org/wiki/Trigonal_crystal_system: 143-167
    ! http://en.wikipedia.org/wiki/Hexagonal_crystal_system: 168-194
    ! All others are cubic.

    if(spacegroup >= 143 .and. spacegroup <= 194) then
       cell_symmetry = 1    ! hexagonal
    else
       cell_symmetry = 0    ! cubic
    endif

    disable_frac = .false.
    call spg_get_multiplicity_f(ntran_temp, C_avec(1,1), apos(1,1), atyp(1), nat, symprec)
    SAFE_ALLOCATE(mtrx_inv, (3, 3, ntran_temp))
    SAFE_ALLOCATE(tnp_temp, (3, ntran_temp))

    ! we need to check that it is not a supercell, as in the QE routine (sgam_at)
    ! they disable fractional translations if the identity has one, because the sym ops might not form a group.
    ! spglib may return duplicate operations in this case!

    !> See SPGlib/example/example.f90
    call spg_get_symmetry_f(ntran_temp2, mtrx_inv(1,1,1), tnp_temp(1,1), ntran_temp, C_avec(1,1), apos(1,1), atyp(1), nat, symprec)

    if(ntran_temp2 /= ntran_temp) call die("Inconsistent number of symmetries from spglib. Internal error.")

    if(ntran_temp > 48) then
       disable_frac = .true.
       call die("ntran > 48.")
       write(0,'(a,i6,a)') "Number of symmetry operations = ", ntran_temp, " > 48"
    endif

    found_identity = .false.
    identity = reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/), shape(identity))
    do isym = 1, ntran_temp
       if(all(mtrx_inv(1:3,1:3,isym) == identity(1:3, 1:3))) then
          found_identity = .true.
          if(any(abs(tnp_temp(1:3, isym)) > TOL_Zero)) then
             disable_frac = .true.
             write(0,'(a,3f12.6)') 'Identity has a fractional translation ', tnp_temp(1:3, isym)
          endif
       endif
    enddo

    if(.not. found_identity) call die("Symmetries internal error: Identity is missing from symmetry operations.")

    if(disable_frac) then
       write(0,'(a)') "WARNING: Disabling fractional translations. System appears to be a supercell."
    endif

    ! spglib does not consider an FFT grid. below is based on QE routine sgam_at.
    ntran = 0
    do isym = 1, ntran_temp
       if(all(nfft(1:3) /= 0)) then
          ! check that rotation matrix is compatible with FFT grid
          use_this_sym = &
               mod(mtrx_inv(2, 1, isym) * nfft(1), nfft(2)) == 0 .and. &
               mod(mtrx_inv(3, 1, isym) * nfft(1), nfft(3)) == 0 .and. &
               mod(mtrx_inv(1, 2, isym) * nfft(2), nfft(1)) == 0 .and. &
               mod(mtrx_inv(3, 2, isym) * nfft(2), nfft(3)) == 0 .and. &
               mod(mtrx_inv(1, 3, isym) * nfft(3), nfft(1)) == 0 .and. &
               mod(mtrx_inv(2, 3, isym) * nfft(3), nfft(2)) == 0

          ! check that fractional translation is compatible with FFT grid
          frac_fft(1:3) = tnp_temp(1:3, isym) * nfft(1:3)
          use_this_sym = use_this_sym .and. all(abs(frac_fft(1:3) - nint(frac_fft(1:3))) / nfft(1:3) < symprec)
       else
          ! if FFT grid is supplied as zero, we accept all operations
          use_this_sym = .true.
       endif

       if (disable_frac) then
          if (any(abs(tnp_temp(1:3,isym)) > TOL_Zero)) use_this_sym = .false.
       endif

       if (use_this_sym) then
          ntran = ntran + 1
          if (ntran > 48) call die("Internal error: There are more than 48 accepted symmetry operations.")
          mtrx(:,:,ntran) = TRANSPOSE(mtrx_inv(:,:,isym))
          tnp(1:3, ntran) = tnp_temp(1:3, isym)
       endif
    enddo

    SAFE_DEALLOCATE(mtrx_inv)
    SAFE_DEALLOCATE(tnp_temp)

    call make_identity_symmetry_first(ntran, mtrx, tnp)

    POP_SUB(get_symmetries)
    return

  end subroutine get_symmetries

end module symmetries_m


text:
! TestLite: A lightweight testing framework
!
! MIT License
!
! Copyright (c) 2020 fpm contributors
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module TestLite
  use, intrinsic :: iso_fortran_env, only : error_unit
  use TestLite_suite, only : run_testsuite, new_testsuite, testsuite_t, &
        & select_suite, run_selected
  implicit none

  contains

  !> Run a collection of testsuites
  subroutine run_tests(testsuite)
    type(testsuite_t), intent(in) :: testsuite(:)

    integer :: stat, is
    character(len=:), allocatable :: suite_name, test_name
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    call get_argument(1, suite_name)
    call get_argument(2, test_name)

    if (allocated(suite_name)) then
        is = select_suite(testsuite, suite_name)
        if (is > 0 .and. is <= size(testsuite)) then
            if (allocated(test_name)) then
                write(error_unit, fmt) "Suite:", testsuite(is)%name
                call run_selected(testsuite(is)%collect, test_name, error_unit, stat)
                if (stat < 0) then
                    error stop 1
                end if
            else
                write(error_unit, fmt) "Testing:", testsuite(is)%name
                call run_testsuite(testsuite(is)%collect, error_unit, stat)
            end if
        else
            write(error_unit, fmt) "Available testsuites"
            do is = 1, size(testsuite)
                write(error_unit, fmt) "-", testsuite(is)%name
            end do
            error stop 1
        end if
    else
        do is = 1, size(testsuite)
            write(error_unit, fmt) "Testing:", testsuite(is)%name
            call run_testsuite(testsuite(is)%collect, error_unit, stat)
        end do
    end if

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop 1
    end if

  end subroutine run_tests

  !> Obtain the command line argument at a given index
  subroutine get_argument(idx, arg)

      !> Index of command line argument, range [0:command_argument_count()]
      integer, intent(in) :: idx

      !> Command line argument
      character(len=:), allocatable, intent(out) :: arg

      integer :: length, stat

      call get_command_argument(idx, length=length, status=stat)
      if (stat /= 0) then
          return
      endif

      allocate(character(len=length) :: arg, stat=stat)
      if (stat /= 0) then
          return
      endif

      if (length > 0) then
          call get_command_argument(idx, arg, status=stat)
          if (stat /= 0) then
              deallocate(arg)
              return
          end if
      end if

  end subroutine get_argument

end module TestLite

max_stars_repo_name: jhaiduce/fhash

max_issues_repo_name: jhaiduce/fhash

max_forks_repo_name: jhaiduce/fhash