[Fortran] [FTG] Support for strings in Fortran (#205)

`CHARACTER`s are converted with `IACHAR` and stored as integer array.

Author: Christian Hovy

src/serialbox-fortran/m_ser_ftg.f90

@@ -120,6 +120,7 @@ MODULE m_ser_ftg
 
 INTERFACE ftg_write
   MODULE PROCEDURE &
+    ftg_write_string, &
     ftg_write_logical_0d, &
     ftg_write_logical_1d, &
     ftg_write_logical_2d, &
@@ -154,6 +155,7 @@ MODULE m_ser_ftg
 
 INTERFACE ftg_read
   MODULE PROCEDURE &
+    ftg_read_string, &
     ftg_read_logical_0d, &
     ftg_read_logical_1d, &
     ftg_read_logical_2d, &
@@ -785,6 +787,27 @@ END FUNCTION ftg_loc_hex
 !=============================================================================
 !=============================================================================
 
+SUBROUTINE ftg_write_string(fieldname, field)
+  CHARACTER(LEN=*), INTENT(IN)         :: fieldname
+  CHARACTER(LEN=*), INTENT(IN), TARGET :: field
+
+  CHARACTER(LEN=LEN(field)), POINTER :: padd
+  LOGICAL                            :: bullshit
+
+  padd => field
+  bullshit = .FALSE.
+  IF (ignore_bullshit) THEN
+    bullshit = .NOT. ASSOCIATED(padd)
+  END IF
+
+  IF (.NOT. bullshit) THEN
+    CALL fs_write_field(ftg_get_serializer(), ftg_get_savepoint(), fieldname, field)
+    CALL ftg_add_field_metainfo(TRIM(fieldname), 'ftg:registered_only', .FALSE.)
+    CALL ftg_add_field_metainfo(TRIM(fieldname), 'ftg:loc', TRIM(ADJUSTL(ftg_loc_hex(C_LOC(field)))))
+  END IF
+
+END SUBROUTINE ftg_write_string
+
 SUBROUTINE ftg_write_logical_0d(fieldname, field)
   CHARACTER(LEN=*), INTENT(IN) :: fieldname
   LOGICAL, INTENT(IN), TARGET  :: field
@@ -1670,6 +1693,20 @@ END SUBROUTINE ftg_write_double_4d
 !=============================================================================
 !=============================================================================
 
+SUBROUTINE ftg_read_string(fieldname, field, rperturb)
+  CHARACTER(LEN=*), INTENT(IN)          :: fieldname
+  CHARACTER(LEN=*), INTENT(OUT), TARGET :: field
+  REAL, INTENT(IN), OPTIONAL            :: rperturb
+  LOGICAL                               :: registered_only
+
+  IF (.NOT. ignore_not_existing .OR. ftg_field_exists(fieldname)) THEN
+    CALL ftg_get_field_metainfo(fieldname, 'ftg:registered_only', registered_only)
+    IF (.NOT. registered_only) THEN
+      CALL fs_read_field(serializer, savepoint, fieldname, field, rperturb)
+    END IF
+  END IF
+END SUBROUTINE ftg_read_string
+
 SUBROUTINE ftg_read_logical_0d(fieldname, field, rperturb)
   CHARACTER(LEN=*), INTENT(IN) :: fieldname
   LOGICAL, INTENT(OUT), TARGET :: field

src/serialbox-fortran/m_ser_ftg_cmp.f90

@@ -78,6 +78,7 @@ MODULE m_ser_ftg_cmp
 
 INTERFACE ftg_compare
   MODULE PROCEDURE &
+    ftg_compare_string, &
     ftg_compare_logical_0d, &
     ftg_compare_logical_1d, &
     ftg_compare_logical_2d, &
@@ -1219,6 +1220,62 @@ END SUBROUTINE ftg_cmp_print_deviations_double_4d
 !=============================================================================
 !=============================================================================
 
+SUBROUTINE ftg_compare_string(fieldname, field, result, failure_count, fieldname_alias)
+  CHARACTER(LEN=*), INTENT(IN)           :: fieldname
+  CHARACTER(LEN=*), INTENT(IN)           :: field
+  LOGICAL, INTENT(OUT)                   :: result
+  INTEGER, INTENT(INOUT), OPTIONAL       :: failure_count
+  CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: fieldname_alias
+  CHARACTER(LEN=256)                     :: fieldname_print
+  CHARACTER(LEN=LEN(field))              :: stored_field
+  
+  IF (PRESENT(fieldname_alias)) THEN
+    fieldname_print = fieldname_alias
+  ELSE
+    fieldname_print = fieldname
+  END IF
+  
+  result = .TRUE.
+  
+  IF (.NOT. ftg_field_exists(fieldname)) THEN
+    IF (ftg_cmp_count_missing_field_as_failure) THEN
+      result = .FALSE.
+    END IF
+    IF (.NOT. ftg_cmp_quiet) THEN
+      WRITE (*,'(A,A,A,A)') TRIM(ftg_cmp_message_prefix), " ", TRIM(fieldname_print), " : Don't exist in Serializer"
+    END IF
+  ELSE
+    CALL ftg_read(fieldname, stored_field)
+    IF (.NOT. ftg_cmp_size(fieldname, (/ LEN(field) /), fieldname_print)) THEN
+      result = .FALSE.
+    ELSE IF (field /= stored_field) THEN
+      result = .FALSE.
+      IF (.NOT. ftg_cmp_quiet) THEN
+        WRITE (*,'(A,A,A,A)') TRIM(ftg_cmp_message_prefix), " ", TRIM(fieldname_print), " : Not equal"
+        IF (ftg_cmp_max_print_deviations > 0) THEN
+          WRITE (*,'(A)',advance="no") '  -> expected: "'
+          WRITE (*,'(A)',advance="no") TRIM(stored_field)
+          WRITE (*,'(A)') '"'
+          WRITE (*,'(A)',advance="no") '       actual: "'
+          WRITE (*,'(A)',advance="no") TRIM(field)
+          WRITE (*,'(A)') '"'
+        END IF 
+      END IF
+    END IF
+  END IF
+  
+  IF (result) THEN
+    IF (.NOT. ftg_cmp_quiet .AND. ftg_cmp_print_when_equal) THEN
+      WRITE (*,'(A,A,A,A,A,A)') TRIM(ftg_cmp_message_prefix), ' ', TRIM(fieldname_print), ' : OK ("', TRIM(field), '")'
+    END IF
+  ELSE
+    IF (PRESENT(failure_count)) THEN
+      failure_count = failure_count + 1
+    END IF
+  END IF
+    
+END SUBROUTINE ftg_compare_string
+
 SUBROUTINE ftg_compare_logical_0d(fieldname, field, result, failure_count, fieldname_alias)
   CHARACTER(LEN=*), INTENT(IN)           :: fieldname
   LOGICAL, INTENT(IN)                    :: field
@@ -3009,4 +3066,4 @@ SUBROUTINE ftg_compare_double_4d(fieldname, field, result, failure_count, lbound
 
 END SUBROUTINE ftg_compare_double_4d
 
-END MODULE m_ser_ftg_cmp
+END MODULE m_ser_ftg_cmp

src/serialbox-fortran/m_serialize.f90

@@ -224,6 +224,7 @@ END SUBROUTINE fs_disable_serialization
   !------------------------------------------------------------------------------
   INTERFACE fs_write_field
     MODULE PROCEDURE &
+      fs_write_string, &
       fs_write_logical_0d, &
       fs_write_logical_1d, &
       fs_write_logical_2d, &
@@ -262,6 +263,7 @@ END SUBROUTINE fs_disable_serialization
   !------------------------------------------------------------------------------
   INTERFACE fs_read_field
     MODULE PROCEDURE &
+      fs_read_string, &
       fs_read_logical_0d, &
       fs_read_logical_1d, &
       fs_read_logical_2d, &
@@ -1516,6 +1518,27 @@ END SUBROUTINE fs_get_savepoint_metainfo_d
 !=============================================================================
 !=============================================================================
 
+SUBROUTINE fs_write_string(serializer, savepoint, fieldname, field)
+  TYPE(t_serializer), INTENT(IN)          :: serializer
+  TYPE(t_savepoint) , INTENT(IN)          :: savepoint
+  CHARACTER(LEN=*), INTENT(IN)            :: fieldname
+  CHARACTER(LEN=*, KIND=C_CHAR), INTENT(IN), TARGET :: field
+
+  ! Local variables
+  INTEGER(KIND=C_INT), ALLOCATABLE :: ascii(:)
+  INTEGER :: i
+
+  ALLOCATE(ascii(LEN(field)))
+  DO i = 1, LEN(field)
+    ascii(i) = IACHAR(field(i:i), C_INT)
+  END DO
+  CALL fs_write_field(serializer, savepoint, fieldname, ascii)
+
+END SUBROUTINE fs_write_string
+
+!=============================================================================
+!=============================================================================
+  
 SUBROUTINE fs_write_logical_0d(serializer, savepoint, fieldname, field)
   TYPE(t_serializer), INTENT(IN)          :: serializer
   TYPE(t_savepoint) , INTENT(IN)          :: savepoint
@@ -2300,6 +2323,33 @@ END SUBROUTINE fs_write_double_4d
 !=============================================================================
 !=============================================================================
 
+SUBROUTINE fs_read_string(serializer, savepoint, fieldname, field, rperturb)
+  TYPE(t_serializer), INTENT(IN)          :: serializer
+  TYPE(t_savepoint) , INTENT(IN)          :: savepoint
+  CHARACTER(LEN=*), INTENT(IN)            :: fieldname
+  CHARACTER(LEN=*, KIND=C_CHAR), INTENT(OUT), TARGET :: field
+  REAL, INTENT(IN), OPTIONAL               :: rperturb
+
+  ! Local variables
+  INTEGER(KIND=C_INT), ALLOCATABLE :: ascii(:)
+  INTEGER :: i
+
+  ALLOCATE(ascii(fs_get_total_size(serializer, fieldname)))
+  CALL fs_read_field(serializer, savepoint, fieldname, ascii)
+  DO i = 1, MIN(LEN(field), SIZE(ascii))
+    field(i:i) = ACHAR(ascii(i), C_CHAR)
+  END DO
+  IF (LEN(field) > SIZE(ascii)) THEN
+    DO i = LEN(field) + 1, SIZE(ascii)
+      field(i:i) = ' '
+    END DO
+  END IF
+
+END SUBROUTINE fs_read_string
+
+!=============================================================================
+!=============================================================================
+  
 SUBROUTINE fs_read_logical_0d(serializer, savepoint, fieldname, field, rperturb)
   TYPE(t_serializer), INTENT(IN)           :: serializer
   TYPE(t_savepoint) , INTENT(IN)           :: savepoint

test/serialbox-fortran/ser_ftg_cmp_test.pf

@@ -353,5 +353,39 @@ CONTAINS
       CALL ftg_destroy_serializer()      
 
     END SUBROUTINE testNotExists
+    
+  @Test
+    SUBROUTINE testStrings()
+    
+      LOGICAL :: result
+      INTEGER :: failure_count
+    
+      CHARACTER(10) :: w_testfield_len10
+      
+      CHARACTER(len=*), PARAMETER :: base_name = 'test_strings'
+    
+      result = .FALSE.
+      failure_count = 0
+      
+      
+      w_testfield_len10 = 'abcde'
+
+      CALL ftg_set_serializer(dir, base_name, 'w')
+      CALL ftg_write("testfield_len10", w_testfield_len10)
+      CALL ftg_destroy_serializer()
+      
+      CALL ftg_set_serializer(dir, base_name, 'r')
+      CALL ftg_compare("testfield_len10", "abcde     ", result, failure_count)
+      @assertTrue(result)
+      @assertEqual(0, failure_count)
+      CALL ftg_compare("testfield_len10", "abcdedefgh", result, failure_count)
+      @assertFalse(result)
+      @assertEqual(1, failure_count)
+      CALL ftg_compare("testfield_len10", "abcde", result, failure_count)
+      @assertFalse(result)
+      @assertEqual(2, failure_count)
+      CALL ftg_destroy_serializer()
+    
+    END SUBROUTINE testStrings    
 
 END MODULE ser_ftg_cmp_test

test/serialbox-fortran/ser_ftg_test.pf

@@ -1111,6 +1111,35 @@ CONTAINS
       @assertTrue(ftg_field_exists("testc2"))
       CALL ftg_destroy_serializer()
 
-    END SUBROUTINE testTypeComponents  
+    END SUBROUTINE testTypeComponents
+    
+  @Test
+    SUBROUTINE testStrings()
+    
+      CHARACTER(10) :: w_testfield_len10, r_testfield_len10
+      
+      CHARACTER(len=*), PARAMETER :: base_name = 'test_strings'
+      
+      w_testfield_len10 = 'abcde'
+
+      CALL ftg_set_serializer(dir, base_name, 'w')
+      CALL ftg_write("testfield_len10", w_testfield_len10)
+      CALL ftg_destroy_serializer()
+      
+      CALL ftg_set_serializer(dir, base_name, 'r')
+      
+      @assertTrue(ftg_field_exists("testfield_len10"))
+      @assertEqual((/ 10, 0, 0, 0 /), ftg_get_size("testfield_len10"))
+      
+      CALL ftg_read("testfield_len10", r_testfield_len10)
+      
+      CALL ftg_destroy_serializer()
+      
+      @assertEqual('a', CHAR(ICHAR('a')))
+      @assertEqual(w_testfield_len10, r_testfield_len10)
+      @assertEqual('abcde     ', r_testfield_len10)
+      @assertEqual('abcde', TRIM(r_testfield_len10))
+    
+    END SUBROUTINE testStrings
 
 END MODULE ser_ftg_test

test/serialbox-fortran/serialbox_test.pf

@@ -838,5 +838,36 @@ CONTAINS
       CALL fs_destroy_savepoint(savepoint)
 
     END SUBROUTINE testSavepointMetainfo    
+    
+@Test
+    SUBROUTINE testStrings()
+    
+      TYPE(t_serializer) :: serializer
+      CHARACTER(10) :: w_testfield_len10, r_testfield_len10
+      
+      CHARACTER(len=*), PARAMETER :: base_name = 'test_strings'
+      
+      w_testfield_len10 = 'abcde'
+
+      CALL fs_create_serializer(dir, base_name, 'w', serializer)
+      CALL fs_write_field(serializer, savepoint, "testfield_len10", w_testfield_len10)
+      CALL fs_destroy_serializer(serializer)
+      
+      CALL fs_create_serializer(dir, base_name, 'r', serializer)
+      
+      @assertTrue(fs_field_exists(serializer, "testfield_len10"))
+      @assertEqual(10, fs_get_total_size(serializer, "testfield_len10"))
+      @assertEqual((/ 10, 0, 0, 0 /), fs_get_size(serializer, "testfield_len10"))
+      
+      CALL fs_read_field(serializer, savepoint, "testfield_len10", r_testfield_len10)
+      
+      CALL fs_destroy_serializer(serializer)
+      
+      @assertEqual('a', CHAR(ICHAR('a')))
+      @assertEqual(w_testfield_len10, r_testfield_len10)
+      @assertEqual('abcde     ', r_testfield_len10)
+      @assertEqual('abcde', TRIM(r_testfield_len10))
+    
+    END SUBROUTINE testStrings
 
 END MODULE serialbox_test