Example Source Code: hhdbin.f
c **********************************************************************
c * hhdbin.f *
c * Copyright (C) 1997 Dept. of Mathematics, University of Houston *
c * This is free software; you can use, copy, distribute and/or modify *
c * it freely under the disclaimer that no warranties are offered nor *
c * liabilities assumed through such actions. *
c **********************************************************************
c **********************************************************************
c * This example program simply reads records from a hhdb file. The *
c * two subroutines gets() and getu() supplied below read a structured *
c * and unstructured block. *
c * Please note that this is a skeleton routine intendend for *
c * demonstration purpose only. *
c **********************************************************************
program hhdbin
implicit logical (a-z)
integer MAGN,
* HHDB,EHHDB,
* UNSTR,STRUC
parameter (MAGN=1212432974,
* HHDB=32,EHHDB=33,
* UNSTR=64,STRUC=66)
integer unit,mag,status,tag,blk
integer soln,nblks,ndims,nvars,bvars
integer getu,gets
character fname*256
print*,'Give hhdb file name.'
read(5,'(a256)') fname
unit = 1
open(unit=unit,file=fname,
* status='old',form='unformatted',err=3000)
read(unit,iostat=status) mag
if( status.ne.0 .or. mag.ne.MAGN ) then
print*,'Incorrect magic number.'
goto 2000
endif
10 read(unit,end=2000) tag
if( tag.eq.HHDB ) then
backspace(unit)
read(unit,err=1000) tag,soln,nblks,ndims,nvars,bvars
print*,'Reading solution number',soln
blk = 0
100 continue
read(unit,err=1000) tag
if( tag.eq.EHHDB ) then
print*,'Finished reading',blk,' of',nblks,' block(s).'
goto 10
else
* if( tag.eq.UNSTR ) then
backspace(unit)
status = getu(unit,ndims,nvars,bvars)
blk = blk+1
if( status.ne.0 ) then
print*,'Error reading unstructured block ',blk
print*,'Error status: ',status
goto 2000
endif
else
* if( tag.eq.STRUC ) then
backspace(unit)
status = gets(unit,ndims,nvars,bvars)
blk = blk+1
if( status.ne.0 ) then
print*,'Error reading structured block ',blk
print*,'Error status: ',status
goto 2000
endif
endif
goto 100
endif
goto 10
1000 print*,'Error while reading file after block',blk,'.'
2000 close(unit=unit)
print*,'Done reading file.'
stop
3000 print*,'Error opening file for reading.'
stop
end
c **********************************************************************
c * Read an unstructured block. *
c **********************************************************************
integer function getu(unit,ndims,nvars,bvars)
integer unit,ndims,nvars,bvars
implicit logical (a-z)
integer EUNSTR,CC_INT,VC_INT,CC_BOU,VC_BOU
parameter (EUNSTR=65,
* CC_INT=257,VC_INT=256,
* CC_BOU=259,VC_BOU=258)
integer tag,blk,nptchs,ptch,
* nnodes,ncells,nconns,bnodes,bcells,bconns
integer type,no,ce,ve,id,va
real node(1),solu(1)
integer cell(1)
real bsol(1)
integer bnod(1),bcel(1)
c The following logical is used to make sure that the current block
c contains the required interior data.
logical rdint
integer nperc(1:8)
save nperc
data nperc/1,2,3,4,5,6,4,8/
rdint = .false.
read(unit,err=1000) tag,blk,nptchs
100 continue
read(unit,err=1000) tag
if( tag.eq.EUNSTR ) then
if( rdint ) then
getu = 0
else
getu = 3
endif
return
else
* if( tag.eq.VC_INT ) then
if( rdint ) then
getu = 2
return
endif
rdint = .true.
backspace(unit)
read(unit,err=1000) tag,nnodes,ncells,nconns,
* ((node(1),id=1,ndims),no=1,nnodes),
* ((solu(1),no=1,nnodes),va=1,nvars),
* (type,(cell(1),ve=1,nperc(type)),ce=1,ncells)
c Note: The read above can not properly load cell(*). This line of code
c serves only to describe the format of the cell connectivity. Since
c nconns = #words in (type,(cell(1),ve=1,nperc(type)),ce=1,ncells),
c it is much better to use
c read(...) ...
c * (...),
c * (...),
c * (cell(ce),ce=1,nconns)
c to place this information in memory.
else
* if( tag.eq.CC_INT ) then
if( rdint ) then
getu = 2
return
endif
rdint = .true.
backspace(unit)
read(unit,err=1000) tag,nnodes,ncells,nconns,
* ((node(1),id=1,ndims),no=1,nnodes),
* ((solu(1),ce=1,ncells),va=1,nvars),
* (type,(cell(1),ve=1,nperc(type)),ce=1,ncells)
else
* if( tag.eq.VC_BOU ) then
backspace(unit)
read(unit,err=1000) tag,ptch,bnodes,bcells,bconns,
* (bnod(1),no=1,bnodes),
* ((bsol(1),no=1,bnodes),va=1,bvars),
* (type,(bcel(1),ve=1,nperc(type)),ce=1,bcells)
else
* if( tag.eq.CC_BOU ) then
backspace(unit)
read(unit,err=1000) tag,ptch,bnodes,bcells,bconns,
* (bnod(1),no=1,bnodes),
* ((bsol(1),ce=1,bcells),va=1,bvars),
* (type,(bcel(1),ve=1,nperc(type)),ce=1,bcells)
endif
goto 100
1000 getu = 1
return
end
c **********************************************************************
c * Read a structured block. *
c **********************************************************************
integer function gets(unit,ndims,nvars,bvars)
integer unit,ndims,nvars,bvars
implicit logical (a-z)
integer ESTRUC,CC_INT,VC_INT,CC_BOU,VC_BOU
parameter (ESTRUC=67,
* CC_INT=257,VC_INT=256,
* CC_BOU=259,VC_BOU=258)
integer tag,blk,nptchs,ptch,
* idim,jdim,kdim,
* ilo,ihi,jlo,jhi,klo,khi
integer id,va,i,j,k
real node(1),solu(1)
real bsol(1)
c The following logical is used to make sure that the current block
c contains the required interior data.
logical rdint
rdint = .false.
read(unit,err=1000) tag,blk,nptchs
100 continue
read(unit) tag
if( tag.eq.ESTRUC ) then
if( rdint ) then
gets = 0
else
gets = 3
endif
return
else
* if( tag.eq.VC_INT ) then
if( rdint ) then
gets = 2
return
endif
rdint = .true.
backspace(unit)
read(unit,err=1000) tag,idim,jdim,kdim,
* ((((node(1),id=1,ndims),
* i=1,idim),
* j=1,jdim),
* k=1,kdim),
* ((((solu(1),i=1,idim),
* j=1,jdim),
* k=1,kdim),va=1,nvars)
else
* if( tag.eq.CC_INT ) then
if( rdint ) then
gets = 2
return
endif
rdint = .true.
backspace(unit)
read(unit,err=1000) tag,idim,jdim,kdim,
* ((((node(1),id=1,ndims),
* i=1,idim),
* j=1,jdim),
* k=1,kdim),
* ((((solu(1),i=1,max(idim-1,1)),
* j=1,max(jdim-1,1)),
* k=1,max(kdim-1,1)),va=1,nvars)
else
* if( tag.eq.VC_BOU ) then
backspace(unit)
read(unit,err=1000) tag,ptch,ilo,ihi,jlo,jhi,klo,khi,
* ((((bsol(1),i=1,ihi-ilo+1),
* j=1,jhi-jlo+1),
* k=1,khi-klo+1),va=1,bvars)
else
* if( tag.eq.CC_BOU ) then
backspace(unit)
read(unit,err=1000) tag,ptch,ilo,ihi,jlo,jhi,klo,khi,
* ((((bsol(1),i=1,max(ihi-ilo,1)),
* j=1,max(jhi-jlo,1)),
* k=1,max(khi-klo,1)),va=1,bvars)
endif
goto 100
1000 gets = 1
return
end
Last modified: Mon Sep 14 11:21:42 MET DST 1998