lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
3 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: ec572c6da6
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'ec572c6da6'
${ noResults }
EXODUS/packages/seacas/applications/ex2ex1v2/ex2ex1v2.f

814 lines
24 KiB
Raw Blame History

C Copyright(C) 1999-2021 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 EX2EX1V2
C=======================================================================
C --*** EX2EX1V2 *** EXODUS II to EXODUS I translator
C --
C --EX2EX1V2 reads the EXODUS II V2.02 and V2.03
C --regular and history files and writes an EXODUS I database file.
C --
C --Expects the output database on unit 11.
include 'exodusII.inc'
INCLUDE 'argparse.inc'
CHARACTER*8 QAINFO(6)
PARAMETER (MAXQA = 100, MAXINF = 100)
c CHARACTER*32 QAREC(4,MAXQA)
c CHARACTER*80 INFO(MAXINF)
C ... Names read in are 32-characters long
CHARACTER*(mxstln) MAMECO(6)
CHARACTER*(mxstln) MAMES(256)
C ... Names written out are 8-characters long, truncate with no warning
CHARACTER*8 NAMECO(6)
CHARACTER*8 NAMELB(256)
CHARACTER*8 NAMES(256)
CHARACTER*80 TITLE
DIMENSION A(1), ia(1)
C --A - the dynamic memory base array
equivalence (a(1), ia(1))
CHARACTER*1 c(1)
CHARACTER*8 cdummy
CHARACTER*5 STRA, STRB
CHARACTER*8 STR8
character*2048 netfil, ndbfil, errmsg
character*(mxstln) name
LOGICAL WHOTIM
real wtime, htime
integer cpuws, iows
LOGICAL MDEBUG
data (qainfo(i), i=1,3) / 'ex2ex1v2', '20210128', 'v 2.10 ' /
data cpuws, iows /0,0/
CALL STRTUP (QAINFO)
CALL BANNER (0, QAINFO,
& 'EXODUS II TO EXODUS I DATABASE'//
& ' TRANSLATOR',' ', ' ')
CALL MDINIT (A)
CALL MCINIT (C)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
MDEBUG = .false.
if (MDEBUG) then
call mlist()
end if
c make netCDF and exodus errors not show up
c call ncpopt (0)
call exopts (0,ierr)
C .. Get filename from command line. If not specified, emit error message
NARG = argument_count()
if (narg .lt. 2) then
CALL PRTERR ('FATAL', 'Filenames not specified.')
CALL PRTERR ('FATAL',
* 'Syntax is: "ex2ex1v2 exo2_file exo1_file"')
GOTO 140
else if (narg .gt. 2) then
CALL PRTERR ('FATAL', 'Too many arguments specified.')
CALL PRTERR ('FATAL',
* 'Syntax is: "ex2ex1v2 exo2_file exo1_file"')
GOTO 140
end if
c open the netcdf file
net = 11
CALL get_argument(1,netfil, lnam)
netid = EXOPEN(netfil(1:lnam), EXREAD, cpuws, iows, vers, nerr)
if (nerr .lt. 0) then
errmsg = 'Database "'//netfil(:lnam)//'" does not exist.'
CALL PRTERR ('FATAL', errmsg(:lenstr(errmsg)))
call exerr('ex2ex1v2', errmsg, exlmsg)
goto 140
endif
write(*,*) 'Input file name: ',netfil(1:lnam)
call exinq (netid, EXVERS, idummy, exversion, name, nerr)
write(*,'(A,F6.3)')
& 'This database was created by ExodusII version ', exversion
C open the output database and write the initial variables
NDB = 20
CALL get_argument(2,ndbfil, lnam)
open(unit=ndb, file=ndbfil(:lnam), form='unformatted',
* status='unknown', iostat=ierr)
IF (IERR .NE. 0) THEN
errmsg = 'Error opening output file "'//ndbfil(:lnam)//'".'
CALL PRTERR ('FATAL', errmsg(:LENSTR(errmsg)))
GOTO 140
END IF
write(*,*) 'Output file name: ',ndbfil(1:lnam)
c get initialization parameters from regular netcdf file
CALL EXGINI (netid, title, ndim, numnp, numel,
& nelblk, numnps, numess, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgini', exlmsg)
goto 140
endif
c get the length of the node sets node list
if (numnps .gt. 0) then
CALL EXINQ (netid, EXNSNL, lnpsnl, dummy, cdummy, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exqini', exlmsg)
goto 140
endif
else
lnpsnl = 0
endif
if (numess .gt. 0) then
c get the length of the side sets node list
CALL EXINQ (netid, EXSSNL, lessnl, dummy, cdummy, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exqini', exlmsg)
goto 140
endif
c get the length of the side sets distribution factor list
CALL EXINQ (netid, EXSSDF, lessdl, dummy, cdummy, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exqini', exlmsg)
goto 140
endif
c get the length of the side sets element list
CALL EXINQ (netid, EXSSEL, lessel, dummy, cdummy, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exqini', exlmsg)
goto 140
endif
else
lessnl = 0
lessel = 0
lessdl = 0
endif
c write the initialization information to the EXODUS 1.0 database
CALL DBOINI (NDB, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
& NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL)
CALL DBPINI ('TIS', NDB, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
& NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL,
& IDUM, IDUM, IDUM, IDUM)
C --Read the coordinates
CALL MDRSRV ('XN', KXN, NUMNP)
CALL MDRSRV ('YN', KYN, NUMNP)
IF (NDIM .GE. 3) THEN
CALL MDRSRV ('ZN', KZN, NUMNP)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
c write(*,*)' ************************* NDIM: ',ndim
CALL EXGCOR(netid, a(kxn), a(kyn), a(kzn), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgcor', exlmsg)
goto 140
endif
CALL DBOXYZ (NDB, NDIM, NUMNP, A(KXN), A(KYN), A(KZN))
CALL MDDEL ('XN')
CALL MDDEL ('YN')
CALL MDDEL ('ZN')
ELSE
CALL EXGCOR(netid, a(kxn), a(kyn), dummy, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgcor', exlmsg)
goto 140
endif
CALL DBOXYZ (NDB, NDIM, NUMNP, A(KXN), A(KYN), dummy)
CALL MDDEL ('XN')
CALL MDDEL ('YN')
ENDIF
C --Read the element order map
CALL MDRSRV ('MAPEL', KMAPEL, NUMEL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
CALL EXGMAP (netid, a(KMAPEL), nerr)
if (nerr .ne. 0) then
if (nerr .eq. 17) then
C -- no element order map in the EXODUS II file; create a dummy one
do 30 i=1,numel
ia(kmapel+i-1) = i
30 continue
else
goto 140
endif
endif
CALL DBOMAP (NDB, NUMEL, A(KMAPEL))
CALL MDDEL ('MAPEL')
c Read in the element block ID array
call MDRSRV ('IDELB', kidelb, nelblk)
call exgebi (netid, a(kidelb), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgebi', exlmsg)
goto 140
endif
C --Read the element blocks
CALL MDRSRV ('NUMELB', KNELB, NELBLK)
CALL MDRSRV ('LINK', KLINK, 0)
CALL MDRSRV ('ATRIB', KATRIB, 0)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
nel = 0
DO 50 IELB = 1, NELBLK
CALL EXGELB (netid, a(kidelb+ielb-1), name,
& a(knelb+ielb-1), numlnk, numatr, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgelb', exlmsg)
goto 140
endif
namelb(ielb) = name(:8)
call getin (ia(knelb+ielb-1),num)
if (numlnk .gt. 0) then
CALL MDLONG ('LINK', KLINK, num*numlnk)
CALL EXGELC (netid, a(kidelb+ielb-1),
& a(klink), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgelc', exlmsg)
goto 140
endif
end if
if (numatr .gt. 0) then
CALL MDLONG ('ATRIB', KATRIB, num*numatr)
CALL EXGEAT (netid, a(kidelb+ielb-1), a(katrib), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgeat', exlmsg)
goto 140
endif
end if
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
CALL DBOELB (NDB, IELB, IELB,
& a(kidelb+ielb-1), A(KNELB+IELB-1), NUMLNK, NUMATR,
& A(KLINK), A(KATRIB))
nel=nel+num
CALL MDLONG ('LINK', klink, 0)
CALL MDLONG ('ATRIB', katrib, 0)
50 CONTINUE
CALL MDDEL ('LINK')
CALL MDDEL ('ATRIB')
IF (NEL .NE. NUMEL) THEN
CALL INTSTR (1, 0, NEL, STRA, LSTRA)
CALL INTSTR (1, 0, NUMEL, STRB, LSTRB)
CALL PRTERR ('WARNING',
& 'NUMBER OF ELEMENTS IN BLOCK = ' // STRA(:LSTRA)
& // ' does not match TOTAL = ' // STRB(:LSTRB))
END IF
C --Read the node sets
CALL MDRSRV ('IDNPS', KIDNS, NUMNPS) ! Node set ids array
CALL MDRSRV ('NNNPS', KNNNS, NUMNPS) ! Node set node count array
CALL MDRSRV ('NDNPS', KNDNS, NUMNPS) ! Node set df count array
CALL MDRSRV ('IXNNPS', KIXNNS, NUMNPS) ! Node set nodes index array
CALL MDRSRV ('IXDNPS', KIXDNS, NUMNPS) ! Node set df index array
CALL MDRSRV ('LSTNPS', KLSTNS, LNPSNL) ! Node set node list array
CALL MDRSRV ('FACNPS', KFACNS, LNPSNL) ! Node set df list array
CALL MDRSRV ('XFACNP', KXFACN, LNPSNL) ! Expanded df list array
CALL MDSTAT (NERR, MEM)
if (numnps .gt. 0) then
call exgcns (netid, a(kidns), a(knnns), a(kndns), a(kixnns),
& a(kixdns), a(klstns), a(kfacns), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgcns', exlmsg)
goto 140
endif
endif
C Massage node sets distribution factors to include '1' for node sets
C without Dfs by walking KNDNS array, checking for 0, and filling where
C necessary.
do 64 i=0, numnps-1
if (ia(kndns+i) .eq. 0) then
do 60 ii=0, ia(knnns+i)-1
a(kxfacn+ia(kixnns+i)-1+ii) = 1.0! Force unity distribution factor
60 continue
else
do 62 ii=0, ia(kndns+i)-1
a(kxfacn+ia(kixnns+i)-1+ii) = a(kfacns+ia(kixdns+i)-1+ii)
62 continue
endif
64 continue
CALL DBONPS (NDB, NUMNPS, LNPSNL,
& A(KIDNS), A(KNNNS), A(KIXNNS), A(KLSTNS), A(KXFACN))
CALL MDDEL ('IDNPS')
CALL MDDEL ('NNNPS')
CALL MDDEL ('NDNPS')
CALL MDDEL ('IXNNPS')
CALL MDDEL ('IXDNPS')
CALL MDDEL ('LSTNPS')
CALL MDDEL ('FACNPS')
CALL MDDEL ('XFACNP')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
C --Read the side sets
CALL MDRSRV ('IDESS', KIDSS, NUMESS) ! side set id array
c write(*,*)'side set id array size: ',numess
CALL MDRSRV ('NEESS', KNESS, NUMESS) ! number of ss elems array
c write(*,*)'number of side set elements array size: ',numess
CALL MDRSRV ('NDESS', KNDSS, NUMESS) ! number of dist factors array
c write(*,*)'number of dist factors array size: ',numess
CALL MDRSRV ('NNESS', KNNSS, NUMESS) ! number of nodes array
c write(*,*)'number of side set nodes array size: ',numess
CALL MDRSRV ('IXEESS', KIXESS, NUMESS) ! index into elements array
c write(*,*)'index into side set elements array size: ',numess
CALL MDRSRV ('IXDESS', KIXDSS, NUMESS) ! index into dist factors array
c write(*,*)'index into side set dist factors array size: ',numess
CALL MDRSRV ('IXNESS', KIXNSS, NUMESS) ! index into nodes array
c write(*,*)'index into side set nodes array size: ',numess
CALL MDRSRV ('LTEESS', KLTESS, LESSEL) ! element list
c write(*,*)'side set element list array size: ',lessel
CALL MDRSRV ('LTNESS', KLTNSS, LESSNL) ! node list (21 is max possible)
c write(*,*)'side set node list array size: ',lessnl
CALL MDRSRV ('LTNNSS', KLTNNS, LESSEL) ! node count array
c write(*,*)'side set node count array size: ',lessel
CALL MDRSRV ('LTSESS', KLTSSS, LESSEL) ! side list
c write(*,*)'side set side list array size: ',lessel
CALL MDRSRV ('FACESS', KFACSS, LESSDL) ! dist factors list
c write(*,*)'side set dist factors list array size: ',lessdl
CALL MDRSRV ('XFACES', KXFACS, LESSNL) ! dist factors list(w/all DF)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
if (numess .gt. 0) then
call exgcss (netid, a(kidss), a(kness), a(kndss),
& a(kixess), a(kixdss),
& a(kltess), a(kltsss), a(kfacss), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgcss', exlmsg)
goto 140
endif
C Convert sides to nodes
isoff = 0 ! offset into element list for current side set
nodcnt = 0 ! node count for current side set
do 104 i=0,numess-1 ! loop through ss elem blks
ia(kixnss+i)=nodcnt+1 ! update index array
call exgsp(netid,ia(kidss+i),nsess,ndess,nerr)! get num of sides & df
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgsp', exlmsg)
goto 140
endif
c write(*,*)'SS ID: ',ia(kidss+i)
c write(*,*)' # of sides: ',nsess
c write(*,*)' # of dist factors: ',ndess
call exgssn(netid,ia(kidss+i),a(kltnns+isoff),
& a(kltnss+nodcnt),nerr) ! get side set nodes
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgssn', exlmsg)
goto 140
endif
nness = 0
do 102 ii=0,nsess-1 ! sum node counts to
nness=nness+ia(kltnns+isoff+ii) ! calculate next index
102 continue
c write(*,*)' # of nodes: ',nness
ia(knnss+i)=nness
nodcnt=nodcnt+nness
isoff=isoff+nsess
104 continue
endif
C Massage side sets distribution factors to include '1' for side sets
C without Dfs by walking KNDSS array, checking for 0, and filling where
C necessary.
do 110 i=0, numess-1
if (ia(kndss+i) .eq. 0) then
do 106 ii=0, ia(knnss+i)-1
a(kxfacs+ia(kixnss+i)-1+ii) = 1.0! Force unity distribution factor
106 continue
else
do 108 ii=0, ia(knnss+i)-1
a(kxfacs+ia(kixnss+i)-1+ii) = a(kfacss+ia(kixdss+i)-1+ii)
108 continue
endif
110 continue
CALL DBOESS (NDB, NUMESS, LESSEL, LESSNL,
& A(KIDSS), A(KNESS), A(KNNSS), A(KIXESS), A(KIXNSS),
& A(KLTESS), A(KLTNSS), A(KXFACS))
CALL MDDEL ('IDESS')
CALL MDDEL ('NEESS')
CALL MDDEL ('NDESS')
CALL MDDEL ('NNESS')
CALL MDDEL ('IXEESS')
CALL MDDEL ('IXDESS')
CALL MDDEL ('IXNESS')
CALL MDDEL ('LTEESS')
CALL MDDEL ('LTNESS')
CALL MDDEL ('LTNNSS')
CALL MDDEL ('LTSESS')
CALL MDDEL ('FACESS')
CALL MDDEL ('XFACES')
C --Read the QA records
nqarec = 0
call exinq (netid, EXQA, nqarec, r, name, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exinq', exlmsg)
goto 140
endif
if (nqarec .gt. 0 .and. nqarec .le. MAXQA) then
call mcrsrv('QARECS', kqarec, 4*nqarec*8)
call mcrsrv('QATMP', kqatmp, 4*nqarec*mxstln)
call mcstat(nerr, mem)
if (nerr .ne. 0) goto 130
else
kqarec = 1
end if
if (nqarec .gt. MAXQA) nqarec = 0
ninfo = 0
call exinq (netid, EXINFO, ninfo, r, name, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exinq', exlmsg)
goto 140
endif
if (ninfo .gt. 0 .and. ninfo .le. MAXINF) then
call mcrsrv('INFO', kinfo, ninfo*mxlnln)
call mcstat(nerr, mem)
if (nerr .ne. 0) goto 130
else
kinfo = 1
end if
if (ninfo .gt. MAXINF) ninfo = 0
call rdqain (netid, nqarec, c(kqatmp), ninfo, c(kinfo))
if (nqarec .gt. 0)
& call resize (nqarec, c(kqarec), c(kqatmp))
IF (NQAREC .GE. 0) THEN
CALL DBOQA (NDB, NQAREC, c(kqarec), NINFO, c(kinfo))
END IF
C --Read in the number of element variable names
call exgvp (netid, 'e', nvarel, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvp', exlmsg)
goto 140
endif
C --Read in the number of global variable names
call exgvp (netid, 'g', nvargl, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvp', exlmsg)
goto 140
endif
C --Read in the number of nodal variable names
call exgvp (netid, 'n', nvarnp, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvp', exlmsg)
goto 140
endif
nvarhi = 0
call mdrsrv ('ISEVOK', kievok, nvarel*nelblk)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
c read in the element variable truth table
if (nvarel .gt. 0) then
call exgvtt (netid, nelblk, nvarel, a(kievok), nerr)
if (nerr .gt. 0) then
if (nvarel .gt. 0) then
write (*,'(4x,"must have element variable truth table")')
goto 140
endif
endif
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvtt', exlmsg)
goto 140
endif
end if
c read in the element variable names
ixev = 1
if (nvarel .gt. 0) then
call exgvan (netid, 'e', nvarel,mames(ixev), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvan', exlmsg)
goto 140
endif
end if
c read in the global variable names
ixgv = ixev + nvarel
if (nvargl .gt. 0) then
call exgvan (netid, 'g', nvargl,mames(ixgv), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvan', exlmsg)
goto 140
endif
end if
c read in the nodal variable names
ixnv = ixgv + nvargl
if (nvarnp .gt. 0) then
call exgvan (netid, 'n', nvarnp, mames(ixnv), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgvan', exlmsg)
goto 140
endif
end if
c read in the history variable names
ixhv = ixnv + nvarnp
c read coordinate names
call exgcon (netid, mameco, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgcon', exlmsg)
goto 140
endif
CALL DBPINI ('V', NTXT, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
& NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL,
& NVARHI, NVARGL, NVARNP, NVAREL)
do 111 i=1, ndim
nameco(i) = mameco(i)(:8)
111 continue
do 112 i=1, (nvarhi+nvargl+nvarnp+nvarel)
names(i) = mames(i)(:8)
112 continue
CALL DBONAM (NDB, NDIM, NELBLK, NVARHI, NVARGL, NVARNP, NVAREL,
& nameco, namelb,
& names(ixhv), names(ixgv), names(ixnv), names(ixev),
& A(KIEVOK))
CALL MDRSRV ('VARHI', KVARHI, NVARHI)
CALL MDRSRV ('VARGL', KVARGL, NVARGL)
CALL MDRSRV ('VARNP', KVARNP, NVARNP * NUMNP)
CALL MDRSRV ('VAREL', KVAREL, NVAREL * NUMEL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 130
c read in the number of history time steps and the number of
C whole time steps
call exinq (netid, EXTIMS, ntime, s, name, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exqini', exlmsg)
goto 140
endif
if (ntime .eq. 0) then
write(errmsg,'("GENISIS file - no time steps written")')
call exerr('ex2ex1v2', errmsg, EXPMSG)
goto 140
endif
numstp = ntime
c read the time step information
istep = 0
call exgtim(netid, istep+1, wtime, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgtim', exlmsg)
goto 140
endif
do 300 ihstep=1,numstp
write (*,'(4x,"processing time step ", i4)') ihstep
c get history information
whotim = .true.
call exgtim(netid, ihstep, wtime, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgtim', exlmsg)
goto 140
endif
htime = wtime
c If a whole time step, do global, nodal, and element
c variables for the time step.
if ((whotim) .or. (wtime .eq. htime)) then
whotim =.true.
istep = istep + 1
c get the global variable values
if( nvargl .gt. 0) then
call exggv (netid, istep, nvargl, a(kvargl), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exggv', exlmsg)
goto 140
endif
end if
c get the nodal variable values
do 210 j=1, nvarnp
call exgnv (netid, istep, j, numnp,
& a(kvarnp+(j-1)*numnp), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgnv', exlmsg)
goto 140
endif
210 continue
c get element variable values
if (nvarel .gt. 0) then
ielo=0
do 250 k = 1,nelblk
l=(k-1)*nvarel
do 240 j=1, nvarel
c If truth table indicates element values are available
c for the element variable, get the values for the
c element variable.
if(a(kievok+l +j-1) .ne. 0) then
call exgev (netid, istep, j, a(kidelb+k-1),
& a(knelb+k-1), a(kvarel+ielo), nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgev', exlmsg)
goto 140
endif
call getin (ia(knelb+k-1),num)
ielo = ielo+num
end if
240 continue
250 continue
end if
else
whotim=.false.
end if
CALL DBOSTE (NDB, ihstep, NVARHI, NVARGL, NVARNP, NUMNP,
& NVAREL, NELBLK, a(knelb), a(kievok),
& HTIME, WHOTIM, A(KVARHI), A(KVARGL), A(KVARNP),
& A(KVAREL))
300 continue
call MDDEL ('IDELB')
CALL MDDEL ('VARHI')
CALL MDDEL ('VARGL')
CALL MDDEL ('VARNP')
CALL MDDEL ('VAREL')
CALL MDDEL ('NUMELB')
CALL INTSTR (1, 0, IHSTEP-1, STR8, LSTR)
WRITE (*, 10010) STR8(:LSTR)
10010 FORMAT (/, 4X, A,
& ' time steps have been written to the database')
GOTO 140
130 CONTINUE
CALL MEMERR
GOTO 140
140 CONTINUE
c close all files
CLOSE (NDB, IOSTAT=IDUM)
if (netid .gt. 0 ) call exclos (netid, ierr)
call addlog (QAINFO(1)(:lenstr(QAINFO(1))))
CALL WRAPUP (QAINFO(1))
END
subroutine mlist()
call mdlist(6)
return
end
subroutine rdqain (ndb, nqarec, qarec, ninfo, info)
include 'exodusII.inc'
integer ndb
character*(32) qarec(4,nqarec)
character*(80) info(ninfo)
if (nqarec .gt. 0) then
call exgqa (ndb, qarec, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exgqa', exlmsg)
endif
endif
if (ninfo .gt. 0) then
call exginf (ndb, info, nerr)
if (nerr .lt. 0) then
call exerr('ex2ex1v2', 'Error from exginf', exlmsg)
endif
endif
return
end
C=======================================================================
SUBROUTINE RESIZE (NQAREC, QAREC, QATMP)
C=======================================================================
C --
C --RESIZE - resizes the qa records from length 32 to 8
C --
C --Parameters:
C -- NQAREC - IN - the number of QA records
C -- QAREC - IN - the QA records containing size = 8
C -- QATMP - IN - the QA records containing size = 32
INTEGER NQAREC
CHARACTER*8 QAREC(4,NQAREC)
CHARACTER*32 QATMP(4,NQAREC)
IF (NQAREC .GT. 0) THEN
DO 50 I = 1, NQAREC
DO 75 J = 1, 4
QAREC(J,I) = QATMP(J,I)(:8)
75 CONTINUE
50 CONTINUE
END IF
RETURN
END
subroutine getin (num1,num2)
integer num1(*)
num2=num1(1)
return
end