rpm_read.f90

来自「国外大名顶顶的“台风”并行计算流体力学CFD软件的早期版本的源代码」· F90 代码 · 共 61 行

!------------------------------------------------------------------------------!
! Procedure : readrpmblock                Auteur : J. Gressier
!                                         Date   : Fevrier 2002
! Fonction                                Modif  :
!   Lecture et mise en buffer des blocs de lignes dans des structures
!   RPMBLOCK g閞閑s en liste.
!
! Defauts/Limitations/Divers :
!
!------------------------------------------------------------------------------!
subroutine readrpmblock(nio, nerr, iaff, firstblock)
  use STRING
  implicit none 

! -- Declaration des entr閑s --
  integer nio    ! numero d'unite pour la lecture 
  integer nerr   ! type d'erreur en lecture de param鑤res
  integer iaff   ! choix d'affichage des informations en lecture

! -- Declaration des sorties --
  type(rpmblock), pointer  :: firstblock    ! pointeur premier bloc RPM

! -- Declaration des variables internes --
  integer, parameter       :: dimbuf = 100  ! taille du buffer ligne
  integer                  :: lectstat      ! statut de la lecture
  integer                  :: ilig          ! numero de ligne
  integer                  :: nbloc         ! nombre de bloc
  integer                  :: posc          ! position de caract鑢e
  logical                  :: inblock       ! bloc en cours de traitement
  character(len=dimrpmlig) :: strc           ! cha頽e courante
  character(len=dimrpmlig), dimension(:), allocatable &
                           :: buffer
  type(rpmblock), pointer  :: newblock, blockcourant
  type(rpmdata),  pointer  :: newdata,  datacourant
  
! -- Debut de la procedure --
  lectstat = 0
  ilig     = 1
  inblock  = .false.
  nullify(firstblock)
  allocate(buffer(dimbuf))
  
  do while ((lectstat == 0).and.(ilig <= dimbuf))
  
    read(unit=nio, fmt='(a)', iostat=lectstat) strc
    if (lectstat == 0) then
      if (iaff >= 4) write(nerr,*) "RPM: lecture - ",ilig," : ",trim(strc)
      buffer(ilig) = trait_rpmlig(strc)
    else
      buffer(ilig) = ""
      if (iaff >= 2) write(nerr,*) "RPM: Fin de fichier"
    endif
    
    if (len_trim(buffer(ilig)) /= 0) then
    
      ! ----- test de d閎ut de bloc -----
      posc = index(buffer(ilig),':')
      if (samestring(buffer(ilig)(1:posc-1), 'BLOCK')) then
        if (ilig > 1) call rpmerr("Instructions inattendues&
                                  & avant d閒inition de bloc")
        if (inblock) call rpmerr("Bloc pr閏閐ent non termin