sll_m_ascii_io.F90

Go to the documentation of this file.

!**************************************************************
!  Copyright INRIA
!  Authors :
!     CALVI project team
!
!  This code SeLaLib (for Semi-Lagrangian-Library)
!  is a parallel library for simulating the plasma turbulence
!  in a tokamak.
!
!  This software is governed by the CeCILL-B license
!  under French law and abiding by the rules of distribution
!  of free software.  You can  use, modify and redistribute
!  the software under the terms of the CeCILL-B license as
!  circulated by CEA, CNRS and INRIA at the following URL
!  "http://www.cecill.info".
!**************************************************************
 
module sll_m_ascii_io
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#include "sll_working_precision.h"
 
   implicit none
 
   public :: &
      sll_s_ascii_file_close, &
      sll_s_ascii_file_create, &
      sll_o_ascii_write_array, &
      sll_s_ascii_write_array_1d, &
      sll_s_ascii_write_array_2d, &
      sll_s_ascii_write_array_1d_as_row
 
   private
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
   interface sll_o_ascii_write_array
      module procedure sll_s_ascii_write_array_1d
      module procedure sll_s_ascii_write_array_2d
      module procedure sll_ascii_write_array_3d
   end interface
 
contains
 
   subroutine sll_s_ascii_file_create(file_name, file_id, error)
 
      character(len=*), intent(in)         :: file_name
      sll_int32, intent(out)               :: error     
      sll_int32, intent(out)               :: file_id   
      logical                              :: lopen
 
      error = 0
 
!       do 100 file_id = 20, 99
!
!          inquire (unit=file_id, opened=lopen)
!          if (lopen) then
!             cycle
!          else
!             open (file_id, status='SCRATCH', err=100)
!             close (file_id, status='DELETE', err=100)
!             goto 200
!          end if
!
! 100      continue
!          error = 1
! 200      continue
!          error = 0
 
         open(newunit=file_id,file=file_name,form='FORMATTED',iostat=error)
         rewind(file_id)
 
         end subroutine sll_s_ascii_file_create
 
         subroutine sll_s_ascii_file_close(file_id, error)
            sll_int32, intent(in)  :: file_id 
            sll_int32, intent(out) :: error   
 
            close (file_id, iostat=error)
 
         end subroutine sll_s_ascii_file_close
 
         subroutine sll_ascii_write_array_0d(file_id, array, error)
            sll_int32, intent(in)  :: file_id
            sll_int32, intent(out) :: error
            sll_real64, intent(in)  :: array
            write (file_id, *, iostat=error) array
         end subroutine
 
         subroutine sll_s_ascii_write_array_1d(file_id, array, error, num_points, array2, array3)
            sll_int32, intent(in)  :: file_id
            sll_int32, intent(out) :: error
            sll_real64, intent(in)  :: array(:)
            sll_int32, intent(in), optional :: num_points
            sll_real64, intent(in), optional  :: array2(:)
            sll_real64, intent(in), optional  :: array3(:)
            sll_int32 :: i
            character(len=30) :: rowfmt
 
            if (.not. present(num_points)) then
               write (file_id, *, iostat=error) array
            else
               if (size(array) < num_points) then
                  print *, '#bad size for array'
                  print *, '#at line/file', __line__, __file__
                  stop
               end if
               if (present(array2)) then
                  if (size(array2) < num_points) then
                     print *, '#bad size for array2'
                     print *, '#at line/file', __line__, __file__
                     stop
                  end if
                  if (present(array3)) then
                     if (size(array3) < num_points) then
                        print *, '#bad size for array3'
                        print *, '#at line/file', __line__, __file__
                        stop
                     end if
                     do i = 1, num_points
                        write (file_id, *, iostat=error) array(i), array2(i), array3(i)
                     end do
                  else
                     do i = 1, num_points
                        write (file_id, *, iostat=error) array(i), array2(i)
                     end do
                  end if
               else
                  write (rowfmt, '(a,i7,a)') '(', num_points, '(1x,g15.5))'
                  do i = 1, num_points
                     write (file_id, trim(rowfmt), iostat=error) array(i)
                  end do
 
               end if
            end if
         end subroutine
 
         subroutine sll_s_ascii_write_array_2d(file_id, array, error)
            sll_int32, intent(in)  :: file_id
            sll_int32, intent(out) :: error
            sll_real64, intent(in)  :: array(:, :)
            write (file_id, "(100(1x,g15.5))", iostat=error) array
         end subroutine
 
         subroutine sll_ascii_write_array_3d(file_id, array, error)
            sll_int32, intent(in)  :: file_id
            sll_int32, intent(out) :: error
            sll_real64, intent(in)  :: array(:, :, :)
            write (file_id, *, iostat=error) array
          end subroutine sll_ascii_write_array_3d
 
          
          subroutine sll_s_ascii_write_array_1d_as_row(file_id,array,num_points)
            sll_int32 , intent(in)  :: file_id
            sll_real64, intent(in)  :: array(:)
            sll_int32, intent(in)   :: num_points
            sll_int32 :: i
            
            do i=1,num_points-1
               write(file_id, '(2g24.16)', advance='no') array(i)
            end do
            write(file_id, '(2g24.16)') array(num_points)
            
          end subroutine sll_s_ascii_write_array_1d_as_row
 
         end module sll_m_ascii_io