EXODUS/packages/seacas/applications/blot/msgeom.f

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 MSGEOM (A, CURPRO, ISTEP,
     &  LENF, NLNKF, KLINKF, KXN, KYN, KZN,
     &  KIF2EL, NEWELB, IELBST, NEWFAC, FIXFAC)
C=======================================================================

C   --*** MSGEOM *** (MESH) Correct the mesh faces
C   --   Written by Amy Gilkey - revised 05/27/88
C   --
C   --MSGEOM determines the new face array, if it has changed.
C   --It handles new displayed element blocks, a new "cut" through the mesh,
C   --and element birth/death (for the time step).  A flag is set if the
C   --faces are changed.
C   --
C   --This routine reserves and sets the following dynamic memory arrays:
C   --   IX2NP - the node number for each mesh index
C   --
C   --This routine uses MDFIND to find the following dynamic memory arrays:
C   --   IF2EL2 - the secondary element number of each face
C   --   IE2ELB - the element block for each element
C   --   XN, YN, ZN - IN - the full set of nodal coordinates (ZN for 3D only)
C   --   LENE - the cumulative element counts by element block
C   --   ISEVOK - the element block variable truth table;
C   --      variable i of block j exists iff ISEVOK(j,i)
C   --
C   --Parameters:
C   --   A - IN - the dynamic memory base array
C   --   CURPRO - IN - the name of the program that changed the faces
C   --   ISTEP - IN - the time step number
C   --   LENF - IN/OUT - the cumulative face counts by element block
C   --      LENF(0) is always 0
C   --      LENF(1..NELBLK) is the end of the surface faces of element block (i)
C   --      LENF(NELBLK+1) is the end of the interior faces
C   --      LENF(NELBLK+2) is the end of the faces that are dead
C   --      LENF(NELBLK+3) is the end of the faces outside a cut
C   --      LENF(NELBLK+4) is the end of the faces in a non-selected block
C   --   NLNKF - IN - the number of nodes per face
C   --   KLINKF - IN/OUT - the index of LINKF - the connectivity for all faces
C   --   KXN, KYN, KZN - IN - the indices of XN, YN, ZN -
C   --      the nodal coordinates (ZN for 3D only)
C   --   KIF2EL - IN/OUT - the index of IF2EL - the element number of each face
C   --   NEWELB - IN/OUT - the new element blocks flag:
C   --      0 = no new element blocks
C   --      1 = new selected element blocks
C   --      2 = new displayed element blocks (implies new selected blocks)
C   --   IELBST - IN - the element block status:
C   --      -1 = OFF, 0 = ON, but not selected, 1 = selected
C   --   NEWFAC - OUT - set true if the faces are changed, else false
C   --   FIXFAC - OUT - set true if the program that last set the faces is
C   --      not the current program (some program-specific values may need
C   --      to be reset), else false
C   --
C   --Common Variables:
C   --   Uses NDIM, NUMEL, NELBLK of /DBNUMS/
C   --   Uses IS3DIM of /D3NUMS/
C   --   Uses NALVAR of /MSHOPT/
C   --   Sets and uses NEWROT, ROTMAT, ROTCEN of /ROTOPT/
C   --   Sets and uses NEWCUT, ISCUT, CUTPT, CUTNRM of /CUTOPT/

      include 'dbnums.blk'
      include 'd3nums.blk'
      include 'mshopt.blk'
      COMMON /ROTOPT/ NEWROT, ROTMAT(3,3), ROTCEN(3), EYE(3)
      LOGICAL NEWROT
      COMMON /CUTOPT/ NEWCUT, ISCUT, CUTPT(3), CUTNRM(3)
      LOGICAL NEWCUT, ISCUT

      DIMENSION A(*)
      CHARACTER*(*) CURPRO
      INTEGER LENF(0:NELBLK+4)
      INTEGER NLNKF(NELBLK)
      INTEGER NEWELB
      INTEGER IELBST(NELBLK)
      LOGICAL NEWFAC
      LOGICAL FIXFAC

      LOGICAL FIRST
      SAVE FIRST
C      --FIRST - true iff first time through routine

      CHARACTER*8 LSTPRO
      SAVE LSTPRO
C      --LSTPRO - the last program to set the faces

      INTEGER NALOLD
      SAVE NALOLD
C      --NALOLD - the last setting of NALVAR

      DATA FIRST / .TRUE. /
      DATA NALOLD / 0 /
      DATA LSTPRO / '        ' /

C   --Figure out if new face set needs to be calculated

      NEWFAC = .FALSE.

      IF (FIRST) THEN
        LSTPRO = CURPRO
      END IF

      IF (IS3DIM .AND. (NEWELB .EQ. 2)) THEN
        NEWFAC = .TRUE.
      END IF

      IF (IS3DIM .AND. NEWCUT) THEN
        NEWFAC = .TRUE.
      END IF

      IF ((NALOLD .GT. 0) .AND. (NALVAR .LE. 0)) THEN
        NEWFAC = .TRUE.
      END IF

      IF ((NALVAR .GT. 0) .AND. (ISTEP .GE. 1)) THEN
        NEWFAC = .TRUE.
      END IF

C   --Compute new face set if element blocks have been turned on/off

      IF (IS3DIM .AND. (NEWELB .EQ. 2)) THEN

C         --Determine new face set for new element blocks

        NSETS = NELBLK + 4
        CALL MDRSRV ('NEWELB', KNEWB, LENF(NSETS))
        IF (IS3DIM) CALL MDFIND ('IF2EL2', KIF2E2, IDUM)
        CALL MDFIND ('IE2ELB', KE2ELB, IDUM)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) GOTO 100

        CALL FIXELB (IELBST, LENF, A(KIF2EL), A(KIF2E2), A(KE2ELB),
     &    A(KNEWB))

C         --Adjust the face connectivity

        CALL SORLNK (A, NSETS, A(KNEWB),
     &    LENF, NLNKF, A(KLINKF), A(KIF2EL), A(KIF2E2), A(KE2ELB))

        CALL MDDEL ('NEWELB')

C      --If no faces are ON, print error message
C      --and go back for more commands with NEWELB set

        IF (LENF(NELBLK) .EQ. 0) THEN
          CALL PRTERR ('ERROR', 'No element blocks are displayed')
          NEWELB = 2
          GOTO 100
        END IF

C      --Force the re-calculation of the cut, if cut
        IF (ISCUT) NEWCUT = .TRUE.

C      --All faces are now alive
        NALOLD = 0

C      --Force the re-calculation of connected element count, if needed
        NEWELB = 1
      END IF

C   --Compute new face set if the object has been cut

      IF (IS3DIM .AND. NEWCUT) THEN

C         --Compute new face set for cut

        NSETS = NELBLK + 3
        CALL MDRSRV ('NEWELB', KNEWB, LENF(NSETS))
        IF (IS3DIM) CALL MDFIND ('IF2EL2', KIF2E2, IDUM)
        CALL MDFIND ('IE2ELB', KE2ELB, IDUM)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) GOTO 100

        IF (ISCUT) THEN
          CALL MDRSRV ('SCRFAC', KFSTAT, LENF(NELBLK+3))
          CALL MDRSRV ('ROUTEL', KESTAT, NUMEL)
          CALL MDRSRV ('ROUTZC', KZC, NUMNP)
C            --Get the full set of coordinates
          CALL MDFIND ('XN', KX, IDUM)
          CALL MDFIND ('YN', KY, IDUM)
          CALL MDFIND ('ZN', KZ, IDUM)
          CALL MDSTAT (NERR, MEM)
          IF (NERR .GT. 0) GOTO 100

          CALL FIXCUT (CUTPT, CUTNRM, A(KX), A(KY), A(KZ),
     &      LENF, NLNKF, A(KLINKF),
     &      A(KIF2EL), A(KIF2E2), A(KE2ELB),
     &      A(KFSTAT), A(KESTAT), A(KZC), A(KNEWB))

          CALL MDDEL ('SCRFAC')
          CALL MDDEL ('ROUTEL')
          CALL MDDEL ('ROUTZC')

        ELSE
          CALL ALLCUT (A(KE2ELB), LENF, A(KIF2EL), A(KIF2E2),
     &      A(KNEWB))
        END IF

C         --Adjust the face connectivity

        CALL SORLNK (A, NSETS, A(KNEWB),
     &    LENF, NLNKF, A(KLINKF), A(KIF2EL), A(KIF2E2), A(KE2ELB))

        CALL MDDEL ('NEWELB')

C      --If no faces are defined by cut, delete cut, print error message
C      --and go back for more commands with NEWCUT set

        IF (LENF(NELBLK) .EQ. 0) THEN
          CALL PRTERR ('ERROR',
     &      'No elements are defined by the cutting plane')
          NEWCUT = .TRUE.
          GOTO 100
        END IF

C      --All faces are now alive
        NALOLD = 0

        NEWCUT = .FALSE.
      END IF

C   --Compute new face set (and line set for 2D) for birth/death turned off

      IF ((NALOLD .GT. 0) .AND. (NALVAR .LE. 0)) THEN

C         --Compute new face set for birth/death turned off

        NSETS = NELBLK + 2
        CALL MDRSRV ('NEWELB', KNEWB, LENF(NSETS))
        IF (IS3DIM) CALL MDFIND ('IF2EL2', KIF2E2, IDUM)
        CALL MDFIND ('IE2ELB', KE2ELB, IDUM)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) GOTO 100

        IF (.NOT. IS3DIM) THEN
          CALL ALLAL2 (LENF, A(KIF2EL), A(KE2ELB), A(KNEWB))
        ELSE
          CALL ALLAL3 (LENF, A(KIF2EL), A(KIF2E2), A(KE2ELB),
     &      A(KNEWB))
        END IF

C         --Adjust the face connectivity

        CALL SORLNK (A, NSETS, A(KNEWB),
     &    LENF, NLNKF, A(KLINKF), A(KIF2EL), A(KIF2E2), A(KE2ELB))

        CALL MDDEL ('NEWELB')

        NALOLD = NALVAR
      END IF

C   --Compute new face set (and line set for 2D) for birth/death for step

      IF ((NALVAR .GT. 0) .AND. (ISTEP .GE. 1)) THEN

C         --Compute new face set for birth/death for step

        NSETS = NELBLK + 2
        CALL MDRSRV ('NEWELB', KNEWB, LENF(NSETS))
        IF (IS3DIM) CALL MDFIND ('IF2EL2', KIF2E2, IDUM)
        CALL MDFIND ('IE2ELB', KE2ELB, IDUM)

        CALL MDRSRV ('ROUTEL', KALIVE, NUMEL)
        CALL MDFIND ('LENE', KLENE, IDUM)
        CALL MDFIND ('ISEVOK', KIEVOK, IDUM)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) GOTO 100

        CALL GETALV (A, NALVAR, ALIVAL, ISTEP, A(KLENE), A(KIEVOK),
     &    A(KALIVE), A(KALIVE))

        IF (.NOT. IS3DIM) THEN
          CALL FIXAL2 (A(KALIVE),
     &      LENF, A(KIF2EL), A(KE2ELB), A(KNEWB))
        ELSE
          CALL FIXAL3 (A(KALIVE),
     &      LENF, A(KIF2EL), A(KIF2E2), A(KE2ELB), A(KNEWB))
        END IF

        CALL MDDEL ('ROUTEL')

C         --Adjust the face connectivity

        CALL SORLNK (A, NSETS, A(KNEWB),
     &    LENF, NLNKF, A(KLINKF), A(KIF2EL), A(KIF2E2), A(KE2ELB))

        CALL MDDEL ('NEWELB')

C      --If no faces are alive, print error message
C      --and skip time step

        IF (LENF(NELBLK) .EQ. 0) THEN
          CALL PRTERR ('ERROR', 'No elements are alive')
          GOTO 100
        END IF

        NALOLD = NALVAR
      END IF

 100  CONTINUE

      IF (NEWFAC) THEN

C      --Force the re-calculation of which nodes are on the surface
        NNPSUR = -999
      END IF

      IF (NEWFAC) LSTPRO = CURPRO
      FIXFAC = (CURPRO .NE. LSTPRO)

      FIRST = .FALSE.

      RETURN
      END