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