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 C======================================================================= PROGRAM EX1EX2V2 C======================================================================= C --*** EX1EX2V2 *** EXODUS I to EXODUS II translator C -- C --EX1EX2V2 reads EXODUS I database and writes an EXODUS II V2.03 database C -- include 'exodusII.inc' INCLUDE 'argparse.inc' CHARACTER*8 QAINFO(6) CHARACTER*80 TITLE PARAMETER (MAXQA = 100, MAXINF = 100) PARAMETER (MAXDIM=6, MAXELB=512, MAXVAR=512) CHARACTER*8 QAREC(4,MAXQA) CHARACTER*80 INFO(MAXINF) CHARACTER*8 NAMECO(MAXDIM) CHARACTER*8 NAMELB(MAXELB) CHARACTER*8 NAMES(MAXVAR) character*2048 exofil, netfil, scratch character*8 name integer cpuws,wsout DIMENSION A(1) DIMENSION IA(1) EQUIVALENCE (A(1), IA(1)) C --A - the dynamic memory base array CHARACTER*8 STR8 LOGICAL EXODUS LOGICAL WHOTIM data (qainfo(i), i=1,3) / 'ex1ex2v2', '20210128', 'v 2.13 ' / data iin,iout/5,6/ data nsteps /0/ data cpuws,wsout /0,0/ CALL STRTUP (QAINFO) CALL BANNER (0, QAINFO, & 'EXODUS I TO EXODUS II FILE TRANSLATOR', & ' ', ' ') C --Open the input and output files NDB = 11 NET = 20 c make netCDF and exodus errors not show up 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: "ex1ex2v2 exo1_file exo2_file"') GOTO 140 else if (narg .gt. 2) then CALL PRTERR ('FATAL', 'Too many arguments specified.') CALL PRTERR ('FATAL', * 'Syntax is: "ex1ex2v2 exo1_file exo2_file"') GOTO 140 end if CALL get_argument(1,exofil, lnam) write(*,*)'Input filename: ',exofil(1:lnam) open(unit=ndb, file=exofil(:lnam), form='unformatted', * status='old', iostat=ierr) IF (IERR .NE. 0) THEN SCRATCH = 'Database "'//exofil(:lnam)//'" does not exist.' CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH))) GOTO 140 END IF CALL get_argument(2,netfil, lnam) write(*,*)'Output filename: ',netfil(1:lnam) wsout = 8 write(*,*)'Output word size: ',wsout CALL MDINIT (A) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 CALL MDFILL(-1) C --Read the initial variables from exodusI database CALL DBIINI (NDB, '*', NVERS, TITLE, NDIM, NUMNP, NUMEL, NELBLK, & NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL, *150) c create the a netcdf file idexo = excre (netfil(1:lnam), EXCLOB, cpuws, wsout, ierr) if (ierr .lt. 0) then call exerr('ex1ex2v2','Error from excre', EXLMSG) go to 140 end if c write initial variables to netcdf file call expini (idexo, title, ndim, numnp, numel, nelblk, numnps, & numess, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2',' Error from expini', EXLMSG) goto 150 end if CALL DBPINI ('NTIS', NDB, TITLE, NDIM, NUMNP, NUMEL, NELBLK, & NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL, & IDUM, IDUM, IDUM, IDUM) WRITE(*,*) C --Read the coordinates from the exodusI database CALL MDRSRV ('XN', KXN, NUMNP) CALL MDRSRV ('YN', KYN, NUMNP) IF (NDIM .GE. 3) THEN CALL MDRSRV ('ZN', KZN, NUMNP) ELSE KZN = 1 END IF CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 CALL DBIXYZ (NDB, '*', NDIM, NUMNP, A(KXN), A(KYN), A(KZN), *150) c write the coordinates to the regular netcdf file call expcor (idexo, a(kxn), a(kyn), a(kzn), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expcor', EXLMSG) goto 150 end if CALL MDDEL ('XN') CALL MDDEL ('YN') IF (NDIM .GE. 3) CALL MDDEL ('ZN') C --Read the element order map from the exodusI database CALL MDRSRV ('MAPEL', KMAPEL, NUMEL) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 CALL DBIMAP (NDB, '*', NUMEL, IA(KMAPEL), *150) c write the element order map to the regular netcdf file call expmap (idexo, ia(kmapel), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expmap', EXLMSG) goto 150 end if CALL MDDEL ('MAPEL') C --Read the element blocks CALL MDRSRV ('NUMELB', KNELB, NELBLK) CALL MDRSRV ('LINK', KLINK, 0) CALL MDRSRV ('ATRIB', KATRIB, 0) call MDRSRV ('IDELB', KIDELB, NELBLK) call MDRSRV ('NUMLNK', KNMLNK, NELBLK) call MDRSRV ('NUMATR', KNMATR, NELBLK) CALL MDSTAT (IERR, MEM) IF (IERR .GT. 0) goto 150 CALL DBIELB (NDB, '*', 1, nelblk, IA(KIDELB), IA(KNELB), * IA(KNMLNK), IA(KNMATR), A, KLINK, KATRIB, *150) CALL MDSTAT (IERR, MEM) IF (IERR .GT. 0) goto 150 C --Read the nodal points sets CALL MDRSRV ('IDNPS', KIDNS, NUMNPS) CALL MDRSRV ('NNNPS', KNNNS, NUMNPS) CALL MDRSRV ('IXNNPS', KIXNNS, NUMNPS) CALL MDRSRV ('LSTNPS', KLSTNS, LNPSNL) CALL MDRSRV ('FACNPS', KFACNS, LNPSNL) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 CALL DBINPS (NDB, '*', NUMNPS, LNPSNL, & IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLSTNS), A(KFACNS), *150) C --Read the element side sets CALL MDRSRV ('IDESS', KIDSS, NUMESS) CALL MDRSRV ('NEESS', KNESS, NUMESS) CALL MDRSRV ('NNESS', KNNSS, NUMESS) CALL MDRSRV ('IXEESS', KIXESS, NUMESS) CALL MDRSRV ('IXNESS', KIXNSS, NUMESS) CALL MDRSRV ('LTEESS', KLTESS, LESSEL) CALL MDRSRV ('LTNESS', KLTNSS, LESSNL) CALL MDRSRV ('FACESS', KFACSS, LESSNL) CALL MDRSRV ('SACESS', KLTSSS, LESSEL) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 CALL DBIESS (NDB, '*', NUMESS, LESSEL, LESSNL, & IA(KIDSS), IA(KNESS), IA(KNNSS), IA(KIXESS), IA(KIXNSS), & IA(KLTESS), IA(KLTNSS), A(KFACSS), *150) C --Read the QA and info records C ... Exodus set to .FALSE. if end of file during this read CALL DBIQA (NDB, '*', MAXQA, MAXINF, NQAREC, QAREC, NINFO, INFO, & EXODUS, *150) c********************************************************************** C --Read the database names if (exodus) then C ... Exodus set to .FALSE. if end of file during this read CALL DBINAM (NDB, '*', NDIM, NELBLK, & NNDIM, NNELB, NVARHI, NVARGL, NVARNP, NVAREL, & NAMECO, NAMELB, NAMES, IXHV, IXGV, IXNV, IXEV, & A, KIEVOK, EXODUS, *150) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 if (.not. exodus) then nvarhi = 0 nvargl = 0 nvarnp = 0 nvarel = 0 end if CALL DBPINI ('V', NDB, TITLE, NDIM, NUMNP, NUMEL, NELBLK, & NUMNPS, LNPSNL, NUMESS, LESSEL, LESSNL, & NVARHI, NVARGL, NVARNP, NVAREL) else C ... Assign dummy coordinate names... NAMECO(1) = 'X' NAMECO(2) = 'Y' NAMECO(3) = 'Z' C ... Try to infer the element block names also do 50 ielb = 0, nelblk-1 namelb(ielb+1) = 'UNKNOWN' npe = ia(knmlnk+ielb) if (ndim .eq. 2) then if (npe .eq. 4) then namelb(ielb+1) = 'QUAD' else if (npe .eq. 8) then namelb(ielb+1) = 'QUAD8' else if (npe .eq. 3) then namelb(ielb+1) = 'TRIANGLE' end if else if (ndim .eq. 3) then if (npe .eq. 4) then if (ia(knmatr+ielb) .eq. 0) then namelb(ielb+1) = 'TETRA' else namelb(ielb+1) = 'SHELL' end if else if (npe .eq. 8) then if (ia(knmatr+ielb) .eq. 0) then namelb(ielb+1) = 'HEX' else namelb(ielb+1) = 'SHELL8' end if else if (npe .eq. 6) then namelb(ielb+1) = 'WEDGE' end if end if 50 continue END IF c********* ioff = 0 DO 100 IELB = 1, NELBLK c write element block parameters to the netcdf file call expelb (IDEXO, IA(KIDELB+IELB-1), namelb(IELB), 1 IA(KNELB+IELB-1), 2 IA(KNMLNK+IELB-1), IA(KNMATR+IELB-1), IERR) IF (IERR .lt. 0) THEN CALL exerr('ex1ex2v2','Error from expelb',EXLMSG) ENDIF c write block attributes to the netcdf file IF (IA(KNMATR+IELB-1) .GT. 0) THEN call expeat (IDEXO, IA(KIDELB+IELB-1), A(KATRIB+ioff), IERR) IF (IERR .lt. 0) THEN CALL exerr ('rdelb','Error from expeat', EXLMSG) ENDIF end if ioff = ioff + ia(knmatr + ielb-1) * ia(knelb + ielb-1) c CALL MDLONG ('LINK', KLINK, 0) c CALL MDLONG ('ATRIB', KATRIB, 0) 100 CONTINUE iptr = klink do 101 ielb = 1, nelblk c write the element block connectivity to the netcdf file c skipping null element blocks if (IA(KNELB+IELB-1) .eq. 0) then write(*,*)'Null element block: ',ielb else call expelc (idexo, ia(kidelb+ielb-1), ia(iptr), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expelc', exlmsg) goto 150 end if end if iptr = iptr + ( ia(knmlnk+ielb-1) * ia(knelb+ielb-1) ) 101 continue c write out the nodal point sets to the regular netcdf file c Note: For exodus I data, dist factors always exist. if (numnps .gt. 0) then call expcns (idexo, ia(kidns), ia(knnns), ia(knnns), * ia(kixnns), ia(kixnns), ia(klstns), a(kfacns), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expcns', exlmsg) goto 150 end if endif c write element side sets c Note: Exodus II V2.0 represents a major change for side sets: c They are represented as side IDs - not node IDs and c must be translated. if (numess .gt. 0) then call excn2s (idexo, ia(kness), ia(knnss), ia(kixess), 1 ia(kixnss), ia(kltess), ia(kltnss), ia(kltsss), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from excn2s', exlmsg) goto 150 end if call expcss (idexo, ia(kidss), ia(kness), ia(knnss), ia(kixess), & ia(kixnss), ia(kltess), ia(kltsss), a(kfacss), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expcss', exlmsg) goto 150 end if endif call mddel ('LINK') call mddel ('NUMLNK') CALL MDDEL ('ATRIB') CALL MDDEL ('NUMATR') CALL MDDEL ('IDNPS') CALL MDDEL ('NNNPS') CALL MDDEL ('IXNNPS') CALL MDDEL ('LSTNPS') CALL MDDEL ('FACNPS') CALL MDDEL ('IDESS') CALL MDDEL ('NEESS') CALL MDDEL ('NNESS') CALL MDDEL ('IXEESS') CALL MDDEL ('IXNESS') CALL MDDEL ('LTEESS') CALL MDDEL ('LTNESS') CALL MDDEL ('FACESS') CALL MDDEL ('SACESS') CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 130 c write the QA records IF (NQAREC .GT. 0) then call expqa (idexo, NQAREC, QAREC, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expqa', exlmsg) goto 150 end if end if c write the info records if (NINFO .gt. 0) then call expinf (idexo, ninfo, info, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expinf', exlmsg) goto 150 end if end if c********************************************************************** c write coordinate names call expcon (idexo, nameco, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expcon', exlmsg) goto 150 end if if (.not. EXODUS) goto 150 c write the number of global variables if (nvargl .gt. 0) then call expvp (idexo, 'G', nvargl, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvp', exlmsg) goto 140 end if c write the global variable names call expvan (idexo, 'G', nvargl, names(ixgv), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvan', exlmsg) goto 140 end if end if c write the number of nodal variables if (nvarnp .gt. 0) then call expvp (idexo, 'N', nvarnp, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvp', exlmsg) goto 140 end if c write the nodal variable names call expvan (idexo, 'N', nvarnp, names(ixnv), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvan', exlmsg) goto 140 end if end if c write the number of element variables if (nvarel .gt. 0) then call expvp (idexo, 'E', nvarel, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvp', exlmsg) goto 140 end if c write the element variable names call expvan (idexo, 'E', nvarel, names(ixev), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from exvan', exlmsg) goto 140 end if end if c write the element variable truth table call mdrsrv ('ebids', kebids, nelblk) call exgebi (idexo, ia(kebids), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from exgebi', exlmsg) goto 140 end if if (nvarel .gt. 0) then call expvtt(idexo, nelblk, nvarel, ia(kievok), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expvtt', exlmsg) goto 140 end if end if call mddel ('ebids') IF (.NOT. EXODUS) GOTO 140 C --Read the database time steps 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 nwstep = 0 nhstep = 0 110 CONTINUE IF (.TRUE.) THEN CALL DBISTE (NDB, '*', NhSTEP+1, & NVARHI, NVARGL, NVARNP, NUMNP, NVAREL, NELBLK, & ia(knelb), IA(KIEVOK), TIME, WHOTIM, A(KVARHI), & A(KVARGL), A(KVARNP), A(KVAREL), *120) nhstep = nhstep + 1 if (whotim) then nwstep = nwstep+1 write (*,'(4x, "processing whole time step ", i4)') nwstep c write global variables if (nvargl .gt. 0) then call expgv (idexo, nwstep, nvargl, a(kvargl), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expgv', exlmsg) goto 140 end if end if c write nodal variable values if (nvarnp .gt. 0) then do 111 i= 1,nvarnp call expnv (idexo, nwstep, i, numnp, & a(kvarnp+(i-1)*numnp), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from expnv', exlmsg) goto 140 end if 111 continue end if c write element variable values if (nvarel .gt. 0) then call putev (idexo, nwstep, nelblk, nvarel, & ia(knelb), a(kvarel), ia(kidelb), ia(kievok), ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from putev', exlmsg) goto 140 end if end if c write whole time step call exptim (idexo, nwstep, time, ierr) if (ierr .lt. 0) then call exerr ('ex1ex2v2','Error from exptim', exlmsg) goto 140 end if end if GOTO 110 END IF 120 CONTINUE call mddel ('IDELB') WRITE (STR8, '(I8)', IOSTAT=K) NwSTEP CALL SQZSTR (STR8, LSTR) WRITE (*, 10010) STR8(:LSTR) 10010 FORMAT (/, 4X, A, & ' time steps have been written to the file') GOTO 140 130 CONTINUE CALL MEMERR CALL MDSTAT (NERR, MEM) WRITE(*,10020) QAINFO(1), MEM 10020 FORMAT(1x,A8,' currently using ', I10, ' words of memory') 140 CONTINUE 150 if (idexo .gt. 0) call exclos (idexo, ierr) IF (NDB .NE. 0) CLOSE (NDB, IOSTAT=K) call addlog (QAINFO(1)(:lenstr(QAINFO(1)))) CALL WRAPUP (QAINFO(1)) STOP END