/exodus_for/test/testrd_nsid.f

C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details
 
      program testrd
 
c This is a test program for the Fortran binding of the EXODUS II
c database read routines
 
c       09/07/93 V.R. Yarberry - Modified for API 2.00
      implicit none
 
      include 'exodusII.inc'
 
      integer iin, iout, ierr, ioff
      integer exoid, num_dim, num_nodes, num_elem, num_elem_blk
      integer num_node_sets
      integer num_side_sets
      integer i, j, k, elem_map(100), connect(100), nnpe(10)
      integer ids(10)
      integer num_elem_in_block(10), num_nodes_per_elem(10)
      integer num_attr(10)
      integer cpu_ws,io_ws, mod_sz
 
      real x(100), y(100), z(100)
      real vers
 
      character*(MXSTLN) coord_names(3)
      character*(MXLNLN) titl
      character*(MXSTLN) eltype(10)
 
      data iin /5/, iout /6/
 
c open EXODUS II files
 
      cpu_ws = 0
      io_ws = 0
 
      exoid = exopen("test-nsided.exo", exread, cpu_ws, io_ws,
     *  vers, ierr)
      write (iout, '(/"after exopen, error = ",i3)')
     1                  ierr
 
      write (iout, '("test-nsided.exo is an EXODUSII file; version ",
     1                f4.2)') vers
      write (iout, '("  I/O word size",i2)') io_ws
 
      mod_sz = exlgmd(exoid)
      write (iout, '("  Model Size",i2)') mod_sz
 
c read database parameters
 
      call exgini (exoid, titl, num_dim, num_nodes, num_elem,
     1             num_elem_blk, num_node_sets, num_side_sets, ierr)
      write (iout, '(/"after exgini, error = ", i3)' ) ierr
 
      write (iout, '("database parameters:"/
     1               "title = ", a81 /
     2               "num_dim = ", i3 /
     3               "num_nodes = ", i3 /
     4               "num_elem = ", i3 /
     5               "num_elem_blk = ", i3 /
     6               "num_node_sets = ", i3 /
     7               "num_side_sets = ", i3)')
     8               titl,num_dim, num_nodes, num_elem,
     9               num_elem_blk,num_node_sets, num_side_sets
 
c read nodal coordinates values and names from database
 
      call exgcor (exoid, x, y, z, ierr)
      write (iout, '(/"after exgcor, error = ", i3)' ) ierr
 
      write (iout, '("x coords = ")')
      do 10 i = 1, num_nodes
         write (iout, '(f5.1)') x(i)
10    continue
 
      write (iout, '("y coords = ")')
      do 20 i = 1, num_nodes
         write (iout, '(f5.1)') y(i)
20    continue
 
      if (num_dim .gt. 2) then
      write (iout, '("z coords = ")')
      do 22 i = 1, num_nodes
         write (iout, '(f5.1)') z(i)
22    continue
      endif
 
      call exgcon (exoid, coord_names, ierr)
      write (iout, '(/"after exgcon, error = ", i3)' ) ierr
 
      write (iout, '("x coord name = ", a9)') coord_names(1)
      write (iout, '("y coord name = ", a9)') coord_names(2)
 
c read element order map
 
      call exgmap (exoid, elem_map, ierr)
      write (iout, '(/"after exgmap, error = ", i3)' ) ierr
 
      do 30 i = 1, num_elem
         write (iout, '("elem_map(",i1,") = ", i1)') i, elem_map(i)
30    continue
 
c read element block parameters
 
      call exgebi (exoid, ids, ierr)
      write (iout, '(/"after exgebi, error = ", i3)' ) ierr
 
      do 40 i = 1, num_elem_blk
 
         call exgelb (exoid, ids(i), eltype(i), num_elem_in_block(i),
     1                num_nodes_per_elem(i), num_attr(i), ierr)
         write (iout, '(/"after exgelb, error = ", i3)' ) ierr
 
         write (iout, '("element block id = ", i2,/
     1                  "element type = ", a9,/
     2                  "num_elem_in_block = ", i2,/
     3                  "num_nodes_per_elem = ", i2,/
     4                  "num_attr = ", i2)')
     5                  ids(i), eltype(i), num_elem_in_block(i),
     6                  num_nodes_per_elem(i), num_attr(i)
 
40    continue
 
c read element connectivity
 
      do 60 i = 1, num_elem_blk
 
        call exgelc (exoid, ids(i), connect, ierr)
        write (iout, '(/"after exgelc, error = ", i3)' ) ierr
 
        if (eltype(i) .eq. 'nsided' .or. eltype(i) .eq. 'NSIDED') then
          call exgecpp(exoid, exeblk, ids(i), nnpe, ierr)
          write (iout, '(/"after exgecpp, error = ", i3)' ) ierr
 
          write (iout, '("connect array for elem block ", i2)') ids(i)
 
          ioff = 0
          do j = 1, num_elem_in_block(i)
            write (iout, 100) j, nnpe(j), (connect(ioff+k),k=1,nnpe(j))
            ioff = ioff + nnpe(j)
          end do
 
        end if
60    continue
 
C ... Test coordinate frames
      call getfrm(exoid)
 
      call exclos (exoid, ierr)
      write (iout, '(/"after exclos, error = ", i3)' ) ierr
 100  format(' Element ',i3,', Nodes/Element = ',i3,' -- ',20i3)
      stop
      end
 
      subroutine getfrm(exoid)
      implicit none
      include 'exodusII.inc'
 
      integer iout
 
      integer exoid, ierr, i, j
      integer numfrm;   ! Assumed to be 3 for remaining dimensions
      integer cfids(3), tags(3)
      character*32 ctag
      real    coord(27)
 
      data iout /6/
 
      numfrm = exinqi(exoid, exncf)
      write (iout,
     1  '(/"There are ",i2," coordinate frames")')
     2  numfrm
 
      numfrm = 3
      call exgfrm(exoid, numfrm, cfids, coord, tags, ierr);
      write (6,'("after exgfrm, error = ", i4)') ierr
 
! NOTE: These values may not be sensical; just used for testing.
      do i=0,2
        if (tags(i+1) .eq. excfrec) then
          ctag = 'RECTANGULAR'
        else if (tags(i+1) .eq. excfcyl) then
          ctag = 'CYLINDRICAL'
        else if (tags(i+1) .eq. excfsph) then
          ctag = 'SPHERICAL'
        end if
 
        write (iout, 100) cfids(i+1), ctag, (coord(9*i+j),j=1,9)
      end do
 
 100  format(i5, 3x, a, 9f10.2)
      return
      end