C Copyright(C) 1999-2020, 2022 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=======================================================================
*DECK,MAPVAR
      PROGRAM MAPVAR

C     ******************************************************************

C                                --MAPVAR--
C                  A PROGRAM TO MAP FINITE ELEMENT RESULTS
C                 FROM ONE EXODUS-II RESTART FILE TO ANOTHER
C                 EXODUS-II RESTART FILE TO SUPPORT REMESHING

C                             GERALD W. WELLMAN
C                        SANDIA NATIONAL LABORATORIES
C                          ALBUQUERQUE, NEW MEXICO

C     MAPVAR IS BASED ON MERLIN II,A FINITE ELEMENT INTERPOLATION
C     PROGRAM BY DAVID K. GARTLING.

C     THE MERLIN PROGRAM IS DESIGNED TO TRANSFER DATA BETWEEN TWO- AND
C     THREE-DIMENSIONAL FINITE ELEMENT MESHES. GIVEN A FINITE ELEMENT
C     MESH, (MESH-A), AND A SOLUTION FIELD ON THAT MESH, MERLIN
C     INTERPOLATES THE GIVEN SOLUTION ONTO A SECOND FINITE ELEMENT MESH,
C     (MESH-B). THE INTERPOLATION PROCEDURE IS BASED ON USE OF THE
C     ELEMENT SHAPE FUNCTIONS IN MESH-A.

C     MAPVAR IS DESIGNED TO SERVE THE SAME GENERAL PURPOSE AS MERLIN
C     HOWEVER, MAPVAR IS DESIGNED TO PROVIDE THE TRANSLATION IN TERMS
C     OF EXODUS-II-V2 RESTART FILES. MAPVAR ALSO TRANSLATES ELEMENT
C     VARIABLES AS WELL AS NODAL VARIABLES AND READS/WRITES GLOBAL
C     VARIABLES. MAPVAR IS CURRENTLY SET UP FOR THREE ELEMENT TYPES,
C     2-D QUADS, 3-D HEXES, AND 3-D QUAD SHELLS. ALL THE ELEMENTS
C     ORIGINALLY SUPPORTED BY MERLIN CAN BE INCLUDED IN MAPVAR GIVEN
C     THE DESIRE AND RESOURCES. THE SEARCH ENGINE OF MAPVAR HAS BEEN
C     CHANGED TO A BINARY SEARCH FROM THE BIN OR BUCKET SEARCH OF MERLIN.

C     THE INTENT OF MAPVAR IS TO CREATE A RESTART FILE THAT WILL ALLOW
C     A FINITE ELEMENT SOLUTION TO PROCEED WITH A DIFFERENT MESH THAN
C     THE MESH WITH WHICH THE SOLUTION WAS STARTED. THUS, THERE IS AN
C     INHERENT ASSUMPTION THAT MESH-A IS AN EXODUS RESTART FILE.

C     NODAL VARIABLE TRANSFER IS STRAIGHT FORWARD. THE MESH-B NODE IS
C     FOUND INSIDE THE APPROPRIATE MESH-A ELEMENT. THE ELEMENT SHAPE
C     FUNCTIONS ARE USED TO INTERPOLATE RESULTS ONTO THE MESH-B NODE.
C     ELEMENT VARIABLE TRANSFER TAKES TWO STEPS. FIRST THE ELEMENT
C     VARIABLE IS "SCATTERED" TO THE NODES. THEN THE MESH-B ELEMENT
C     CENTROID IS FOUND INSIDE THE MESH-A ELEMENT. TRANSFER TO THE
C     MESH-B ELEMENT CENTROID TAKES PLACE USING THE ELEMENT SHAPE
C     FUNCTIONS AND THE "SCATTERED" ELEMENT DATA (NOW NODAL DATA).
C     ELEMENT DATA IS "SCATTERED" TO THE NODES IN TWO SCHEMES. THE
C     FIRST IS SIMPLE AVERAGING. THIS IS ROBUST AND FAST BUT CAN LEAD
C     TO SIGNIFICANT DISSIPATION IN THE CASE OF GRADIENTS APPROACHING
C     A FREE SURFACE. THE SECOND METHOD EMPLOYS A CONSTRAINED LEAST
C     SQUARES FITTING PROCEDURE TO "SCATTER" ELEMENT RESULTS TO THE
C     NODES. THE CONSTRAINTS ARE BASED ON THE REQUIREMENTS OF THE
C     CONSTITUTIVE MODEL. FINALLY, A DIRECT TRANSFER HAS BEEN IMPLEMENTED
C     BUT IS NOT RECOMMENDED.

C     Special considerations:
C       ELMASS - translated to nodal density, interpolated, translated
C                back to ELMASS
C       ROTATIONS - magnitude of matrix must be 1, translate, compute
C                   magnitude, divide each component by magnitude
C       EQPS - constrained to be .gt. 0.
C       TEARING - constrained to be .gt. 0.
C       DECAY - constrained to be .lt. 1.

C       Code Tree:
C (SUPES, EXODUSII, and multiple calls to ERROR not included)

C SET-UP
C                 MAPVAR - OPNFIL
C                          ERROR -  CLSFIL
C                          RDINPT - BANNER
C                                   ERROR
C                          RDA1 -   LENSTR
C                          RDB1
C                          RDA2 -   ERROR
C                          RDB2 -   ERROR
C SHELLS
C                          BLDSRF
C                          BLDPTN
C                          SRCHS -  MKRNK -  INDEXX
C                                            RANK
C                                -  GETBND - SRCHGE
C                                            SRCHGT
C                                -  MKLSTV
C                                -  SHLSRC
C                          SINTPN - SHAPEF
C                          BLDPTE - CNTR
C                          SRCHS -
C      SCHEME 0
C                          SETON0 - VOL
C                          SINTPE - SHAPEF
C                                   VOL
C      SCHEME 1
C                          SETON1 - CNTR
C                                   VOL
C                                   INVCON
C                                   EXTS -   FRGE
C                                            BS
C                                   AVG
C                          SINTPE -
C      SCHEME 2
C                          STRAN
C      SCHEME 3
C                          INVCON
C                          ELGRAD - CNTR
C                                 - VOL
C                                 - FLGRAD
C                          INTRP3
C QUADS
C                          BLDSRF
C                          BLDPTN
C                          SRCHQ -  MKRNK -  INDEXX
C                                            RANK
C                                -  GETBND - SRCHGE
C                                            SRCHGT
C                                -  MKLSTV
C                                -  QADSRC - NODE
C                                            JACOBN
C                          INTRPN - SHAPEF
C                          BLDPTE -
C                          SRCHQ -
C      SCHEME 0
C                          ELTON0 - VOL
C                          INTRPE - SHAPEF
C                                   VOL
C      SCHEME 1
C                          ELTON1 - CNTR
C                                   VOL
C                                   INVCON
C                                   EXTQ -   FRGE
C                                            BS
C                                   AVG
C                                   EXTH -   FRGE
C                                            BS
C                          INTRPE -
C      SCHEME 2
C                          TRANAB
C      SCHEME 3
C                          INVCON
C                          ELGRAD - CNTR
C                                 - VOL
C                                 - FLGRAD
C                          INTRP3
C HEXES
C                          BLDSRF
C                          BLDPTN
C                          SRCHH -   MKRNK -  INDEXX
C                                            RANK
C                                -  GETBND - SRCHGE
C                                            SRCHGT
C                                -  MKLSTV
C                                -  HEXSRC - NODE
C                                            JACOBN
C                          INTRPN -
C                          BLDPTE -
C                          SRCHH -
C      SCHEME 0
C                          ELTON0 -
C                          INTRPE -
C      SCHEME 1
C                          ELTON1 -
C                          INTRPE -
C      SCHEME 2
C                          TRANAB
C      SCHEME 3
C                          INVCON
C                          ELGRAD - CNTR
C                                 - VOL
C                                 - FLGRAD
C                          INTRP3
C WRAP-UP
C                          WRTC
C                          BANNER
C                          CLSFIL

C SUPES CALLS:
C              EXDATE, EXTIME, FREFLD, MDDEL, MDEROR, MDGET,
C              MDINIT, MDRSRV, MDSTAT, STRIPB

C EXODUSII CALLS:
C              EXCLOS, EXINQ,  (EXOPN)-fcn,
C              EXGATM, EXGCON, EXGCOR, EXGEAT, EXGEBI, EXGELB,
C              EXGELC, EXGEV,  EXGGV,  EXGINI, EXGNSI, EXGNP,
C              EXGNV,  EXGNS,  EXGNSD, EXGP,   EXGPN,  EXGQA,
C              EXGSS,  EXGSSD, EXGSSI, EXGSP,  EXGTIM, EXGVAN,
C              EXGVP,
C              EXPCON, EXPCOR, EXPEAT, EXPELB, EXPELC, EXPEV,
C              EXPGV,  EXPINI, EXPNS,  EXPNSD, EXPNV,  EXPNP,
C              EXPP,   EXPPN,  EXPQA,  EXPSP,  EXPSS,  EXPSSD,
C              EXPTIM, EXPVAN,

C     ******************************************************************

C     THE BASIC REFERENCE DOCUMENT FOR THIS CODE IS SAND 99-0466

C     ******************************************************************

C     COMPUTER CODE MANAGEMENT SYSTEM INFORMATION --

C     CURRENT VERSION DESIGNATOR- 1.12

C     ******************************************************************

      include 'aexds1.blk'
      include 'aexds2.blk'
      include 'amesh.blk'
      include 'bmesh.blk'
      include 'contrl.blk'
      include 'ebbyeb.blk'
      include 'ex2tp.blk'
      include 'header.blk'
      include 'ntpdat.blk'
      include 'rundat.blk'
      include 'steps.blk'
      include 'schdat.blk'
      include 'tapes.blk'
      include 'toldat.blk'
      include 'varnpt.blk'
      include 'varept.blk'

      DIMENSION A(1),IA(1)
      EQUIVALENCE (A(1),IA(1))
      CHARACTER*(MXSTLN) TYP
      CHARACTER*8   MEMDBG

C     ******************************************************************

C     MAIN PROGRAM FOR MAPVAR
C     PROGRAM EXECUTION IS DIRECTED FROM THIS ROUTINE

C     ******************************************************************

C     NOTE : ALL ELEMENT DATA,NODAL POINT DATA, SOLUTION FIELDS, WORK
C            SPACE, ETC. ARE STORED IN THE ARRAY "A". THE MEMORY
C            MANAGER REQUESTS THE NEEDED STORAGE SPACE IN "A" DURING
C            EXECUTION. THE POINTERS NA1,NA2,....NAM PARTITION THE
C            ALLOCATED STORAGE INTO SEPARATE ARRAYS. SEE SAND86-0911,
C            "SUPES", FOR DETAILS OF THE MEMORY MANAGER.

C     ******************************************************************

C open all disk files

C disable netcdf warning messages

      CALL EXOPTS(0,IERR)

      call debug('MVOPNFIL')
      CALL MVOPNFIL

C get info for QA records

      CALL VERSION(QAINFO)

C initialize memory manager

      CALL MDINIT (A)

C ... If EXT99 Environment variable set, turn on supes memory debugging
C     The numeric value of the variable is used as the unit to write
C     debug information to.
      CALL EXNAME (-99, MEMDBG, L)
      IF (L .GE. 1) THEN
        READ(MEMDBG(:L), '(I8)', ERR=20) IUNIT
        CALL MDDEBG(IUNIT)
      END IF
 20   CONTINUE

C ******************************************************************
C read input parameters needed to control the solution from
C      the screen (time step(s), bins)
C ******************************************************************

      CALL EXINQ(NTP2EX,EXTIMS,NTIMES,RDUM,CDUM,IERR)
      CALL EXGINI (NTP2EX,HED,NDIMA,NODESA,NUMELA,NBLKSA,
     &             NUMNPS,NUMESS,IERR)
      CALL EXGINI (NTP3EX,HED,NDIMB,NODESB,NUMELB,NBLKSB,
     &             NUMNPS,NUMESS,IERR)

C A(NT1)      =   TIMES(1:NTIMES) - times on Mesh-A database
C IA(NAEB)    =   IDA(1:NBLKSA) - Donor mesh element block I.D.'s
C IA(NBEB)    =   IDB(1:NBLKSA) - Recipient mesh element block I.D.'s
C IA(NMAP)    =   MP(1:3,1:MBLK) - Donor to recipient mesh map

      MBLK = NBLKSA * NBLKSB
      CALL MDRSRV ('TIMES', NT1,   NTIMES)
      CALL MDRSRV ('IDA',   NAEB,  NBLKSA)
      CALL MDRSRV ('IDB',   NBEB,  NBLKSB)
      CALL MDRSRV ('MP',    NMAP,  MBLK*3)

C reserve space for storing the search box size for each map operation
      CALL MDRSRV ('MPSEA', NMAPS, MBLK)

      CALL MDSTAT (MNERRS, MNUSED)
      IF (MNERRS .NE. 0) THEN
         CALL MDEROR(NOUT)
         CALL ERROR('MAPVAR',
     &              'MEMORY MANAGER ERROR',
     &              'JUST BEFORE CALL TO RDINPT',0,' ',0,' ',' ',1)
      END IF

      call debug('RDINPT')
      CALL RDINPT (A(NT1),IA(NAEB),IA(NBEB),IA(NMAP),A(NMAPS),IMP,MBLK)

C ******************************************************************
C INITIAL READ OF MESH-A
C ******************************************************************

C read sizing data for mesh A

      WRITE (NOUT, 270) fntp2(:lenstr(fntp2)), HED
      WRITE (NTPOUT, 270) fntp2(:lenstr(fntp2)), HED
      WRITE (NOUT, 280) NDIMA,NODESA,NUMELA,NBLKSA
      WRITE (NTPOUT, 280) NDIMA,NODESA,NUMELA,NBLKSA

C allocate storage for initial read of mesh A

C      A(NAX)     =    XA(1:NODESA) - Mesh-A X-coord
C      A(NAY)     =    YA(1:NODESA) - Mesh-A Y-coord
C      A(NAZ)     =    ZA(1:NODESA) - Mesh-A Z-coord
C      A(NADX)    =    DISXA(1:NODESA) - Mesh-A X-displ
C      A(NADY)    =    DISYA(1:NODESA) - Mesh-A Y-displ
C      A(NADZ)    =    DISZA(1:NODESA) - Mesh-A Z-displ

      CALL MDRSRV ('XA',     NAX,   NODESA)
      CALL MDRSRV ('DISXA',  NADX,  NODESA)
      CALL MDRSRV ('YA',     NAY,   NODESA)
      CALL MDRSRV ('DISYA',  NADY,  NODESA)
      IF (NDIMA.EQ.3) THEN
        CALL MDRSRV ('ZA',     NAZ,  NODESA)
        CALL MDRSRV ('DISZA',  NADZ, NODESA)
      ELSE
        CALL MDRSRV ('ZA',     NAZ,  1)
        CALL MDRSRV ('DISZA',  NADZ, 1)
      END IF
      CALL MDSTAT (MNERRS, MNUSED)
      IF (MNERRS .NE. 0) THEN
         CALL MDEROR(NOUT)
         CALL ERROR('MAPVAR',
     &              'MEMORY MANAGER ERROR',
     &              'JUST BEFORE CALL TO RDA1',0,' ',0,' ',' ',1)
      END IF

C Copy "GENESIS" from mesh-B to mesh-C

      CALL EXCOPY(NTP3EX,NTP4EX,IERR)
      IF (IERR .NE. 0)
     &  CALL ERROR('MAPVAR',
     &             'ERROR WITH EXCOPY - GENESIS FILE COPY',
     &             ' ',0,' ',0,' ',' ',1)

c read mesh A (coords,displ,variable names,QA, INFO records),
c write mesh C, (variable names, QA, INFO records)

      call debug('RDA1')
      CALL RDA1 (A(NAX),A(NAY),A(NAZ),A(NADX),A(NADY),A(NADZ))

C ... Mapvar is buggy if mesh contains:
C     * nodal variable(s)
C     * multiple element blocks
C     * multiple timesteps

C     The interpolated mesh will have invalid values for most of the
C     nodes except for those connected to the last element block.
C     Since this is not what the user wants. We check this situation
C     here and then refuse to run...
      if (nvarnp .gt. 0) then
        if (ntimes .gt. 1 .and. istep .eq. -1 .and.
     *    nblksa .gt. 1 .and. nvarnp .gt. 0) then
          write (*,500)
 500      format(10x,/,
     *      'FATAL ERROR: Mapvar is buggy and cannot correctly'
     *      ' handle interpolating a mesh with nodal variables,',
     *      /,14x,'multiple timesteps and multiple element blocks.',
     *      /,14x,'See https://github.com/sandialabs/seacas/packages'
     *      '/seacas/MAPVAR.md')
          stop('INTERNAL ERROR')
        end if
C ... Warn if multiple blocks...
        if (ntimes .gt. 1 .and. nblksa .gt. 1) then
          write (*,600)
 600      format(10x,/,
     *      'WARNING: Mapvar is buggy and might not correctly'
     *      ' handle interpolating a mesh with nodal variables',
     *      /,9x,'and multiple element blocks. Shared nodes',
     *      ' might be incorrect.',
     *      /,9x,'See https://github.com/sandialabs/seacas/packages'
     *      '/seacas/MAPVAR.md')
        end if
      end if

      IF (IACCU .EQ. 1)THEN
        IF (IXVEL .NE. 0 .AND. IYVEL .NE. 0 .AND.
     &      (IELMS .NE. 0 .OR. IDENS .NE. 0))THEN

C velocities and mass are available, compute momenta and k.e.
C 1st set up storage for vel's

C  A(NVXA)    = VELXA(1:NODESA) - X-velocity in mesh-A
C  A(NVYA)    = VELYA(1:NODESA) - Y-velocity in mesh-A
C  A(NVZA)    = VELZA(1:NODESA) - Z-velocity in mesh-A
C  A(NNMSA)   = RMSNA(1:NODESA) - nodal mass in mesh-A
C  A(NVXB)    = VELXB(1:NODESB) - X-velocity in mesh-B
C  A(NVYB)    = VELYB(1:NODESB) - Y-velocity in mesh-B
C  A(NVZB)    = VELZB(1:NODESB) - Z-velocity in mesh-B
C  A(NNMSB)   = RMSNB(1:NODESB) - nodal mass in mesh-B

          CALL MDRSRV ('VELXA',   NVXA,   NODESA)
          CALL MDRSRV ('VELYA',   NVYA,   NODESA)
          IF (NDIMA .EQ. 3)THEN
            CALL MDRSRV ('VELZA',   NVZA,   NODESA)
          ELSE
            CALL MDRSRV ('VELZA',   NVZA,   1)
          END IF
          CALL MDRSRV ('RNMSA',   NNMSA,  NODESA)
          CALL MDRSRV ('VELXB',   NVXB,   NODESB)
          CALL MDRSRV ('VELYB',   NVYB,   NODESB)
          IF (NDIMB .EQ. 3)THEN
            CALL MDRSRV ('VELZB',   NVZB,   NODESB)
          ELSE
            CALL MDRSRV ('VELZB',   NVZB,   1)
          END IF
          CALL MDRSRV ('RNMSB',   NNMSB,  NODESB)
          CALL MDSTAT (MNERRS, MNUSED)
          IF (MNERRS .NE. 0) THEN
            CALL ERROR ('MAPVAR',
     &                  'MEMORY MANAGER ERROR',
     &                  'CHECK ACCURACY - VELOCITY',
     &                  0,' ',0,' ',' ',1)
          END IF

C initialization quantities (6 each for now) that need to be
C summed over the element blocks if doing an accuracy check

          IF (ISTEP .EQ. -1)THEN

C need arrays (one slot for each time), else just scalars will do

C A(NTMXA)  =  TMXA(1:NTIMES)  - X-momentum all mesh-A blocks each time
C A(NTMYA)  =  TMYA(1:NTIMES)  - Y-momentum all mesh-A blocks each time
C A(NTMZA)  =  TMZA(1:NTIMES)  - Z-momentum all mesh-A blocks each time
C A(NTKEA)  =  TKEA(1:NTIMES)  - K.E. all mesh-A blocks each time
C A(NTPSQA) =  TPSQA(1:NTIMES) - Pressure squared mesh-A each time
C A(NTJ2A)  =  TJ2A(1:NTIMES)  - J2 mesh-A each time

C A(NTMXB)  =  TMXB(1:NTIMES)  - X-momentum all mesh-B blocks each time
C A(NTMYB)  =  TMYB(1:NTIMES)  - Y-momentum all mesh-B blocks each time
C A(NTMZB)  =  TMZB(1:NTIMES)  - Z-momentum all mesh-B blocks each time
C A(NTKEB)  =  TKEB(1:NTIMES)  - K.E. all mesh-B blocks each time
C A(NTPSQB) =  TPSQB(1:NTIMES) - Pressure squared mesh-B each time
C A(NTJ2B)  =  TJ2B(1:NTIMES)  - J2 mesh-B each time

            CALL MDRSRV('TMXA',  NTMXA,  NTIMES)
            CALL MDRSRV('TMYA',  NTMYA,  NTIMES)
            CALL MDRSRV('TMZA',  NTMZA,  NTIMES)
            CALL MDRSRV('TKEA',  NTKEA,  NTIMES)
            CALL MDRSRV('TPSQA', NTPSQA, NTIMES)
            CALL MDRSRV('TJ2A', NTJ2A, NTIMES)
            CALL MDRSRV('TMXB',  NTMXB,  NTIMES)
            CALL MDRSRV('TMYB',  NTMYB,  NTIMES)
            CALL MDRSRV('TMZB',  NTMZB,  NTIMES)
            CALL MDRSRV('TKEB',  NTKEB,  NTIMES)
            CALL MDRSRV('TPSQB', NTPSQB, NTIMES)
            CALL MDRSRV('TJ2B',  NTJ2B,  NTIMES)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                    'MEMORY MANAGER ERROR',
     &                    'CHECK ACCURACY - INITIALIZATION',
     &                    0,' ',0,' ',' ',1)
            END IF
          ELSE
            CALL MDRSRV('TMXA',  NTMXA,  1)
            CALL MDRSRV('TMYA',  NTMYA,  1)
            CALL MDRSRV('TMZA',  NTMZA,  1)
            CALL MDRSRV('TKEA',  NTKEA,  1)
            CALL MDRSRV('TPSQA', NTPSQA, 1)
            CALL MDRSRV('TJ2A',  NTJ2A,  1)
            CALL MDRSRV('TMXB',  NTMXB,  1)
            CALL MDRSRV('TMYB',  NTMYB,  1)
            CALL MDRSRV('TMZB',  NTMZB,  1)
            CALL MDRSRV('TKEB',  NTKEB,  1)
            CALL MDRSRV('TPSQB', NTPSQB, 1)
            CALL MDRSRV('TJ2B',  NTJ2B,  1)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                    'MEMORY MANAGER ERROR',
     &                    'CHECK ACCURACY - INITIALIZATION',
     &                    0,' ',0,' ',' ',1)
            END IF
          END IF
        END IF
      END IF

C ******************************************************************
C INITIAL READ OF MESH-B
C ******************************************************************

C read sizing data for mesh B

      WRITE (NOUT, 290) fntp3(:lenstr(fntp3)), HED
      WRITE (NTPOUT, 290) fntp3(:lenstr(fntp3)), HED
      WRITE (NOUT, 300) NDIMB,NODESB,NUMELB,NBLKSB
      WRITE (NTPOUT, 300) NDIMB,NODESB,NUMELB,NBLKSB

c quick initial check of compatibility mesh-A to mesh-B

      IF (NDIMB .NE. NDIMA) THEN
        CALL ERROR('MAPVAR',
     &             'MESH-B INCOMPATIBLE WITH MESH-A',
     &             'DIMENSION OF MESH-A',NDIMA,
     &             'DIMENSION OF MESH-B',NDIMB,
     &             ' ',' ',1)
      END IF

C allocate storage for mesh B read

C      A(NBX)      =    XB(1:NODESB) - Mesh-B X-coord
C      A(NBY)      =    YB(1:NODESB) - Mesh-B Y-coord
C      A(NBZ)      =    ZB(1:NODESB) - Mesh-B Z-coord

      CALL MDRSRV ('XB',     NBX, NODESB)
      CALL MDRSRV ('YB',     NBY, NODESB)
      IF (NDIMB.EQ.3) THEN
        CALL MDRSRV ('ZB',    NBZ, NODESB)
      ELSE
        CALL MDRSRV ('ZB',    NBZ, 1)
      END IF
      CALL MDSTAT (MNERRS, MNUSED)
      IF (MNERRS .NE. 0) THEN
         CALL MDEROR(NOUT)
         CALL ERROR('MAPVAR',
     &              'MEMORY MANAGER ERROR',
     &              'JUST BEFORE CALL TO RDB1',
     &              0,' ',0,' ',' ',1)
      END IF

c read coordinates for mesh B

      call debug('RDB1')
      CALL RDB1 (A(NBX),A(NBY),A(NBZ))

C *********************************************************
C START INTERPOLATION
C *********************************************************

C set up memory for arrays for nodal results and truth table
C these arrays stay around forever - they don't get deleted
C after each element block is processed like the arrays
C set up within the element block loop

C   A(NASOLN)    =    SOLNA(1:NODESA,1:NVARNP) - Mesh-A nodal data
C   A(NBSOLN)    =    SOLNB(1:NODESB,1:NVARNP) - Mesh-B interpolated
C                                                nodal data
C   IA(ITTA)     =    ITRTA(1:NVAREL,1:NBLKSA) - Mesh-A truth table
C   IA(ITTB)     =    ITRTB(1:NVAREL,1:NBLKSB) - Mesh-B truth table

C    A(NSN)      = SN(1:NODESB)  - storage for nodal vars in ininod
C    A(NSE)      = SE(1:NODESB)  - storage for element vars in ininod

      CALL MDRSRV ('SOLNA',  NASOLN,   NODESA*NVARNP)
      CALL MDRSRV ('SOLNB',  NBSOLN,   NODESB*NVARNP)
      CALL MDRSRV ('ITRTA',  ITTA,     NVAREL*NBLKSA)
      CALL MDRSRV ('ITRTB',  ITTB,     NVAREL*NBLKSB)
      CALL MDRSRV ('SN',     NSN,      NODESB)
      CALL MDRSRV ('SE',     NSE,      NODESB)

      CALL MDSTAT (MNERRS, MNUSED)
      IF (MNERRS .NE. 0) THEN
         CALL MDEROR(NOUT)
         CALL ERROR('MAPVAR',
     &              'MEMORY MANAGER ERROR',
     &              'JUST BEFORE INTERPOLATION LOOP',
     &              0,' ',0,' ',' ',1)
      END IF

      call inirea(nodesb*nvarnp, 0.0, a(nbsoln))

      call debug('TRUTBL')
      CALL TRUTBL(IA(NMAP),IMP,IA(NAEB),IA(NBEB),IA(ITTA),IA(ITTB))

C *********************************************************************

C START OF ELEMENT BLOCK-BY-ELEMENT BLOCK INTERPOLATION LOOP

C *********************************************************************

C store default values of search box tolerances per element type
      TOLSHC = TOLSHL
      TOLQAC = TOLQAD
      TOLHEC = TOLHEX
      TOLTEC = TOLTET

C     A(NAGV)    =    GVAR(1:NVARGP) Global variables

      CALL MDRSRV ('GVAR',   NAGV, NVARGP)

      call debug('WRTC')
      CALL WRTC(A(NBX),A(NBY),A(NBZ),A(NAGV),A(NBSOLN))

      DO 50 IM = 1, IMP
C... Get values for block mapping
        call getval(ia(nmap), im, idblka, idblkb, ischem)
        TOLSEA = A(NMAPS+IM-1)

        do 15 i=1, nblksa
          if (idblka .eq. ia(naeb-1+i)) then
            iblka = i
            go to 16
          endif
 15     continue
 16     continue

        do 25 i=1, nblksb
          if (idblkb .eq. ia(nbeb-1+i)) then
            iblkb = i
            go to 26
          endif
 25     continue
 26     continue

C set up controls for many to 1 map
C if first time recipient mesh element block called, insub = 1
C else insub = 2
C if last time recipient mesh element block called, icompl = 1
C else icompl = 0

        INSUB  = 1
        ICOMPL = 1
        IF (IM .GT. 1)THEN
C ... Get the block b id from the previous time through...
C     `IA(NMAP)` is the root of the `MP(1:3,1:MBLK)` array. 
C                      ida    idb    isc    ida    ida    idb         isc
C     Memory ordering (1,1), (2,1), (3,1), (1,2), (2,2), (3,2), ..., (3,3)-
C                     +0     +1     +2     +3     +4     +5
C ida = ia(nmap+(3*im-1)+0) = ia(nmap + 3 * im - 3)
C idb = ia(nmap+(3*im-2)+1  = ia(nmap + 3 * im - 2)

C ... This is MP(2,IM-1)...
          IDBBM1 = IA(NMAP + 3 * im - 5)
          IF (IDBLKB .EQ. IDBBM1)THEN
            INSUB = 2
          END IF
        END IF
        IF (IM .LT. IMP)THEN
C ... This is MP(2,IM+1)...
          IDBBP1 = IA(NMAP+ 3 * im + 1)
          IF (IDBLKB .EQ. IDBBP1)THEN
            ICOMPL = 0
          END IF
       END IF

C     **********************************************************
C     ELEMENT BLOCK BY ELEMENT BLOCK INTERPOLATION
C     REQUIRED FOR ELEMENT DATA BUT ALSO USED FOR NODAL DATA
C     **********************************************************

        WRITE(NOUT,330)IM,IMP,IDBLKB
        WRITE(NOUT,320)IDBLKA
        WRITE(NTPOUT,330)IM,IMP,IDBLKB
        WRITE(NTPOUT,320)IDBLKA

        CALL EXGELB(NTP2EX,IDBLKA,TYP,NUMEBA,NELNDA,NATRIB,
     &              IERR)
        CALL EXGELB(NTP3EX,IDBLKB,TYP,NUMEBB,NELNDB,NATRIB,
     &              IERR)
        IF (NUMEBB .EQ. 0)THEN
          GO TO 50
        END IF

C set up arrays for element block-by-element block preliminaries
C these arrays will be deleted at the end of the loop

C IA(NACON)   =    ICONA(1:NELNDA,1:NUMEBA) - Mesh-A connectivity
C IA(NBCON)   =    ICONB(1:NELNDB,1:NUMEBB) - Mesh-B connectivity
C IA(NANDLST) =    NDLSTA(1:NODESA) - Mesh-A nodes in element block
C IA(NBNDLST) =    NDLSTB(1:NODESB) - Mesh-A nodes in element block
C  A(NASTAT)  =    STATUS(1:NUMEBA) - Mesh-A element status

        CALL MDRSRV ('ICONA',  NACON,   NELNDA*NUMEBA)
        CALL MDRSRV ('ICONB',  NBCON,   NELNDB*NUMEBB)
        CALL MDRSRV ('NDLSTA', NANDLST, NODESA)
        CALL MDRSRV ('NDLSTB', NBNDLST, NODESB)
        CALL MDRSRV ('STATUS', NASTAT,  NUMEBA)
        CALL MDSTAT (MNERRS, MNUSED)

        IF (MNERRS .NE. 0) THEN
          CALL MDEROR(NOUT)
          CALL ERROR('MAPVAR',
     &               'MEMORY MANAGER ERROR',
     &               'BLOCKS LOOP PRELIMINARIES',
     &               0,' ',0,' ',' ',1)
        END IF

c 2nd read of mesh A

        call debug('RDA2')
        CALL RDA2 (IDBLKA,IA(NACON),IA(NANDLST),A(NASTAT),
     &             MAXLN)

C Set the search box tolerance for the current mapping

        IF ( ITYPE .EQ. 13) THEN
C shell
          IF ( TOLSEA .GT. 0.0) THEN
            TOLSHL = TOLSEA
          ELSE
            TOLSHL = TOLSHC
          END IF
          WRITE( NOUT, 321) TOLSHL
          WRITE( NTPOUT, 321) TOLSHL
        ELSE IF ( ( ITYPE .EQ. 3) .OR.
     &            ( ITYPE .EQ. 4) .OR.
     &            ( ITYPE .EQ. 5)) THEN
C quad-4
          IF ( TOLSEA .GT. 0.0) THEN
            TOLQAD = TOLSEA
          ELSE
            TOLQAD = TOLQAC
          END IF
          WRITE( NOUT, 321) TOLQAD
          WRITE( NTPOUT, 321) TOLQAD
        ELSE IF ( ( ITYPE .EQ.  6) .OR.
     &            ( ITYPE .EQ. 10)) THEN
C hex-8 or tet-8
          IF ( TOLSEA .GT. 0.0) THEN
            TOLHEX = TOLSEA
            TOLTET = TOLSEA
          ELSE
            TOLHEX = TOLHEC
            TOLTET = TOLTEC
          END IF
          IF ( ITYPE .EQ. 6) THEN
            WRITE( NOUT, 321) TOLTET
            WRITE( NTPOUT, 321) TOLTET
          ELSE
            WRITE( NOUT, 321) TOLHEX
            WRITE( NTPOUT, 321) TOLHEX
          END IF
        ELSE
          CALL ERROR ('MAPVAR','INCORRECT ELEMENT TYPE',
     &                'ELEMENT TYPE =',ITYPE,
     &                'NOT YET IMPLEMENTED',0,' ',' ',1)
        END IF

c 2nd read of mesh-b

        call debug('RDB2')
        CALL RDB2(IDBLKB,IDBLKA,IA(NBCON),IA(NBNDLST))

C set up arrays for element block-by-element block processing
C these arrays will be deleted at the end of the loop

C IA(NS1)     =  ISRCHR(1:1(NISR),1:NUMNDB) Integer search results
C  A(NS2)     =  RSRCHR(1:6(NRSR),1:NUMNDB) Real search results
C IA(NS3)     =    LIST(1:NUMNDB)         Potential contacts
C IA(NS4)     =     IND(1:NUMNDB,1:3)     Index array point order
C IA(NS5)     =    IRNK(1:NUMNDB,1:3)     Rank array
C IA(NS6)     =   IRNK2(1:NUMNDB,1:3,1:2) Indirect rank array
C IA(NS7)     =    INDX(1:NUMNDB)         Intermediate list potential
C                                         pairs (intersection lists)
C IA(NS8)     =     ILO(1:LBLK,1:3)       Min index search box
C IA(NS9)     =     IUP(1:LBLK,1:3)       Max index search box
C IA(NS10)    =     IDP(1:LBLK)           Points paired with element
C IA(NS11)    =     IDS(1:LBLK)           Elements paired with point
C  A(NS12)    =    XMIN(1:LBLK,1:3)       Min dim search box
C  A(NS13)    =    XMAX(1:LBLK,1:3)       Max dim search box
C IA(NS14)    =    ISCR(1:NISS,1:LBLK)    Integer scratch
C  A(NS15)    =    RSCR(1:NRSS,1:LBLK)    Real scratch
C  A(NS16)    =    XYZSRF(1:NODESA,1:3)   Coords defining element
C  A(NS17)    =    XYZPTS(1:NUMNDB,1:3)   Coords of points searched

C  A(NASOLE)  =    SOLEA(1:NUMEBA,1:NVAREL) - Mesh-A element data
C  A(NBSOLE)  =    SOLEB(1:NUMEBB,1:NVAREL) - Mesh-B interpolated
C                                              element data
C  A(NASOLEN) =    SOLENA(1:NODESA,1:NVAREL) - Mesh-A element data
C                                               "scattered" to nodes
C IA(NANELTN) =    NELTN(1:NODESA) - Mesh-A number of elements per
C                                     node Used for computing averages
C IA(NAINVLN) =    INVLNA(1:NODESA) - Mesh-Anumber of elements per
C                                      node in inverse connectivity
C IA(NAINVC)  =    INVCN(1:MAXLN,1:NODESA) Inverse connectivity
C IA(NACTR)   =    CNTRA(1:NUMEBA,1:3) - Mesh-A element centroids
        LBLK = 1
        IDIM = MAX(NUMNDB, NUMEBB)
        CALL MDRSRV ('ISRCHR', NS1,  1*idim)
        CALL MDRSRV ('RSRCHR', NS2,  6*idim)
        CALL MDRSRV ('LIST',   NS3,  idim)
        CALL MDRSRV ('IND',    NS4,  idim*3)
        CALL MDRSRV ('IRNK',   NS5,  idim*3)
        CALL MDRSRV ('IRNK2',  NS6,  idim*6)
        CALL MDRSRV ('INDX',   NS7,  idim)
        CALL MDRSRV ('ILO',    NS8,  LBLK*3)
        CALL MDRSRV ('IUP',    NS9,  LBLK*3)
        CALL MDRSRV ('IDP',    NS10, LBLK)
        CALL MDRSRV ('IDS',    NS11, LBLK)
        CALL MDRSRV ('XMIN',   NS12, LBLK*3)
        CALL MDRSRV ('XMAX',   NS13, LBLK*3)
        CALL MDRSRV ('ISCR',   NS14, NISS*LBLK)
        CALL MDRSRV ('RSCR',   NS15, NRSS*LBLK)
        CALL MDRSRV ('XYZSRF', NS16, NODESA*3)
        CALL MDRSRV ('XYZPTS', NS17, idim*3)

        CALL MDRSRV ('SOLEA',  NASOLE,  NUMEBA*NVAREL)
        CALL MDRSRV ('SOLEB',  NBSOLE,  NUMEBB*NVAREL)

        IF (ISCHEM .EQ. 0)THEN
          CALL MDRSRV ('SOLENA', NASOLEN, NODESA*NVAREL)
          CALL MDRSRV ('NELTN',  NANELTN, NODESA)
        ELSE IF (ISCHEM .EQ. 1)THEN
          CALL MDRSRV ('SOLENA', NASOLEN, NODESA*NVAREL)
          CALL MDRSRV ('INVLNA', NAINVLN, NODESA)
          CALL MDRSRV('INVCN', NAINVC, MAXLN*NODESA)
          CALL MDRSRV ('CNTRA',  NACTR,   NUMEBA*3)
        ELSE IF (ISCHEM .EQ. 2)THEN
          CONTINUE
        ELSE IF (ISCHEM .EQ. 3)THEN
          CALL MDRSRV ('CNTRA',  NACTR,   NUMEBA*3)
          CALL MDRSRV ('INVLNA', NAINVLN, NODESA)
          CALL MDRSRV ('INVCN',  NAINVC,  MAXLN*NODESA)
          CALL MDRSRV ('ICHKEL', NICHKE,  NUMEBA)
          CALL MDRSRV ('SOLGRA', NSOLGR,  NDIMA*NUMEBA*NVAREL)
        ELSE

          CALL ERROR('MAPVAR',' ','ISCHEM',
     &               ischem,'INCORRECT ARGUMENT',0,' ',' ',1)
        END IF

        CALL MDSTAT (MNERRS, MNUSED)
        IF (MNERRS .NE. 0) THEN
          CALL MDEROR(NOUT)
          CALL ERROR('MAPVAR',
     &               'MEMORY MANAGER ERROR',
     &               'JUST AFTER START OF BLOCKS LOOP',
     &               0,' ',0,' ',' ',1)
        END IF

        IF (ITYPE .EQ. 13)THEN

C     **********************************************************
C     Path through code for shells
C     **********************************************************

          call debug('BLDSRF')
          CALL BLDSRF(A(NAX),A(NAY),A(NAZ),A(NS16))

          IF (NVARNP .GT. 0)THEN

            call debug('BLDPTN')
            CALL BLDPTN(A(NBX),A(NBY),A(NBZ),IA(NBNDLST),A(NS17))

            call debug('SRCHS-nodes')
            CALL SRCHS (NODESA,NUMEBA,IA(NACON),A(NS16),
     1       NUMNDB,A(NS17),TOLSHL,1,6,
     2       NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3       IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),IA(NS9),
     4       IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),IERR)

            call debug('SINTPN')
            CALL SINTPN(IA(NACON),A(NASOLN),IA(NS1),1,A(NS2),6,
     1                  A(NBSOLN),IA(NBNDLST),A(NBX),A(NBY),A(NBZ),
     2                  IDBLKB,A(NT1),INSUB,A(NSN))

          END IF
          IF (NVAREL .GT. 0)THEN

            call debug('BLDPTE')
            CALL BLDPTE(A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NS17))

            call debug('SRCHS-element centroids')
            CALL SRCHS (NODESA,NUMEBA,IA(NACON),A(NS16),
     1       NUMEBB,A(NS17),TOLSHL,1,6,
     2       NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3       IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),IA(NS9),
     4       IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),IERR)

c element centroid values to nodes by averaging

            IF (ISCHEM .EQ. 0)THEN

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 610 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('SETON0')
                CALL SETON0(IA(NACON),IA(NANELTN),A(NASOLE),
     &           A(NASOLEN),IDBLKA,A(NAX),A(NAY),A(NAZ),ISTP,
     &           IA(ITTB),IBLKB)

                call debug('SINTPE')
                CALL SINTPE(IA(NACON),A(NASOLEN),IA(NS1),1,A(NS2),6,
     &                      A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     &                      IA(NBCON),IA(ITTB),IBLKB,A(NT1),A(NS17),
     &                      ISTP,IST,INSUB,ICOMPL,A(NSE))
  610         CONTINUE

            ELSE IF (ISCHEM .EQ. 1) THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 620 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('SETON1')
                CALL SETON1(A(NACTR),A(NASOLE),A(NASOLEN),IDBLKA,
     &                    A(NAX),A(NAY),A(NAZ),IA(NACON),IA(NANDLST),
     &                    IA(NAINVLN),IA(NAINVC),MAXLN,ISTP,
     &                    IA(ITTB),IBLKB)

                call debug('SINTPE')
                CALL SINTPE(IA(NACON),A(NASOLEN),IA(NS1),1,A(NS2),6,
     &                      A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     &                      IA(NBCON),IA(ITTB),IBLKB,A(NT1),A(NS17),
     &                      ISTP,IST,INSUB,ICOMPL,A(NSE))
  620         CONTINUE

            ELSE IF (ISCHEM .EQ. 2) THEN

c direct transfer, does not require scatter to nodes

              call debug('STRAN')
              CALL STRAN(IA(NS1),1,A(NASOLE),A(NBSOLE),
     &                    IDBLKA,IDBLKB,
     &                    IA(ITTB),IBLKB,A(NT1),A(NS17),
     &                    INSUB,ICOMPL,
     &                    A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))

            ELSE IF (ISCHEM .EQ. 3)THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 630 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELGRAD')
                CALL ELGRAD(A(NACTR),A(NAX),A(NAY),A(NAZ),
     &                      A(NASOLE),A(NSOLGR),IA(NICHKE),
     &                      IDBLKA,IA(NACON),IA(NAINVLN),IA(NAINVC),
     &                      MAXLN,ISTP,IA(ITTB),IBLKB)

                call debug('INTRP3')
                CALL INTRP3(A(NACTR),A(NS17),IA(NS1),
     &                      A(NBSOLE),A(NASOLE),A(NSOLGR),
     &                      IDBLKB,IA(ITTB),IBLKB,A(NT1),
     &                      ISTP,IST,INSUB,ICOMPL,
     &                      A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))
 630          CONTINUE

            ELSE
              CALL ERROR('MAPVAR',' ','ISCHEM =',
     &                 ischem,'INCORRECT ARGUMENT',0,' ',' ',1)
            END IF

          END IF

C ITYPE = 3 - 4 node quad
C ITYPE = 4 - 8 node quad
C ITYPE = 5 - 9 node quad

        ELSE IF (ITYPE .EQ. 3 .OR. ITYPE .EQ. 4 .OR.
     &           ITYPE .EQ. 5) THEN

C     *****************************************************
C     PATH THROUGH CODE FOR CONTINUUM ELEMENTS
C              (QUAD-4)
C     *****************************************************

C find and store location of mesh-b nodes within mesh-a

          call debug('BLDSRF')
          CALL BLDSRF(A(NAX),A(NAY),A(NAZ),A(NS16))

          IF (NVARNP .GT. 0)THEN

            call debug('BLDPTN')
            CALL BLDPTN(A(NBX),A(NBY),A(NBZ),IA(NBNDLST),A(NS17))

            call debug('SRCHQ-nodes')
            CALL SRCHQ (NODESA,NUMEBA,IA(NACON),A(NS16),
     1       NUMNDB,A(NS17),TOLQAD,1,3,
     2       NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3       IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),IA(NS9),
     4       IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),IERR)
c           DO 530 I = 1, NUMNDB
c             IF (IA(NS1-1+I) .EQ. 0)THEN
c               WRITE(NOUT,430)IA(NBNDLST-1+I),IDBLKB
c               WRITE(NTPOUT,430)IA(NBNDLST-1+I),IDBLKB
c             END IF
c 530       CONTINUE

c   interpolate nodal variables

c            write(nout,1037)
c            write(ntpout,1037)
            CALL INTRPN(IA(NACON),A(NASOLN),IA(NS1),A(NS2),
     &                A(NBSOLN),IA(NBNDLST),A(NBX),A(NBY),A(NBZ),
     &                IDBLKB,A(NT1),INSUB,A(NSN))

c start element variable interpolation

c locate Mesh-B element centroid in Mesh-A

          END IF
          IF (NVAREL .GT. 0)THEN

            call debug('BLDPTE')
            CALL BLDPTE(A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NS17))

            call debug('SRCHQ-element centroids')
            CALL SRCHQ (NODESA,NUMEBA,IA(NACON),A(NS16),
     1       NUMEBB,A(NS17),TOLQAD,1,3,
     2       NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3       IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),IA(NS9),
     4       IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),IERR)

c element centroid variables averaged to nodes

            IF (ISCHEM .EQ. 0)THEN

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 640 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELTON0')
                CALL ELTON0(IA(NACON),IA(NANELTN),A(NASOLE),
     &           A(NASOLEN),IDBLKA,A(NAX),A(NAY),A(NAZ),ISTP,
     &           IA(ITTB),IBLKB)

c interpolate element vars

                call debug('INTRPE')
                CALL INTRPE(IA(NACON),A(NASOLEN),IA(NS1),A(NS2),
     1                    A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     2                    IA(NBCON),IA(ITTB),IBLKB,A(NT1),
     3                    A(NS17),ISTP,IST,INSUB,ICOMPL,A(NSE))
  640         CONTINUE

c element centroid variables linear least squares to nodes

            ELSE IF (ISCHEM .EQ. 1)THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 650 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELTON1')
                CALL ELTON1(A(NACTR),A(NASOLE),A(NASOLEN),IDBLKA,
     &                    A(NAX),A(NAY),A(NAZ),IA(NACON),IA(NANDLST),
     &                    IA(NAINVLN),IA(NAINVC),MAXLN,ISTP,
     &                    IA(ITTB),IBLKB)

c interpolate element vars

                call debug('INTRPE')
                CALL INTRPE(IA(NACON),A(NASOLEN),IA(NS1),A(NS2),
     1                    A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     2                    IA(NBCON),IA(ITTB),IBLKB,A(NT1),
     3                    A(NS17),ISTP,IST,INSUB,ICOMPL,A(NSE))
  650         CONTINUE

            ELSE IF (ISCHEM .EQ. 2)THEN

c direct transfer from Mesh-A to Mesh-B

              call debug('TRANAB')
              CALL TRANAB(IA(NS1),A(NASOLE),A(NBSOLE),
     &                  IDBLKA,IDBLKB,
     &                  IA(ITTB),IBLKB,A(NT1),A(NS17),
     &                  INSUB,ICOMPL,
     &                  A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))

            ELSE IF (ISCHEM .EQ. 3)THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 660 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELGRAD')
                CALL ELGRAD(A(NACTR),A(NAX),A(NAY),A(NAZ),
     &                    A(NASOLE),A(NSOLGR),IA(NICHKE),
     &                    IDBLKA,IA(NACON),IA(NAINVLN),IA(NAINVC),
     &                    MAXLN,ISTP,IA(ITTB),IBLKB)

                call debug('INTRP3')
                CALL INTRP3(A(NACTR),A(NS17),IA(NS1),
     &                    A(NBSOLE),A(NASOLE),A(NSOLGR),
     &                    IDBLKB,IA(ITTB),IBLKB,A(NT1),
     &                    ISTP,IST,INSUB,ICOMPL,
     &                    A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))
 660          CONTINUE
            ELSE
              CALL ERROR('MAPVAR',' ','ISCHEM =',
     &                 ischem,'INCORRECT ARGUMENT',0,' ',' ',1)
            END IF

          END IF

        ELSE IF (ITYPE .EQ. 10 .OR. ITYPE .EQ. 6) THEN

C     *****************************************************
C     PATH THROUGH CODE FOR 3-D CONTINUUM ELEMENTS
C              (HEX-8) OR (TET-8)
C     *****************************************************

C     FIND AND STORE LOCATION OF MESH-B NODES WITHIN MESH-A

          call debug('BLDSRF')
          CALL BLDSRF(A(NAX),A(NAY),A(NAZ),A(NS16))

          IF (NVARNP .GT. 0)THEN

            call debug('BLDPTN')
             CALL BLDPTN(A(NBX),A(NBY),A(NBZ),IA(NBNDLST),A(NS17))

            IF (ITYPE .EQ. 10)THEN
              call debug('SRCHH-nodes')
              CALL SRCHH (NODESA,NUMEBA,IA(NACON),A(NS16),
     1          NUMNDB,A(NS17),TOLHEX,1,3,
     2          NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3          IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),
     4          IA(NS9),
     5          IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),
     6          IERR)

            ELSEIF (ITYPE .EQ. 6)THEN
              call debug('SRCHT-nodes')
              CALL SRCHT (NODESA,NUMEBA,IA(NACON),A(NS16),
     1          NUMNDB,A(NS17),TOLHEX,1,3,
     2          NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3          IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),
     4          IA(NS9),
     5          IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),
     6          IERR)
            END IF

c interpolate nodal variables

            call debug('INTRPN')
            CALL INTRPN(IA(NACON),A(NASOLN),IA(NS1),A(NS2),
     &                A(NBSOLN),IA(NBNDLST),A(NBX),A(NBY),A(NBZ),
     &                IDBLKB,A(NT1),INSUB,A(NSN))

c start element variable interpolation

c locate Mesh-B element centroid in Mesh-A

          END IF
          IF (NVAREL .GT. 0)THEN

            call debug('BLDPTE')
            CALL BLDPTE(A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NS17))

            IF (ITYPE .EQ. 10)THEN
              call debug('SRCHH-element centroids')
              CALL SRCHH (NODESA,NUMEBA,IA(NACON),A(NS16),
     1          NUMEBB,A(NS17),TOLHEX,1,3,
     2          NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3          IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),
     4          IA(NS9),
     5          IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),
     6          IERR)

            ELSEIF (ITYPE .EQ. 6)THEN
              call debug('SRCHT-element centroids')
              CALL SRCHT (NODESA,NUMEBA,IA(NACON),A(NS16),
     1          NUMEBB,A(NS17),TOLHEX,1,3,
     2          NISS,NRSS,IA(NS1),A(NS2),LBLK,
     3          IA(NS3),IA(NS4),IA(NS5),IA(NS6),IA(NS7),IA(NS8),
     4          IA(NS9),
     5          IA(NS10),IA(NS11),A(NS12),A(NS13),IA(NS14),A(NS15),
     6          IERR)
            END IF

            IF (ISCHEM .EQ. 0)THEN

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 670 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELTON0')
                CALL ELTON0(IA(NACON),IA(NANELTN),A(NASOLE),
     &               A(NASOLEN),IDBLKA,A(NAX),A(NAY),A(NAZ),ISTP,
     &               IA(ITTB),IBLKB)

c interpolate element vars

                call debug('INTRPE')
                CALL INTRPE(IA(NACON),A(NASOLEN),IA(NS1),A(NS2),
     1                    A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     2                    IA(NBCON),IA(ITTB),IBLKB,A(NT1),
     3                    A(NS17),ISTP,IST,INSUB,ICOMPL,A(NSE))
  670         CONTINUE

            ELSE IF (ISCHEM .EQ. 1)THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 680 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELTON1')
                CALL ELTON1(A(NACTR),A(NASOLE),A(NASOLEN),IDBLKA,
     &                    A(NAX),A(NAY),A(NAZ),IA(NACON),IA(NANDLST),
     &                    IA(NAINVLN),IA(NAINVC),MAXLN,ISTP,
     &                    IA(ITTB),IBLKB)

c interpolate element vars

                call debug('INTRPE')
                CALL INTRPE(IA(NACON),A(NASOLEN),IA(NS1),A(NS2),
     1                    A(NBSOLE),IDBLKB,A(NBX),A(NBY),A(NBZ),
     2                    IA(NBCON),IA(ITTB),IBLKB,A(NT1),
     3                    A(NS17),ISTP,IST,INSUB,ICOMPL,A(NSE))
  680         CONTINUE

            ELSE IF (ISCHEM .EQ. 2)THEN

c direct transfer from Mesh-A to Mesh-B

              call debug('TRANAB')
              CALL TRANAB(IA(NS1),A(NASOLE),A(NBSOLE),
     &                IDBLKA,IDBLKB,
     &                IA(ITTB),IBLKB,A(NT1),A(NS17),
     &                INSUB,ICOMPL,
     &                A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))

            ELSE IF (ISCHEM .EQ. 3)THEN

              call debug('INVCON')
              CALL INVCON(IA(NAINVLN),MAXLN,IA(NAINVC),IA(NACON))

C Set up time steps

              IF (ISTEP .EQ. -1)THEN
                NTM = NTIMES
              ELSE
                NTM = 1
              END IF

              DO 690 IST = 1, NTM
                IF (ISTEP .EQ. -1)THEN
                  ISTP = IST
                ELSE
                  ISTP = ISTEP
                END IF

                call debug('ELGRAD')
                CALL ELGRAD(A(NACTR),A(NAX),A(NAY),A(NAZ),
     &                    A(NASOLE),A(NSOLGR),IA(NICHKE),
     &                    IDBLKA,IA(NACON),IA(NAINVLN),IA(NAINVC),
     &                    MAXLN,ISTP,IA(ITTB),IBLKB)

                call debug('INTRP3')
                CALL INTRP3(A(NACTR),A(NS17),IA(NS1),
     &                    A(NBSOLE),A(NASOLE),A(NSOLGR),
     &                    IDBLKB,IA(ITTB),IBLKB,A(NT1),
     &                    ISTP,IST,INSUB,ICOMPL,
     &                    A(NBX),A(NBY),A(NBZ),IA(NBCON),A(NSE))
 690          CONTINUE

            ELSE
              CALL ERROR('MAPVAR',' ','ISCHEM =',
     &                 ischem,'INCORRECT ARGUMENT',0,' ',' ',1)
            END IF

          END IF
        ELSE
          CALL ERROR ('MAPVAR','INCORRECT ELEMENT TYPE',
     &              'ELEMENT TYPE =',ITYPE,
     &              'NOT YET IMPLEMENTED',0,' ',' ',1)

        END IF

        IF (IACCU .EQ. 1)THEN

C velocities and mass are available, compute momenta and k.e.
C 1st set up storage for mass

          IF (IELMS .NE. 0 .AND. IDENS .EQ. 0)THEN

C  A(NEMSA)   = EMSSA(1:NODESA) - element mass in mesh-A
C  A(NEMSB)   = EMSSB(1:NODESB) - element mass in mesh-B

            CALL MDRSRV ('EMSSA',   NEMSA,   NUMEBA)
            CALL MDRSRV ('DENSA',   NDENA,   1)
            CALL MDRSRV ('EMSSB',   NEMSB,   NUMEBB)
            CALL MDRSRV ('DENSB',   NDENB,   1)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                   'MEMORY MANAGER ERROR',
     &                   'CHECK ACCURACY - ELEMENT MASS',
     &                   0,' ',0,' ',' ',1)
            END IF
          ELSE IF(IDENS .NE. 0)THEN

C  A(NEMSA)   = EMSSA(1:NUMEBA) - element mass in mesh-A
C  A(NEMSB)   = EMSSB(1:NUMEBB) - element mass in mesh-B
C  A(NDENA)   = DENSA(1:NUMEBA) - element density in mesh-A
C  A(NDENB)   = DENSB(1:NUMEBB) - element density in mesh-B

            CALL MDRSRV ('EMSSA',   NEMSA,   NUMEBA)
            CALL MDRSRV ('DENSA',   NDENA,   NUMEBA)
            CALL MDRSRV ('EMSSB',   NEMSB,   NUMEBB)
            CALL MDRSRV ('DENSB',   NDENB,   NUMEBB)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                   'MEMORY MANAGER ERROR',
     &                   'CHECK ACCURACY - ELEMENT MASS',
     &                    0,' ',0,' ',' ',1)
            END IF
          END IF

          IF (NDIMA .EQ. 3)THEN

C  A(NSXXA)  = SIGXXA(1:NUMEBA) - XX component of stress tensor
C  A(NSYYA)  = SIGYYA(1:NUMEBA) - YY component of stress tensor
C  A(NSZZA)  = SIGZZA(1:NUMEBA) - ZZ component of stress tensor
C  A(NSXYA)  = SIGXYA(1:NUMEBA) - XY component of stress tensor
C  A(NSYZA)  = SIGYZA(1:NUMEBA) - YZ component of stress tensor
C  A(NSZXA)  = SIGZXA(1:NUMEBA) - ZX component of stress tensor
C  A(NSXXB)  = SIGXXB(1:NUMEBB) - XX component of stress tensor
C  A(NSYYB)  = SIGYYB(1:NUMEBB) - YY component of stress tensor
C  A(NSZZB)  = SIGZZB(1:NUMEBB) - ZZ component of stress tensor
C  A(NSXYB)  = SIGXYB(1:NUMEBB) - XY component of stress tensor
C  A(NSYZB)  = SIGYZB(1:NUMEBB) - YZ component of stress tensor
C  A(NSZXB)  = SIGZXB(1:NUMEBB) - ZX component of stress tensor

            CALL MDRSRV ('SIGXXA' , NSXXA,  NUMEBA)
            CALL MDRSRV ('SIGYYA' , NSYYA,  NUMEBA)
            CALL MDRSRV ('SIGZZA' , NSZZA,  NUMEBA)
            CALL MDRSRV ('SIGXYA' , NSXYA,  NUMEBA)
            CALL MDRSRV ('SIGYZA' , NSYZA,  NUMEBA)
            CALL MDRSRV ('SIGZXA' , NSZXA,  NUMEBA)
            CALL MDRSRV ('SIGXXB' , NSXXB,  NUMEBB)
            CALL MDRSRV ('SIGYYB' , NSYYB,  NUMEBB)
            CALL MDRSRV ('SIGZZB' , NSZZB,  NUMEBB)
            CALL MDRSRV ('SIGXYB' , NSXYB,  NUMEBB)
            CALL MDRSRV ('SIGYZB' , NSYZB,  NUMEBB)
            CALL MDRSRV ('SIGZXB' , NSZXB,  NUMEBB)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                   'MEMORY MANAGER ERROR',
     &                   'CHECK ACCURACY - ELEMENT MASS',
     &                    0,' ',0,' ',' ',1)
            END IF
          ELSE IF (NDIMA .EQ. 2)THEN

C  A(NSXXA)  = SIGXXA(1:NUMEBA) - XX component of stress tensor
C  A(NSYYA)  = SIGYYA(1:NUMEBA) - YY component of stress tensor
C  A(NSZZA)  = SIGZZA(1:NUMEBA) - ZZ component of stress tensor
C  A(NSXYA)  = SIGXYA(1:NUMEBA) - XY component of stress tensor
C  A(NSXXB)  = SIGXXB(1:NUMEBB) - XX component of stress tensor
C  A(NSYYB)  = SIGYYB(1:NUMEBB) - YY component of stress tensor
C  A(NSZZB)  = SIGZZB(1:NUMEBB) - ZZ component of stress tensor
C  A(NSXYB)  = SIGXYB(1:NUMEBB) - XY component of stress tensor

            CALL MDRSRV ('SIGXXA' , NSXXA,  NUMEBA)
            CALL MDRSRV ('SIGYYA' , NSYYA,  NUMEBA)
            CALL MDRSRV ('SIGZZA' , NSZZA,  NUMEBA)
            CALL MDRSRV ('SIGXYA' , NSXYA,  NUMEBA)
            CALL MDRSRV ('SIGYZA' , NSYZA,  1)
            CALL MDRSRV ('SIGZXA' , NSZXA,  1)
            CALL MDRSRV ('SIGXXB' , NSXXB,  NUMEBB)
            CALL MDRSRV ('SIGYYB' , NSYYB,  NUMEBB)
            CALL MDRSRV ('SIGZZB' , NSZZB,  NUMEBB)
            CALL MDRSRV ('SIGXYB' , NSXYB,  NUMEBB)
            CALL MDRSRV ('SIGYZB' , NSYZB,  1)
            CALL MDRSRV ('SIGZXB' , NSZXB,  1)
            CALL MDSTAT (MNERRS, MNUSED)
            IF (MNERRS .NE. 0) THEN
              CALL ERROR ('MAPVAR',
     &                   'MEMORY MANAGER ERROR',
     &                   'CHECK ACCURACY - ELEMENT MASS',
     &                    0,' ',0,' ',' ',1)
            END IF
          END IF

C Set up time steps

          IF (ISTEP .EQ. -1)THEN
            NTM = NTIMES
          ELSE
            NTM = 1
          END IF

          DO 710 IST = 1, NTM
            IF (ISTEP .EQ. -1)THEN
              ISTP = IST
            ELSE
              ISTP = ISTEP
            END IF

            CALL MKEI(IST,ISTP,A(NT1),IDBLKA,IA(NACON),IA(NANDLST),
     &               A(NAX),A(NAY),A(NAZ),A(NVXA),A(NVYA),A(NVZA),
     &               A(NEMSA),A(NDENA),A(NNMSA),
     &               A(NTMXA),A(NTMYA),A(NTMZA),A(NTKEA),A(NTPSQA),
     &                                                   A(NTJ2A),
     &               A(NSXXA),A(NSYYA),A(NSZZA),A(NSXYA),A(NSYZA),
     &                                                   A(NSZXA),
     &               IDBLKB,IA(NBCON),IA(NBNDLST),
     &               A(NBX),A(NBY),A(NBZ),A(NVXB),A(NVYB),A(NVZB),
     &               A(NEMSB),A(NDENB),A(NNMSB),
     &               A(NTMXB),A(NTMYB),A(NTMZB),A(NTKEB),A(NTPSQB),
     &                                          A(NTJ2B),ICOMPL,
     &               A(NSXXB),A(NSYYB),A(NSZZB),A(NSXYB),A(NSYZB),
     &                                                   A(NSZXB))
  710     CONTINUE

          CALL MDDEL ('EMSSA')
          CALL MDDEL ('DENSA')
          CALL MDDEL ('EMSSB')
          CALL MDDEL ('DENSB')
          CALL MDDEL ('SIGXXA')
          CALL MDDEL ('SIGYYA')
          CALL MDDEL ('SIGZZA')
          CALL MDDEL ('SIGXYA')
          CALL MDDEL ('SIGYZA')
          CALL MDDEL ('SIGZXA')
          CALL MDDEL ('SIGXXB')
          CALL MDDEL ('SIGYYB')
          CALL MDDEL ('SIGZZB')
          CALL MDDEL ('SIGXYB')
          CALL MDDEL ('SIGYZB')
          CALL MDDEL ('SIGZXB')

        END IF

C     *****************************************************************
C     CLEAN UP STUFF FOR NEXT ELEMENT BLOCK
C     *****************************************************************

        CALL MDDEL ('ISRCHR')
        CALL MDDEL ('RSRCHR')
        CALL MDDEL ('LIST')
        CALL MDDEL ('IND')
        CALL MDDEL ('IRNK')
        CALL MDDEL ('IRNK2')
        CALL MDDEL ('INDX')
        CALL MDDEL ('ILO')
        CALL MDDEL ('IUP')
        CALL MDDEL ('IDP')
        CALL MDDEL ('IDS')
        CALL MDDEL ('XMIN')
        CALL MDDEL ('XMAX')
        CALL MDDEL ('ISCR')
        CALL MDDEL ('RSCR')
        CALL MDDEL ('XYZSRF')
        CALL MDDEL ('XYZPTS')
        CALL MDDEL ('ICONA')
        CALL MDDEL ('ICONB')
        CALL MDDEL ('NDLSTA')
        CALL MDDEL ('NDLSTB')
        CALL MDDEL ('SOLEA')
        CALL MDDEL ('SOLEB')
        IF (ISCHEM .EQ. 0)THEN
          CALL MDDEL ('SOLENA')
          CALL MDDEL ('NELTN')
        ELSE IF (ISCHEM .EQ. 1)THEN
          CALL MDDEL ('SOLENA')
          CALL MDDEL ('INVLNA')
          CALL MDDEL ('INVCN')
          CALL MDDEL ('CNTRA')
        ELSE IF (ISCHEM .EQ. 2)THEN
          CONTINUE
        ELSE IF (ISCHEM .EQ. 3)THEN
          CALL MDDEL ('CNTRA')
          CALL MDDEL ('INVLNA')
          CALL MDDEL ('INVCN')
          CALL MDDEL ('ICHKEL')
          CALL MDDEL ('SOLGRA')
        END IF
        CALL MDDEL ('STATUS')
        CALL MDSTAT (MNERRS, MNUSED)
        IF (MNERRS .NE. 0) THEN
           CALL MDEROR(NOUT)
        END IF

 50   CONTINUE

C     *****************************************************************
C     STOP COMMAND
C     *****************************************************************

C     CLOSE FILES AND STOP

      CALL BANNR2(84,'NORMAL',NTPOUT)
      CALL BANNR2(84,'EXIT',NTPOUT)
      call debug('CLSFIL')
      CALL CLSFIL

      call addlog (qainfo(1))
      call wrapup(qainfo(1))
      call mdfree()
      STOP

  270 FORMAT (3X,/'DATA FROM MESH "A" (MESH & SOLUTION) FILE - ',A,
     *        //,10X,'HEADING - ',A,/)
  280 FORMAT (10x,I1,'-DIMENSIONAL MODEL',/
     &       ,10X,'NUMBER OF NODES IN MESH A (nodesa) -      ',I9,/
     &       ,10X,'NUMBER OF ELEMENTS IN MESH A (numela) -   ',I9,/
     &       ,10X,'NUMBER OF ELEMENT BLOCKS IN A (nblksa) -  ',I9)
  290 FORMAT (3X,/,'DATA FROM MESH "B" (MESH) FILE - ',A,
     *        //,10X,'HEADING - ',A,/)
  300 FORMAT (10x,I1,'-DIMENSIONAL MODEL',/
     &       ,10X,'NUMBER OF NODES IN MESH B (nodesb) -      ',I7,/
     &       ,10X,'NUMBER OF ELEMENTS IN MESH B (numelb) -   ',I7,/
     &       ,10X,'NUMBER OF ELEMENT BLOCKS IN B (nblksb) -  ',I7)
  320 FORMAT (10X,'CORRESPONDS TO MESH-A ELEMENT BLOCK ID',I7,/)
  321 FORMAT (10X,'USING SEARCH BOX TOLERANCE            ',F14.6,/)
  330 FORMAT (10X,'WORKING ON MESH-B ELEMENT BLOCK       ',I7,/
     &       ,10X,'ELEMENT BLOCK ID                      ',I7)
      END

      BLOCK DATA INITLZ

C     ******************************************************************

C     BLOCK DATA SUBROUTINE TO INITIALIZE VARIABLES STORED IN
C     NAMED COMMON BLOCKS

C     ******************************************************************

C...NOTE: Cannot include exodusII.inc in a block data routine.
      PARAMETER (MXSTLN=32)
c      CHARACTER*10 ELTYPE

      include 'header.blk'
      include 'ntpdat.blk'
      include 'contrl.blk'
      include 'amesh.blk'
      include 'bmesh.blk'
      include 'aexds1.blk'
      include 'schdat.blk'
      include 'tapes.blk'
      include 'toldat.blk'
      include 'varnpt.blk'
      include 'varept.blk'
      include 'debg.blk'
      include 'inival.blk'

      DATA HED/' '/
      DATA NOUT,NTPOUT,NTP2,NTP3,NTP4/
     1     6,7,12,13,14/
      DATA (IFILES(I),I=1,5)/5*0/
      DATA ISCHEM/1/
      DATA IDEF/1/
      DATA IDEBUG/0/
      DATA IACCU/0/
      DATA IXDIS,IYDIS,IZDIS,IXVEL,IYVEL,IZVEL/6*0/
      DATA ISXX,ISYY,ISZZ,ISXY,ISYZ,ISZX,IELMS,IDENS/8*0/
      DATA NUMELA,NODESA,NBLKSA,NDIMA,NELNDA/5*0/
      DATA NUMELB,NODESB,NBLKSB,NDIMB,NELNDB/5*0/
      DATA NQAREC,NVARGP,NVARNP,NVAREL/4*0/
c      DATA (ELTYPE(I),I=1,13)/'TRI3','TRI6','QUAD4','QUAD8','QUAD9',
c     1     'TETRA4','TETRA10','PRISM6','PRISM15','HEX8','HEX20',
c     2     'HEX27','SHELL'/
C      DATA (NNELM(I),I=1,13)/3,6,4,8,9,4,10,6,15,8,20,27,4/

      DATA VALINI /0.0/
      DATA TOLSHL,TOLQAD,TOLHEX,TOLTET,NISS,NRSS
     *  /0.01,0.01,0.01,0.01, 5,10/

C TOLSHL=extension of box around MESH-A shell element
C TOLQAD=extension of box around MESH-A quad element
C TOLHEX=extension of box around MESH-A hex element
C NISS=number of integer search scratch  (=5)
C NRSS=number of    real search scratch (=10)

      DATA TOL,EPS,STRLMT,ITERMX/0.01,0.01,20.,20/

C TOL=difference in isoparametric coords after newton iteration (don't change)
C EPS=tolerance used in checking if point is within element or coincident
C     with a node
C STRLMT=tolerance for isoparametric coords to lie within an element

      END

      subroutine getval(IMAP, IM, idblka, idblkb, ischem)
      integer imap(3,*)
      idblka = imap(1,im)
      idblkb = imap(2,im)
      ischem = imap(3,im)
      return
      end