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.
233 lines
7.4 KiB
233 lines
7.4 KiB
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
|
|
C=======================================================================
|
|
SUBROUTINE WELB (NDBOUT, NELBLK, VISELB, ALLELE, BLKTYP,
|
|
& NUMLNK, NUMATR, LINK, ATRIB, NUMELB, IXELB, IXELBO,
|
|
& IXELEM, NEWNOD, NODIX, IDELB, A, IA, C, MERR)
|
|
C=======================================================================
|
|
|
|
C --The original version of this code was written by
|
|
C --Amy Gilkey - revised 04/19/88
|
|
C --*** RWELB *** (ALGEBRA) Read and write database element blocks
|
|
C --RWELB was modified and renamed to WELB 8/25/95
|
|
C --
|
|
C --WELB writes the element block information to the database.
|
|
C --Deleted elements are removed and nodes are renumbered.
|
|
C --
|
|
C --Parameters:
|
|
C -- NDBOUT - IN - the output database file
|
|
C -- NELBLK - IN - the number of element blocks
|
|
C -- VISELB - IN - true iff element block i is to be written
|
|
C -- ALLELE - IN - true iff all elements are selected
|
|
C -- BLKTYP - IN - element type for each element block
|
|
C -- NUMLNK - IN - Number of nodes per element for each element block
|
|
C -- NUMATR - IN - Number of attributes for each element block
|
|
C -- LINK - IN - Connectivity array for element blocks
|
|
C -- ATRIB - IN - Attribute array for element blocks
|
|
C -- NUMELB - I/O - the number of elements in each block; set if ALLELE
|
|
C -- IXELB - I/O - the cumulative element counts for each
|
|
C -- element block; set if ALLELE
|
|
C -- IXELBO - I/O - the cumulative element counts for each output block;
|
|
C -- set if ALLELE
|
|
C -- IXELEM - IN - the indices of the output elements
|
|
C -- (iff IXELBO <> IXELB)
|
|
C -- NEWNOD - IN - true iff nodes are renumbered
|
|
C -- NODIX(i) - IN - the zoom mesh index for each node (iff NEWNOD)
|
|
C -- A - IN - the dynamic memory array
|
|
C -- MERR - OUT - memory error flag
|
|
|
|
include 'exodusII.inc'
|
|
|
|
INTEGER NDBOUT
|
|
INTEGER NELBLK
|
|
LOGICAL VISELB(NELBLK)
|
|
LOGICAL ALLELE
|
|
CHARACTER*(MXSTLN) BLKTYP(*)
|
|
INTEGER NUMLNK(*)
|
|
INTEGER NUMATR(*)
|
|
INTEGER LINK(*)
|
|
REAL ATRIB(*)
|
|
INTEGER NUMELB(*)
|
|
INTEGER IXELB(0:NELBLK)
|
|
INTEGER IXELBO(0:NELBLK)
|
|
INTEGER IXELEM(*)
|
|
LOGICAL NEWNOD
|
|
INTEGER NODIX(*)
|
|
INTEGER IDELB(*)
|
|
DIMENSION A(1)
|
|
INTEGER IA(1)
|
|
CHARACTER*1 C(1)
|
|
INTEGER MERR
|
|
|
|
CHARACTER*(MXSTLN) NAEB
|
|
INTEGER NELB, EBID, NLNK, NATR
|
|
INTEGER NERR
|
|
|
|
MERR = 0
|
|
ILNK = 0
|
|
IATR = 0
|
|
ISLNK = 0
|
|
ISATR = 0
|
|
|
|
IF (ALLELE) THEN
|
|
IXELB(0) = 0
|
|
IXELBO(0) = 0
|
|
END IF
|
|
|
|
MAXCON = NUMLNK(1)*NUMELB(1)
|
|
MAXATR = NUMATR(1)*NUMELB(1)
|
|
DO 90 I = 1, NELBLK
|
|
NELB = NUMELB(I)
|
|
NLNK = NUMLNK(I)
|
|
NATR = NUMATR(I)
|
|
IF (NELB*NLNK .GT. MAXCON) MAXCON = NELB*NLNK
|
|
IF (NELB*NATR .GT. MAXATR) MAXATR = NELB*NATR
|
|
90 CONTINUE
|
|
|
|
if (allele) then
|
|
call expclb(ndbout, IDELB, BLKTYP, NUMELB, NUMLNK, NUMATR,
|
|
* .TRUE., IERR)
|
|
else
|
|
call mdrsrv('IDSCR', kidscr, nelblk)
|
|
call mdrsrv('NUMSCR', knumscr, nelblk)
|
|
call mdrsrv('LNKSCR', klnkscr, nelblk)
|
|
call mdrsrv('NATSCR', knatscr, nelblk)
|
|
call mcrsrv('NAMSCR', knamscr, nelblk*mxstln)
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) then
|
|
call memerr
|
|
MERR = 1
|
|
return
|
|
end if
|
|
C Loop from 1 to number of element blocks
|
|
ielbo = 0
|
|
DO IELB = 1, NELBLK
|
|
if (viselb(ielb)) then
|
|
ielbo = ielbo + 1
|
|
itmp = isetarr(ia(kidscr), ielbo, idelb(ielb))
|
|
itmp = isetarr(ia(knatscr), ielbo, numatr(ielb))
|
|
itmp = isetarr(ia(klnkscr), ielbo, numlnk(ielb))
|
|
call cpynam(blktyp(ielb), c(knamscr), ielbo)
|
|
NELBO = IXELBO(IELB) - IXELBO(IELB-1)
|
|
itmp = isetarr(ia(knumscr), ielbo, nelbo)
|
|
end if
|
|
end do
|
|
C ... Wrap this call to handle character*(1) vs character*(mxstln) weirdness
|
|
call blkout(ndbout, ia(kidscr), c(knamscr), ia(knumscr),
|
|
* ia(klnkscr), ia(knatscr))
|
|
call mddel('IDSCR')
|
|
call mddel('NUMSCR')
|
|
call mddel('LNKSCR')
|
|
call mddel('NATSCR')
|
|
call mcdel('NAMSCR')
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) then
|
|
call memerr
|
|
MERR = 1
|
|
return
|
|
end if
|
|
end if
|
|
|
|
C Loop from 1 to number of element blocks
|
|
DO 100 IELB = 1, NELBLK
|
|
|
|
C These variable must be set here in order to calculate
|
|
C the correct indices for the LINK and ATRIB arrays
|
|
C The problem arises when the VISIBLE command is used
|
|
C and not all element blocks are visible
|
|
NELB = NUMELB(IELB)
|
|
NLNK = NUMLNK(IELB)
|
|
NATR = NUMATR(IELB)
|
|
ISLNK = ILNK + 1
|
|
ILNK = ILNK + (NLNK * NELB)
|
|
ISATR = IATR + 1
|
|
IATR = IATR + (NATR * NELB)
|
|
|
|
C If write all elements or write this element block
|
|
IF (ALLELE .OR. VISELB(IELB)) THEN
|
|
|
|
EBID = IDELB(IELB)
|
|
NAEB = BLKTYP(IELB)
|
|
|
|
IF (ALLELE) THEN
|
|
IXELB(IELB) = IXELB(IELB-1) + NELB
|
|
IXELBO(IELB) = IXELBO(IELB-1) + NELB
|
|
END IF
|
|
|
|
NELBO = IXELBO(IELB) - IXELBO(IELB-1)
|
|
|
|
if ((NELBO .NE. NELB) .or. NEWNOD) then
|
|
CALL MDRSRV('LNSCR', KLNSCR, MAX(NELB,NELBO)*NLNK)
|
|
CALL MDRSRV('ATRSCR', KATSCR, MAX(NELB,NELBO)*NATR)
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) then
|
|
call memerr
|
|
MERR = 1
|
|
return
|
|
end if
|
|
else
|
|
klnscr = 1
|
|
katscr = 1
|
|
end if
|
|
|
|
IEL = IXELB(IELB-1)+1
|
|
IELO = IXELBO(IELB-1)+1
|
|
|
|
C Write element block connectivity array
|
|
C Write element block attributes
|
|
CALL WCONAT (NDBOUT, NELB, NELBO, IEL, IXELEM(IELO),
|
|
& NLNK, NATR, MAX(1,NLNK), MAX(1,NATR),
|
|
& LINK(ISLNK), ATRIB(ISATR), NAEB,
|
|
& EBID, NEWNOD, NODIX,
|
|
& A(KLNSCR), A(KATSCR))
|
|
|
|
IF (nelbo .ne. nelb .or. newnod) THEN
|
|
CALL MDDEL ('LNSCR')
|
|
CALL MDDEL ('ATRSCR')
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) then
|
|
call memerr
|
|
MERR = 1
|
|
return
|
|
end if
|
|
END IF
|
|
|
|
END IF
|
|
100 CONTINUE
|
|
|
|
RETURN
|
|
END
|
|
|
|
integer function isetarr(intarr, ipos, ival)
|
|
|
|
integer intarr(*)
|
|
integer ipos
|
|
|
|
intarr(ipos) = ival
|
|
isetarr = ival
|
|
return
|
|
end
|
|
|
|
subroutine cpynam(namei, nameo, idx)
|
|
include 'exodusII.inc'
|
|
|
|
character*(mxstln) namei
|
|
character*(mxstln) nameo(*)
|
|
nameo(idx) = namei
|
|
return
|
|
end
|
|
|
|
subroutine blkout(ndbout, idelb, names, numelb, numlnk, numatr)
|
|
include 'exodusII.inc'
|
|
integer idelb(*)
|
|
character*(mxstln) names(*)
|
|
integer numelb(*)
|
|
integer numlnk(*)
|
|
integer numatr(*)
|
|
call expclb(ndbout, idelb, names, numelb, numlnk, numatr,
|
|
* .true., ierr)
|
|
return
|
|
end
|
|
|