Add support for writing QCSchema JSON

.github/workflows/build.yml

@@ -41,7 +41,7 @@ jobs:
           compiler: gnu
           version: 9
 
-        - os: macos-latest
+        - os: ubuntu-latest
           build: meson
           build-type: coverage
           compiler: gnu
@@ -53,12 +53,6 @@ jobs:
           compiler: gnu
           version: 11
 
-        - os: macos-latest
-          build: meson
-          build-type: debug
-          compiler: gnu
-          version: 5
-
         - os: ubuntu-latest
           build: meson
           build-type: debug

src/mctc/io/filetype.f90

@@ -50,6 +50,9 @@ module mctc_io_filetype
       !> Gaussian external format
       integer :: gaussian = 8
 
+      !> QCSchema JSON file
+      integer :: qcschema = 9
+
    end type enum_filetype
 
    !> File type enumerator
@@ -91,6 +94,8 @@ elemental function get_filetype(file) result(ftype)
          ftype = filetype%gen
       case('ein')
          ftype = filetype%gaussian
+      case('json')
+         ftype = filetype%qcschema
       end select
       if (ftype /= filetype%unknown) return
    else

src/mctc/io/write.f90

@@ -19,6 +19,7 @@ module mctc_io_write
    use mctc_io_write_gaussian, only : write_gaussian_external
    use mctc_io_write_genformat, only : write_genformat
    use mctc_io_write_pdb, only : write_pdb
+   use mctc_io_write_qcschema, only : write_qcschema
    use mctc_io_write_turbomole, only : write_coord
    use mctc_io_write_vasp, only : write_vasp
    use mctc_io_write_xyz, only : write_xyz
@@ -128,6 +129,9 @@ subroutine write_structure_to_unit(self, unit, ftype, error)
    case(filetype%gaussian)
       call write_gaussian_external(self, unit)
 
+   case(filetype%qcschema)
+      call write_qcschema(self, unit)
+
    end select
 
 end subroutine write_structure_to_unit

src/mctc/io/write/CMakeLists.txt

@@ -20,6 +20,7 @@ list(
   "${dir}/gaussian.f90"
   "${dir}/genformat.f90"
   "${dir}/pdb.f90"
+  "${dir}/qcschema.f90"
   "${dir}/turbomole.f90"
   "${dir}/vasp.f90"
   "${dir}/xyz.f90"

src/mctc/io/write/meson.build

@@ -17,6 +17,7 @@ srcs += files(
   'gaussian.f90',
   'genformat.f90',
   'pdb.f90',
+  'qcschema.f90',
   'turbomole.f90',
   'vasp.f90',
   'xyz.f90',

src/mctc/io/write/qcschema.f90

@@ -0,0 +1,255 @@
+! This file is part of mctc-lib.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+module mctc_io_write_qcschema
+   use mctc_env_accuracy, only : wp
+   use mctc_io_structure, only : structure_type
+   use mctc_version, only : get_mctc_version
+   implicit none
+   private
+
+   public :: write_qcschema
+
+
+   interface json_value
+      module procedure :: json_value_char
+      module procedure :: json_value_int
+      module procedure :: json_value_real
+   end interface json_value
+
+   interface json_array
+      module procedure :: json_array_char_1
+      module procedure :: json_array_int_1
+      module procedure :: json_array_real_1
+   end interface json_array
+
+   character(len=*), parameter :: nl = new_line('a')
+
+contains
+
+
+subroutine write_qcschema(mol, unit)
+   type(structure_type), intent(in) :: mol
+   integer, intent(in) :: unit
+
+   write(unit, '(a)') json_string(mol, "  ")
+end subroutine write_qcschema
+
+pure function json_string(mol, indent) result(string)
+   type(structure_type), intent(in) :: mol
+   character(len=*), intent(in), optional :: indent
+   character(len=:), allocatable :: string
+
+   string = "{"
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("schema_version", indent) // json_value(2)
+
+   string = string // ","
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("schema_name", indent) // json_value("qcschema_molecule")
+
+   string = string // ","
+   block
+      character(len=:), allocatable :: version
+      call get_mctc_version(string=version)
+      if (present(indent)) string = string // nl // indent
+      string = string // json_key("provenance", indent) // "{"
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_key("creator", indent) // json_value("mctc-lib")
+      string = string // ","
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_key("version", indent) // json_value(version)
+      string = string // ","
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_key("routine", indent) // &
+         & json_value("mctc_io_write_qcschema::write_qcschema")
+      if (present(indent)) string = string // nl // indent
+      string = string // "}"
+   end block
+
+   if (allocated(mol%comment)) then
+      string = string // ","
+      if (present(indent)) string = string // nl // indent
+      string = string // json_key("comment", indent) // json_value(mol%comment)
+   end if
+
+   string = string // ","
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("symbols", indent) // json_array(mol%sym(mol%id), indent)
+
+   string = string // ","
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("atomic_numbers", indent) // &
+      & json_array(mol%num(mol%id), indent)
+
+   string = string // ","
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("geometry", indent) // json_array([mol%xyz], indent)
+
+   string = string // ","
+   if (present(indent)) string = string // nl // indent
+   string = string // json_key("molecular_charge", indent) // json_value(nint(mol%charge))
+
+   if (mol%uhf > 0) then
+      string = string // ","
+      if (present(indent)) string = string // nl // indent
+      string = string // json_key("molecular_multiplicity", indent) // json_value(mol%uhf+1)
+   end if
+
+   if (allocated(mol%bond)) then
+      string = string // ","
+      if (present(indent)) string = string // nl // indent
+      string = string // json_key("connectivity", indent) // "["
+      block
+         integer :: i
+         do i = 1, mol%nbd
+            if (present(indent)) string = string // nl // indent // indent
+            string = string // "[" // json_value(mol%bond(1, i)-1) // "," // &
+               & json_value(mol%bond(2, i)-1) // ","
+            if (size(mol%bond, 1) > 2) then
+               string = string // json_value(mol%bond(3, i)) // "]"
+            else
+               string = string // json_value(1) // "]"
+            end if
+            if (i /= mol%nbd) string = string // ","
+         end do
+      end block
+      if (present(indent)) string = string // nl // indent
+      string = string // "]"
+   end if
+
+   if (present(indent)) string = string // nl
+   string = string // "}"
+end function json_string
+
+pure function json_array_int_1(array, indent) result(string)
+   integer, intent(in) :: array(:)
+   character(len=*), intent(in), optional :: indent
+   character(len=:), allocatable :: string
+
+   integer :: i, j
+
+   string = "["
+   do i = 1, size(array)
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_value(array(i))
+      if (i /= size(array)) string = string // ","
+   end do
+   if (present(indent)) string = string // nl // indent
+   string = string // "]"
+end function json_array_int_1
+
+pure function json_array_real_1(array, indent) result(string)
+   real(wp), intent(in) :: array(:)
+   character(len=*), intent(in), optional :: indent
+   character(len=:), allocatable :: string
+
+   integer :: i, j
+
+   string = "["
+   do i = 1, size(array)
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_value(array(i), '(es23.16)')
+      if (i /= size(array)) string = string // ","
+   end do
+   if (present(indent)) string = string // nl // indent
+   string = string // "]"
+end function json_array_real_1
+
+pure function json_array_char_1(array, indent) result(string)
+   character(len=*), intent(in) :: array(:)
+   character(len=*), intent(in), optional :: indent
+   character(len=:), allocatable :: string
+
+   integer :: i, j
+
+   string = "["
+   do i = 1, size(array)
+      if (present(indent)) string = string // nl // indent // indent
+      string = string // json_value(trim(array(i)))
+      if (i /= size(array)) string = string // ","
+   end do
+   if (present(indent)) string = string // nl // indent
+   string = string // "]"
+end function json_array_char_1
+
+pure function json_key(key, indent) result(string)
+   character(len=*), intent(in) :: key
+   character(len=*), intent(in), optional :: indent
+   character(len=:), allocatable :: string
+
+   if (present(indent)) then
+      string = json_value(key) // ": "
+   else
+      string = json_value(key) // ":"
+   end if
+end function json_key
+
+pure function json_value_char(val) result(string)
+   character(len=*), intent(in) :: val
+   character(len=:), allocatable :: string
+
+   string = """" // val // """"
+end function json_value_char
+
+pure function json_value_real(val, format) result(str)
+   real(wp), intent(in) :: val
+   character(len=*), intent(in) :: format
+   character(len=:), allocatable :: str
+
+   character(len=128) :: buffer
+   integer :: stat
+
+   write(buffer, format, iostat=stat) val
+   if (stat == 0) then
+      str = trim(buffer)
+   else
+      str = """*"""
+   end if
+end function json_value_real
+
+pure function json_value_int(val) result(string)
+   integer, intent(in) :: val
+   character(len=:), allocatable :: string
+   integer, parameter :: buffer_len = range(val)+2
+   character(len=buffer_len) :: buffer
+   integer :: pos
+   integer :: n
+   character(len=1), parameter :: numbers(0:9) = &
+      ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]
+
+   if (val == 0) then
+      string = numbers(0)
+      return
+   end if
+
+   n = abs(val)
+   buffer = ""
+
+   pos = buffer_len + 1
+   do while (n > 0)
+      pos = pos - 1
+      buffer(pos:pos) = numbers(mod(n, 10))
+      n = n/10
+   end do
+   if (val < 0) then
+      pos = pos - 1
+      buffer(pos:pos) = '-'
+   end if
+
+   string = buffer(pos:)
+end function json_value_int
+
+
+end module mctc_io_write_qcschema

src/mctc/version.f90

@@ -31,7 +31,7 @@ module mctc_version
 
 
 !> Getter function to retrieve mctc-lib version
-subroutine get_mctc_version(major, minor, patch, string)
+pure subroutine get_mctc_version(major, minor, patch, string)
 
    !> Major version number of the mctc-lib version
    integer, intent(out), optional :: major