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
SUBROUTINE WRJERR (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
& NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, NODES, NELEMS, NNFLG,
& NNPTR, NNLEN, NSFLG, NSPTR, NSLEN, NVPTR, NVLEN, NSIDEN,
& MAPDXG, XN, YN, NXK, MAT, MAPGXD, MATMAP, NBCNOD, NNLIST,
& NBCSID, NSLIST, NVLIST, NUMMAT, LINKM, TITLE, ERR, EIGHT, NINE)
C***********************************************************************
C SUBROUTINE WRJERR = WRITES JOE'S ERROR DATABASE MESH OUTPUT FILE
C***********************************************************************
DIMENSION XN (NPNODE), YN (NPNODE), NXK (NNXK, NPELEM)
DIMENSION MAT (NPELEM)
DIMENSION NODES (NPNBC), NELEMS (NPSBC), NSIDEN (NPSBC)
DIMENSION NNFLG (MXNFLG), NNLEN (MXNFLG), NNPTR (MXNFLG)
DIMENSION NSFLG (MXSFLG), NSLEN (MXSFLG), NSPTR (MXSFLG)
DIMENSION NVLEN (MXSFLG), NVPTR (MXSFLG), LINKM (2, (MS+MR))
DIMENSION MAPDXG (NPNODE), MAPGXD (NPNODE), MATMAP (3, NPREGN)
DIMENSION IHOLD (9)
CHARACTER*72 TITLE, DUMMY
LOGICAL ERR, EIGHT, NINE, FOUND
ERR = .TRUE.
C WRITE OUT HEADER TITLE AND INFORMATION
CALL INQSTR ('TITLE: ',TITLE)
WRITE (IUNIT, 10000, ERR = 290)TITLE
WRITE (IUNIT, 10010, ERR = 290)
C WRITE OUT NODE BLOCK
WRITE (IUNIT, 10020, ERR = 290)
Z = 0.
DO 100 I = 1, NNN
WRITE (IUNIT, 10030, ERR = 290)I, XN (I), YN (I), Z
100 CONTINUE
C WRITE OUT ELEMENT BLOCKS
DO 130 I = 1, NUMMAT
CALL GETDUM (MATMAP (1, I), DUMMY, LEN)
WRITE (IUNIT, 10040, ERR = 290)
IF (NXK (3, MATMAP (2, I)) .EQ. 0) THEN
INODE = 2
ELSEIF (NXK (4, MATMAP (2, I)) .EQ. 0) THEN
INODE = 3
ELSEIF (EIGHT) THEN
INODE = 8
ELSEIF (NINE) THEN
INODE = 9
ELSE
INODE = 4
ENDIF
IF (INODE .EQ. 8) THEN
DO 110 KELEM = MATMAP (2, I), MATMAP (3, I)
K = MAPGXD(KELEM)
WRITE (IUNIT, 10050, ERR = 290) K, NXK (1, KELEM),
& NXK (3, KELEM), NXK (5, KELEM), NXK (7, KELEM),
& NXK (2, KELEM), NXK (4, KELEM), NXK (6, KELEM),
& NXK (8, KELEM)
110 CONTINUE
ELSE
DO 120 KELEM = MATMAP (2, I), MATMAP (3, I)
K = MAPGXD(KELEM)
WRITE (IUNIT, 10060, ERR = 290) K, (NXK (J, KELEM),
& J = 1, INODE)
120 CONTINUE
ENDIF
130 CONTINUE
C WRITE OUT THE NODAL BOUNDARY CONDITIONS
IF (NBCNOD.GT.0) THEN
WRITE (IUNIT, 10070)
DO 150 I = 1, NBCNOD
J1 = NNPTR (I)
J2 = NNPTR (I)+NNLEN (I)-1
CALL GETDUM (NNFLG (I), DUMMY, LEN)
WRITE (*, 10080) NNFLG(I)
CALL INQSTR ('FIXED DEGREE OF FREEDOM: ',TITLE)
READ (TITLE, '(I10)') INT
DO 140 J = J1, J2
WRITE (IUNIT, 10100, ERR = 290) NODES (J), INT
140 CONTINUE
150 CONTINUE
ENDIF
C WRITE OUT THE SIDE BOUNDARY FLAGS
WRITE (IUNIT, 10120, ERR = 290)
IF (NBCSID.GT.0) THEN
WRITE (IUNIT, 10130, ERR = 290)
C CALL MESSAGE('ELEMENT NUMBERING IS WRITTEN WITH ELEMENT' //
C & BOUNDARY FLAGS')
C CALL INQTRU ('WOULD YOU LIKE TO CHANGE THIS TO NODES', IANS)
C IF (IANS) THEN
C DO 190 I = 1, NBCSID
C J1 = NVPTR (I)
C J2 = NVPTR (I) + NVLEN (I)-1
C CALL GETDUM (NSFLG (I), DUMMY, LEN)
C WRITE (IUNIT, 180, ERR = 200) DUMMY (1:LEN)
C WRITE (IUNIT, 160, ERR = 200) (NSIDEN (J), J = J1, J2)
C 190 CONTINUE
C ELSE
DO 280 I = 1, NBCSID
J1 = NSPTR (I)
J2 = NSPTR (I)+NSLEN (I)-1
CALL GETDUM (NSFLG (I), DUMMY, LEN)
WRITE (*, 10090) NSFLG(I)
CALL INQSTR ('PRESSURE MAGNITUDE: ',TITLE)
READ (TITLE, '(F10.0)') PMAG
C WRITE OUT THE SIDE 1 ELEMENTS
FOUND = .FALSE.
JHOLD = 0
DO 170 J = J1, J2
JJ1 = NSIDEN ( (J * 2) - 1)
JJ2 = NSIDEN (J * 2)
K = NELEMS (J)
IF (NXK (3, K) .EQ. 0) THEN
INODE = 2
ELSEIF (NXK (4, K) .EQ. 0) THEN
INODE = 3
ELSEIF (EIGHT .OR. NINE) THEN
INODE = 8
ELSE
INODE = 4
ENDIF
IF ( ( (INODE .EQ. 4) .AND.
& ( ( (JJ1 .EQ. NXK (1, K)) .AND.
& (JJ2 .EQ. NXK (2, K)) ) .OR.
& ( (JJ2 .EQ. NXK (1, K)) .AND.
& (JJ1 .EQ. NXK (2, K)) ) ) ) .OR.
& ( (INODE .EQ. 8) .AND.
& ( ( (JJ1 .EQ. NXK (1, K)) .AND.
& (JJ2 .EQ. NXK (2, K)) ) .OR.
& ( (JJ2 .EQ. NXK (1, K)) .AND.
& (JJ1 .EQ. NXK (2, K)) ) ) ) ) THEN
C & ( (JJ1 .EQ. NXK (2, K)) .AND.
C & (JJ2 .EQ. NXK (3, K)) ) .OR.
C & ( (JJ2 .EQ. NXK (2, K)) .AND.
C & (JJ1 .EQ. NXK (3, K)) ) ) ) ) THEN
IF (.NOT. FOUND) THEN
FOUND = .TRUE.
ENDIF
JHOLD = JHOLD + 1
IHOLD (JHOLD) = MAPGXD (K)
IF (JHOLD .EQ. 9) THEN
DO 160 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 1,
& PMAG
160 CONTINUE
JHOLD = 0
ENDIF
ENDIF
170 CONTINUE
IF (JHOLD .GT. 0) THEN
DO 180 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 1, PMAG
180 CONTINUE
ENDIF
C WRITE OUT THE SIDE 2 ELEMENTS
FOUND = .FALSE.
JHOLD = 0
DO 200 J = J1, J2
JJ1 = NSIDEN ( (J * 2) - 1)
JJ2 = NSIDEN (J * 2)
K = NELEMS (J)
IF (NXK (3, K) .EQ. 0) THEN
INODE = 2
ELSEIF (NXK (4, K) .EQ. 0) THEN
INODE = 3
ELSEIF (EIGHT .OR. NINE) THEN
INODE = 8
ELSE
INODE = 4
ENDIF
IF ( ( (INODE .EQ. 4) .AND.
& ( ( (JJ1 .EQ. NXK (2, K)) .AND.
& (JJ2 .EQ. NXK (3, K)) ) .OR.
& ( (JJ2 .EQ. NXK (2, K)) .AND.
& (JJ1 .EQ. NXK (3, K)) ) ) ) .OR.
& ( (INODE .EQ. 8) .AND.
& ( ( (JJ1 .EQ. NXK (3, K)) .AND.
& (JJ2 .EQ. NXK (4, K)) ) .OR.
& ( (JJ2 .EQ. NXK (3, K)) .AND.
& (JJ1 .EQ. NXK (4, K)) ) ) ) ) THEN
C & ( (JJ1 .EQ. NXK (4, K)) .AND.
C & (JJ2 .EQ. NXK (5, K)) ) .OR.
C & ( (JJ2 .EQ. NXK (4, K)) .AND.
C & (JJ1 .EQ. NXK (5, K)) ) ) ) ) THEN
IF (.NOT. FOUND) THEN
FOUND = .TRUE.
ENDIF
JHOLD = JHOLD + 1
IHOLD (JHOLD) = MAPGXD (K)
IF (JHOLD .EQ. 9) THEN
DO 190 II = 2, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 2,
& PMAG
190 CONTINUE
JHOLD = 0
ENDIF
ENDIF
200 CONTINUE
IF (JHOLD .GT. 0) THEN
DO 210 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 2, PMAG
210 CONTINUE
ENDIF
C WRITE OUT THE SIDE 3 ELEMENTS
FOUND = .FALSE.
JHOLD = 0
DO 230 J = J1, J2
JJ1 = NSIDEN ( (J * 2) - 1)
JJ2 = NSIDEN (J * 2)
K = NELEMS (J)
IF (NXK (3, K) .EQ. 0) THEN
INODE = 2
ELSEIF (NXK (4, K) .EQ. 0) THEN
INODE = 3
ELSEIF (EIGHT .OR. NINE) THEN
INODE = 8
ELSE
INODE = 4
ENDIF
IF ( ( (INODE .EQ. 4) .AND.
& ( ( (JJ1 .EQ. NXK (3, K)) .AND.
& (JJ2 .EQ. NXK (4, K)) ) .OR.
& ( (JJ2 .EQ. NXK (3, K)) .AND.
& (JJ1 .EQ. NXK (4, K)) ) ) ) .OR.
& ( (INODE .EQ. 8) .AND.
& ( ( (JJ1 .EQ. NXK (5, K)) .AND.
& (JJ2 .EQ. NXK (6, K)) ) .OR.
& ( (JJ2 .EQ. NXK (5, K)) .AND.
& (JJ1 .EQ. NXK (6, K)) ) ) ) ) THEN
C & ( (JJ1 .EQ. NXK (6, K)) .AND.
C & (JJ2 .EQ. NXK (7, K)) ) .OR.
C & ( (JJ2 .EQ. NXK (6, K)) .AND.
C & (JJ1 .EQ. NXK (7, K)) ) ) ) ) THEN
IF (.NOT. FOUND) THEN
FOUND = .TRUE.
ENDIF
JHOLD = JHOLD + 1
IHOLD (JHOLD) = MAPGXD (K)
IF (JHOLD .EQ. 9) THEN
DO 220 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 3,
& PMAG
220 CONTINUE
JHOLD = 0
ENDIF
ENDIF
230 CONTINUE
IF (JHOLD .GT. 0) THEN
DO 240 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 3, PMAG
240 CONTINUE
ENDIF
C WRITE OUT THE SIDE 4 ELEMENTS
FOUND = .FALSE.
JHOLD = 0
DO 260 J = J1, J2
JJ1 = NSIDEN ( (J * 2) - 1)
JJ2 = NSIDEN (J * 2)
K = NELEMS (J)
IF (NXK (3, K) .EQ. 0) THEN
INODE = 2
ELSEIF (NXK (4, K) .EQ. 0) THEN
INODE = 3
ELSEIF (EIGHT .OR. NINE) THEN
INODE = 8
ELSE
INODE = 4
ENDIF
IF ( ( (INODE .EQ. 4) .AND.
& ( ( (JJ1 .EQ. NXK (4, K)) .AND.
& (JJ2 .EQ. NXK (1, K)) ) .OR.
& ( (JJ2 .EQ. NXK (4, K)) .AND.
& (JJ1 .EQ. NXK (1, K)) ) ) ) .OR.
& ( (INODE .EQ. 8) .AND.
& ( ( (JJ1 .EQ. NXK (7, K)) .AND.
& (JJ2 .EQ. NXK (8, K)) ) .OR.
& ( (JJ2 .EQ. NXK (7, K)) .AND.
& (JJ1 .EQ. NXK (8, K)) ) ) ) ) THEN
C & ( (JJ1 .EQ. NXK (8, K)) .AND.
C & (JJ2 .EQ. NXK (1, K)) ) .OR.
C & ( (JJ2 .EQ. NXK (8, K)) .AND.
C & (JJ1 .EQ. NXK (1, K)) ) ) ) ) THEN
IF (.NOT. FOUND) THEN
FOUND = .TRUE.
ENDIF
JHOLD = JHOLD + 1
IHOLD (JHOLD) = MAPGXD (K)
IF (JHOLD .EQ. 9) THEN
DO 250 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 4,
& PMAG
250 CONTINUE
JHOLD = 0
ENDIF
ENDIF
260 CONTINUE
IF (JHOLD .GT. 0) THEN
DO 270 II = 1, JHOLD
WRITE (IUNIT, 10110, ERR = 290) IHOLD(II), 4, PMAG
270 CONTINUE
ENDIF
280 CONTINUE
ENDIF
WRITE (IUNIT, 10140, ERR = 290)
CALL MESSAGE('JOE''S ERROR OUTPUT FILE SUCCESSFULLY WRITTEN')
ERR = .FALSE.
RETURN
C ERR DURING WRITE PROBLEMS
290 CONTINUE
CALL MESSAGE('ERR DURING WRITE TO ABAQUS OUTPUT FILE')
CALL MESSAGE(' - NO FILE SAVED - ')
RETURN
10000 FORMAT (A72)
10010 FORMAT ('*PROSTRFAC 0.0',/,
& '*PSTRESS',/,
& '*MATERIAL',/,
& '*ELASTIC',/,
& '30.E+6 .3',/,
& '*MATERIAL',/,
& '*ELASTIC',/,
& '30.E+6 .3')
10020 FORMAT ('*NODE')
10030 FORMAT (I10, ',', 2 (E14.7, ','), E14.7)
10040 FORMAT ('*ELEMENT')
10050 FORMAT (8 (I8, ','), I8)
10060 FORMAT (4 (I10, ','), I10)
10070 FORMAT ('*FIXED')
10080 FORMAT (/,' FOR NODE BOUNDARY FLAG',I5)
10090 FORMAT (/,' FOR ELEMENT BOUNDARY FLAG',I5)
10100 FORMAT (I8, ',', I8)
10110 FORMAT ('EL,', I8, ', P', I1, ',', F10.6)
10120 FORMAT ('*STEP', /, '1.,1.', /, '*POST', /,
& '*MAXIT 2', /, 'PRINT 50')
10130 FORMAT ('*PTOL 1.E-2')
10140 FORMAT ('*END')
END