[Nek5000-users] Compute the derivatives

nek5000-users at lists.mcs.anl.gov nek5000-users at lists.mcs.anl.gov
Thu Jul 8 09:59:57 CDT 2010


B
Hi Fred,

If you're using the splitting formulation (lx2=lx1), then there
should be no problem.  Otherwise you first need to map pressure
to the velocity mesh (mesh1), which can be done via:

       common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
      $    ,pa (lx1,ly2,lz2)     ,pb (lx1,ly1,lz2)

       call mappr(pm1,pr,pa,pb)

Note that for the Pn-Pn-2 method pressure is discontinuous
and of course the same holds for all the derivatives (but
the jumps should be small if you are well-resolved).

Paul

PS - note to group:  mappr may need to be fixed for axisymm. case..







On Wed, 7 Jul 2010, nek5000-users at lists.mcs.anl.gov wrote:

> Hi NEKs,
>
> for the validation of my simulation I need the 1st derivative of the
> pressure and the 2nd of the velocity. When I use twice "call gradm1" to
> calculate and "call outpost" to write the 2nd derivative for my velocity
> field it works pretty well. But for the pressure field it goes wrong. I
> think this is due to the fact, that the pressure meshed differently compared
> to the velocity field. Does there exist a subroutine to calculate the
> derivatives of the pressure or do I have to write something by my own??
>
> Thanks a lot.
>
> Best, Fred
>
> _______________________________________________
> Nek5000-users mailing list
> Nek5000-users at lists.mcs.anl.gov
> https://lists.mcs.anl.gov/mailman/listinfo/nek5000-users
>
c-----------------------------------------------------------------------
       subroutine prepost(ifdoin,prefin)

c     Store results for later postprocessing
c
c     Recent updates:
c
c     p65 now indicates the number of parallel i/o files; iff p66 >= 6
c

       include 'SIZE'
       include 'TOTAL'
       include 'CTIMER'
C
C     Work arrays and temporary arrays
C
       common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
c
c     note, this usage of CTMP1 will be less than elsewhere if NELT ~> 3.
       parameter (lxyz=lx1*ly1*lz1)
       parameter (lpsc9=ldimt+9)
       common /ctmp1/ tdump(lxyz,lpsc9)
       real*4         tdump
       real           tdmp(4)
       equivalence   (tdump,tdmp)

       real*4         test_pattern
c
       character*3    prefin,prefix
       character*1    fhdfle1(132)
       character*132   fhdfle
       equivalence   (fhdfle,fhdfle1)
       character*1    fldfile2(120)
       integer        fldfilei( 60)
       equivalence   (fldfilei,fldfile2)
c
c
       common /doit/ ifdoit
       logical       ifdoit
       logical       ifdoin
C 
C
       real hdump(25)
       real xpart(10),ypart(10),zpart(10)
       character*10 frmat
       integer nopen(99)
       save    nopen
       data    nopen /99*0/
       common /rdump/ ntdump
       data ndumps / 0 /
c
       logical ifhis
c
       integer maxstep
       save    maxstep
       data    maxstep /999999999/

       if (iostep.lt.0 .or. timeio.lt.0) return

#ifndef NOTIMER
       icalld=icalld+1
       nprep=icalld
       etime1=dnekclock()
#endif

c     Trigger history output only if prefix = 'his'   pff 8/18/05
       ifhis  = .false.
       prefix = prefin
       if (prefin.eq.'his') ifhis  = .true.
       if (prefix.eq.'his') prefix = '   '

       if(icalld.eq.0) then
         ierr = 0
         if (nid.eq.0) then
            write(6,*) 'schfile:',schfle

            open(unit=26,file=schfle,err=44,form='formatted',
      &          status='new')
            goto 45
   44       ierr = 1
   45    endif
         call err_chk(ierr,'.sch file already exists.$')
       endif

       call prepost_map(0) ! map pr and axisymm. arrays

       if(istep .ge. nsteps) lastep=1

       timdump=0
       if(timeio.ne.0.0)then
          if(time .ge. (ntdump + 1) * timeio) then
             timdump=1.
             ntdump=ntdump+1
          endif
       endif

       if (istep.gt.0 .and. iostep.gt.0) then
          if(mod(istep,iostep) .eq. 0) ifdoit=.true.
       endif


       ! check for io request in file 'ioinfo'
       iiidmp=0
       if (nid.eq.0 .and. (mod(istep,10).eq.0 .or. istep.lt.200)) then
          open(unit=87,file='ioinfo',status='old',err=88)
          read(87,*,end=87,err=87) idummy
          if (iiidmp.eq.0) iiidmp=idummy
          if (idummy.ne.0) then  ! overwrite last i/o request
             rewind(87)
             write(87,86)
    86       format(' 0')
          endif
    87    continue
          close(unit=87)
    88    continue
          if (iiidmp.ne.0) write(6,*) 'Output:',iiidmp
       endif

       tdmp(1)=iiidmp
       call gop(tdmp,tdmp(3),'+  ',1)
       iiidmp= tdmp(1)
       if (iiidmp.lt.0) maxstep=abs(iiidmp)
       if (istep.ge.maxstep.or.iiidmp.eq.-2) lastep=1
       if (iiidmp.eq.-2) return
       if (iiidmp.lt.0) iiidmp = 0

       if (ifdoin) ifdoit=.true.
       if (iiidmp.ne.0.or.lastep.eq.1.or.timdump.eq.1.) ifdoit=.true.

       if (ifdoit) call outfld(prefix)

       call outhis(ifhis)

       call prepost_map(1) ! map back axisymm. arrays

       if (lastep.eq.1 .and. nid.eq.0) close(unit=26)

#ifndef NOTIMER
       tprep=tprep+dnekclock()-etime1
#endif

       ifdoit=.false.
       return

       end
c-----------------------------------------------------------------------
       subroutine prepost_map(isave) ! isave=0-->fwd, isave=1-->bkwd

c     Store results for later postprocessing

       include 'SIZE'
       include 'TOTAL'
C
C     Work arrays and temporary arrays
C
       common /scruz/ vxax   (lx1,ly1,lelv)
      $             , vyax   (lx1,ly1,lelv)
      $             , prax   (lx2,ly2,lelv)
      $             , yax    (lx1,ly1,lelt)
       common /scrmg/ tax    (lx1,ly1,lelt,ldimt)
       common /scrcg/ pm1    (lx1,ly1,lz1,lelv)
C
c
       common /prepst/ pa(lx1,ly2,lz2),pb(lx1,ly1,lz2)
       integer e

       if (isave.eq.0) then ! map to GLL grid

          if (ifaxis) then
             ntotm1 = nx1*ny1*nelt
             call copy (yax,ym1,ntotm1)
             do 5 e=1,nelt
                if (ifrzer(e)) then
                   call mxm  (ym1(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
                   call copy (ym1(1,1,1,e),pb,nx1*ny1)
                endif
     5       continue
             if (ifflow) then
                ntotm1 = nx1*ny1*nelv
                ntotm2 = nx2*ny2*nelv
                call copy (vxax,vx,ntotm1)
                call copy (vyax,vy,ntotm1)
                call copy (prax,pr,ntotm2)
                do 10 e=1,nelv
                   if (ifrzer(e)) then
                      call mxm  (vx(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
                      call copy (vx(1,1,1,e),pb,nx1*ny1)
                      call mxm  (vy(1,1,1,e),nx1,iatjl1,ny1,pb,ny1)
                      call copy (vy(1,1,1,e),pb,nx1*ny1)
                      call mxm  (pr(1,1,1,e),nx2,iatjl2,ny2,pb,ny2)
                      call copy (pr(1,1,1,e),pb,nx2*ny2)
                   endif
  10            continue
             endif
             if (ifheat) then
                ntotm1 = nx1*ny1*nelt
                do 15 ifldt=1,npscal+1
                   call copy (tax(1,1,1,ifldt),t(1,1,1,1,ifldt),ntotm1)
  15            continue
                do 30 e=1,nelt
                   if (ifrzer(e)) then
                     do 25 ifldt=1,npscal+1
                       call mxm  (t(1,1,1,e,ifldt),nx1,iatjl1,ny1,
      $                                                  pb,ny1)
                       call copy (t(1,1,1,e,ifldt),pb,nx1*ny1)
  25                 continue
                   endif
  30            continue
             endif
          endif
C        Map the pressure onto the velocity mesh
C
          ntot1 = nx1*ny1*nz1*nelv
          nyz2  = ny2*nz2
          nxy1  = nx1*ny1
          nxyz  = nx1*ny1*nz1
C
          if (ifsplit) then
             call copy(pm1,pr,ntot1)
          else
             do 1000 e=1,nelv
                call mxm (ixm21,nx1,pr(1,1,1,e),nx2,pa(1,1,1),nyz2)
                do 100 iz=1,nz2
                   call mxm (pa(1,1,iz),nx1,iytm21,ny2,pb(1,1,iz),ny1)
   100          continue
                call mxm (pb(1,1,1),nxy1,iztm21,nz2,pm1(1,1,1,e),nz1)
  1000       continue
          endif

       else       ! map back

          if (ifaxis) then
             ntot1 = nx1*ny1*nelt
             call copy (ym1,yax,ntot1)
             if (ifflow) then
                ntot1 = nx1*ny1*nelv
                ntot2 = nx2*ny2*nelv
                call copy (vx,vxax,ntot1)
                call copy (vy,vyax,ntot1)
                call copy (pr,prax,ntot2)
             endif
             if (ifheat) then
                ntot1 = nx1*ny1*nelt
                do 3000 ifldt=1,npscal+1
                   call copy (t(1,1,1,1,ifldt),tax(1,1,1,ifldt),ntot1)
  3000          continue
             endif
          endif

       endif
       return
       end
c-----------------------------------------------------------------------
       subroutine outfld(prefix)

c     output .fld file

       include 'SIZE'
       include 'TOTAL'
C
C     Work arrays and temporary arrays
C
       common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
c
c     note, this usage of CTMP1 will be less than elsewhere if NELT ~> 3.
       parameter (lxyz=lx1*ly1*lz1)
       parameter (lpsc9=ldimt+9)
       common /ctmp1/ tdump(lxyz,lpsc9)
       real*4         tdump
       real           tdmp(4)
       equivalence   (tdump,tdmp)

       real*4         test_pattern

       character*3    prefix
       character*1    fhdfle1(132)
       character*132   fhdfle
       equivalence   (fhdfle,fhdfle1)
       character*1    fldfile2(120)
       integer        fldfilei( 60)
       equivalence   (fldfilei,fldfile2)

       character*1 excode(30)
       character*10 frmat

       common /nopenf/ nopen(99)

       common /rdump/ ntdump
       data ndumps / 0 /

       if(nid.eq.0) then
         WRITE(6,1001) istep,time
  1001   FORMAT(/,i9,1pe12.4,' Write checkpoint:')
       endif
       call gsync()

       p66 = abs(param(66))
       if (p66.eq.6) then
          call mfo_outfld(prefix)
          call gsync                ! avoid race condition w/ outfld
          return
       endif

       iprefix = i_find_prefix(prefix,99)

       if (nid.eq.0) then
c       Open new file for each dump on /cfs
         NOPEN(iprefix)=NOPEN(iprefix)+1
         call file2(nopen(iprefix),prefix)
         if (p66.lt.1.0) then
            open(unit=24,file=fldfle,form='formatted',status='unknown')
         else
            call  izero    (fldfilei,33)
            len = ltrunc   (fldfle,131)
            call chcopy    (fldfile2,fldfle,len)
            call byte_open (fldfile2)
c             write header as character string
            call blank(fhdfle,132)
         endif
       endif

C     Figure out what goes in EXCODE
       CALL BLANK(EXCODE,30)
       NDUMPS=NDUMPS+1
       i=1
       if (mod(p66,1.0).eq.0.0) then !old header format
          IF(IFXYO) then
             EXCODE(1)='X'
             EXCODE(2)=' '
             EXCODE(3)='Y'
             EXCODE(4)=' '
             i = 5
             IF(IF3D) THEN
               EXCODE(i)  ='Z'
               EXCODE(i+1)=' '
               i = i + 2
             ENDIF
          ENDIF
          IF(IFVO) then
             EXCODE(i)  ='U'
             EXCODE(i+1)=' '
             i = i + 2
          ENDIF
          IF(IFPO) THEN
            EXCODE(i)='P'
            EXCODE(i+1)=' '
            i = i + 2
          ENDIF
          IF(IFTO) THEN
            EXCODE(i)='T '
            EXCODE(i+1)=' '
            i = i + 1
          ENDIF
          IF(NPSCAL.GT.0)then
             DO IIP=1,ldimt1
                IF(IFPSCO(IIP)) THEN
                  WRITE(EXCODE(IIP+i)  ,'(I1)') IIP
                  WRITE(EXCODE(IIP+i+1),'(A1)') ' '
                  i = i + 1
                ENDIF
             ENDDO
          ENDIF
       else
          !new header format
          IF (IFXYO) THEN
             EXCODE(i)='X'
             i = i + 1
          ENDIF
          IF (IFVO) THEN
             EXCODE(i)='U'
             i = i + 1
          ENDIF
          IF (IFPO) THEN
             EXCODE(i)='P'
             i = i + 1
          ENDIF
          IF (IFTO) THEN
             EXCODE(i)='T'
             i = i + 1
          ENDIF
          IF (NPSCAL.GT.0) THEN
             EXCODE(i) = 'S'
             WRITE(EXCODE(i+1),'(I1)') NPSCAL/10
             WRITE(EXCODE(i+2),'(I1)') NPSCAL-(NPSCAL/10)*10
          ENDIF
       endif

c
C     Dump header
       if (nid.eq.0) call dump_header(excode,p66)
c
       call get_id(id)

       nxyz  = nx1*ny1*nz1
c
       do ieg=1,nelgt
c
          jnid = gllnid(ieg)
          ie   = gllel (ieg)
c
          if (nid.eq.0) then
             if (jnid.eq.0) then
                call fill_tmp(tdump,id,ie)
             else
                mtype=2000+ieg
                len=4*id*nxyz
                dum1=0.
                call csend (mtype,dum1,wdsize,jnid,nullpid)
                call crecv (mtype,tdump,len)
             endif
             call out_tmp(id,p66)
          elseif (nid.eq.jnid) then
             call fill_tmp(tdump,id,ie)
             dum1=0.
c
             mtype=2000+ieg
             len=4*id*nxyz
             call crecv (mtype,dum1,wdsize)
             call csend (mtype,tdump,len,node0,nullpid)
          endif
       enddo

       if (nid.eq.0) call close_fld(p66)

       call gsync                ! avoid race condition w/ outfld
       return
       end
c-----------------------------------------------------------------------
       subroutine outhis(ifhis) ! output time history info

       include 'SIZE'
       include 'TOTAL'
       common /scrcg/ pm1    (lx1,ly1,lz1,lelv)

       real hdump(25)
       real xpart(10),ypart(10),zpart(10)
       character*30 excode
       character*10 frmat
       logical ifhis

       integer icalld
       save    icalld
       data    icalld /0/

       iohis=1
       if (param(52).ge.1) iohis=param(52)
       if (mod(istep,iohis).eq.0.and.ifhis) then
        if (nhis.gt.0) then
          IPART=0
          DO 2100 I=1,NHIS
           IF(HCODE(10,I).EQ.'P')then 
C            Do particle paths
              IF(IPART.LE.10)IPART=IPART+1
              IF(ISTEP.EQ.0)then
C               Particle has original coordinates
C               Restarts?
                 XPART(IPART)=
      $          XM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
                 YPART(IPART)=
      $          YM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
                 ZPART(IPART)=
      $          ZM1(LOCHIS(1,I),LOCHIS(2,I),LOCHIS(3,I),LOCHIS(4,I))
              ELSE
C               Kludge: Find Closest point
                 RMIN=1.0E7
                 DO 20 IEL=1,NELV
                 DO 20 K=1,NZ1
                 DO 20 J=1,NY1
                 DO 20 II=1,NX1
                    X = XM1(II,J,K,IEL)
                    Y = YM1(II,J,K,IEL)
                    Z = ZM1(II,J,K,IEL)
                    R=SQRT( (X-XPART(IPART))**2 + (Y-YPART(IPART))**2
      $             +       (Z-ZPART(IPART))**2 )
                    IF(R.LT.RMIN) then
                       RMIN=R
                       IP=II
                       JP=J
                       KP=K
                       IELP=IEL
                    ENDIF 
20              CONTINUE
                 XPART(IPART) = XPART(IPART) + DT * VX(IP,JP,KP,IELP)
                 YPART(IPART) = YPART(IPART) + DT * VY(IP,JP,KP,IELP)
                 ZPART(IPART) = ZPART(IPART) + DT * VZ(IP,JP,KP,IELP)
              ENDIF
C            Dump particle data for history point first
C            Particle data is Time, x,y,z.
              WRITE(26,'(4G14.6,A10)')TIME,XPART(IPART),YPART(IPART)
      $       ,ZPART(IPART),'  Particle'
           ENDIF
C         Figure out which fields to dump
           NVAR=0
           IF(HCODE(10,I).EQ.'H')then 
C           Do histories 
c
c
             IX =LOCHIS(1,I)
             IY =LOCHIS(2,I)
             IZ =LOCHIS(3,I)
             IEG=LOCHIS(4,I)
             JNID=GLLNID(IEG)
             IE  =GLLEL(IEG)
C
C------------------------------------------------------------------------
C           On first call, write out XYZ location of history points
C
             if (icalld.eq.0) then
               one = glmax(one,1)           ! Force synch.  pff 04/16/04
               IF (NID.EQ.JNID) then
                IF (NP.GT.1.AND..NOT.IF3D)
      $            WRITE(6,22) NID,I,IX,IY,ie,IEG
      $                       ,XM1(IX,IY,IZ,IE),YM1(IX,IY,IZ,IE)
                IF (NP.GT.1.AND.IF3D)
      $            WRITE(6,23) NID,I,IX,IY,IZ,ie,IEG,XM1(IX,IY,IZ,IE)
      $                       ,YM1(IX,IY,IZ,IE),ZM1(IX,IY,IZ,IE)
                IF (NP.EQ.1.AND..NOT.IF3D)
      $            WRITE(6,32) I,IX,IY,ie,IEG
      $                       ,XM1(IX,IY,IZ,IE),YM1(IX,IY,IZ,IE)
                IF (NP.EQ.1.AND.IF3D)
      $            WRITE(6,33) I,IX,IY,IZ,ie,IEG,XM1(IX,IY,IZ,IE)
      $                       ,YM1(IX,IY,IZ,IE),ZM1(IX,IY,IZ,IE)
    22          FORMAT(i6,' History point:',I3,' at (',2(I2,','),
      $         2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
    23          FORMAT(i6,' History point:',I3,' at (',3(I2,','),
      $         2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
    32          FORMAT(2X,' History point:',I3,' at (',2(I2,','),
      $         2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
    33          FORMAT(2X,' History point:',I3,' at (',3(I2,','),
      $         2(I4,','),'); X,Y,Z = (',G12.4,',',G12.4,',',G12.4,').')
               ENDIF
             ENDIF
C------------------------------------------------------------------------
C
             IF(HCODE(1,I).EQ.'U')then
                NVAR=NVAR+1
                HDUMP(NVAR)=VX(IX,IY,IZ,IE)
             elseif(HCODE(1,I).EQ.'X')then
                NVAR=NVAR+1
                HDUMP(NVAR)=XM1(IX,IY,IZ,IE)
             ENDIF
             IF(HCODE(2,I).EQ.'V')then
                NVAR=NVAR+1
                HDUMP(NVAR)=VY(IX,IY,IZ,IE)
             elseif(HCODE(2,I).EQ.'Y')then
                NVAR=NVAR+1
                HDUMP(NVAR)=YM1(IX,IY,IZ,IE)
             ENDIF
             IF(HCODE(3,I).EQ.'W')then
                NVAR=NVAR+1
                HDUMP(NVAR)=VZ(IX,IY,IZ,IE)
             elseif(HCODE(3,I).EQ.'Z')then
                NVAR=NVAR+1
                HDUMP(NVAR)=ZM1(IX,IY,IZ,IE)
             ENDIF
             IF(HCODE(4,I).EQ.'P')then
                NVAR=NVAR+1
                HDUMP(NVAR)=PM1(IX,IY,IZ,IE)
             ENDIF
             IF(HCODE(5,I).EQ.'T')then
                NVAR=NVAR+1
                HDUMP(NVAR)=T (IX,IY,IZ,IE,1)
             ENDIF
             IF(HCODE(6,I).NE.' '.AND. HCODE(6,I).NE.'0') then
                READ(HCODE(6,I),'(I1)',ERR=13)IHISPS
13             CONTINUE
C              Passive scalar data here
                NVAR=NVAR+1
                HDUMP(NVAR)=T (IX,IY,IZ,IE,IHISPS+1)
             ENDIF
C
C--------------------------------------------------------------
C           Dump out the NVAR values for this history point
C--------------------------------------------------------------
             MTYPE=2200+I
             LEN=WDSIZE*NVAR
C
C           If point on this processor, send data to node 0
             IF (NVAR.GT.0.AND.NID.NE.0.AND.JNID.EQ.NID)
      $         call csend (mtype,hdump,len,node0,nullpid)
C
C           If processor 0, recv data (unless point resides on node0).
             IF (NVAR.GT.0.AND.NID.EQ.0.AND.JNID.NE.NID)
      $         call crecv (mtype,hdump,len)
C
             IF (NVAR.GT.0.AND.NID.EQ.0)
      $         WRITE(26,'(1p6e16.8)')TIME,(HDUMP(II),II=1,NVAR)
C
C--------------------------------------------------------------
C         End of history points
C--------------------------------------------------------------
           ENDIF
2100     CONTINUE
C        Now do Integrated quantities (Drag, Lift, Flux, etc.)
C        Find out which groups are to be dumped
          IF (IFINTQ) CALL INTGLQ
          DO 2200 IH=1,NHIS
             IF(HCODE(10,IH).EQ.'I') then
                IOBJ=LOCHIS(1,IH)
                ISK=0
                DO 2205 IQ=1,3
                   IF (HCODE(IQ,IH).NE.' ') ISK=ISK + 1
2205           CONTINUE
                DO 2207 IQ=5,6
                   IF (HCODE(IQ,IH).NE.' ') ISK=ISK + 1
2207           CONTINUE
                IF (NID.EQ.0)
      $         WRITE(26,'(1p6e16.8)')TIME,(QINTEG(II,IOBJ),II=1,ISK)
             ENDIF
2200     CONTINUE
        ENDIF

       endif

       icalld = icalld+1

       return
       end
c-----------------------------------------------------------------------
       subroutine intglq
C
       include 'SIZE'
       include 'SOLN'
       include 'INPUT'
       include 'PARALLEL'
       include 'TSTEP'

       common /scrvx/ ts   (lx1,ly1,lz1,lelt)
      $             , smult(lx1,ly1,lz1,lelt)
       common /scrsx/ sfx  (lx1,ly1,lz1,lelt)
      $             , sfy  (lx1,ly1,lz1,lelt)
      $             , sfz  (lx1,ly1,lz1,lelt)
C
       NTOT1 = LX1*LY1*LZ1*LELV
       NINTQ = LDIMT3*MAXOBJ
       CALL RZERO  (QINTEG,NINTQ)
       CALL SETSMU (SMULT)
C
       IF (IFFLOW) then
          CALL COPY (SFX,BFX,NTOT1)
          CALL COPY (SFY,BFY,NTOT1)
          IF (NDIM.EQ.3) CALL COPY (SFZ,BFZ,NTOT1)
          CALL BDFORCE
       ENDIF
C
       IF (IFHEAT) CALL BDHEAT
C
       DO 100 II=1,NHIS
          IF (HCODE(10,II).NE.'I') GOTO 100
          IOBJ   = LOCHIS(1,II)
          MEMTOT = NMEMBER(IOBJ)
C
C        Fluid flow field
C
          IF (HCODE(1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
      $       HCODE(3,II).NE.' ' ) then
             IFIELD = 1
             NTOT1  = NX1*NY1*NZ1*NELV
             CALL COPY  (TS,SMULT,NTOT1)
             CALL DSSUM (TS,NX1,NY1,NZ1)
             DO 150 MEM=1,MEMTOT
                ISK   = 0
                IEG   = OBJECT(IOBJ,MEM,1)
                IFC   = OBJECT(IOBJ,MEM,2)
                IF (GLLNID(IEG).EQ.NID) then
C                 This processor has a contribution
                   IEL = GLLEL(IEG)
                   IF (HCODE(1,II).NE.' ') then
                      ISK = ISK + 1
                      QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
      $               SUMFC(BFX(1,1,1,IEL),TS(1,1,1,IEL),IFC)
                   ENDIF
                   IF (HCODE(2,II).NE.' ') then
                      ISK = ISK + 1
                      QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
      $               SUMFC(BFY(1,1,1,IEL),TS(1,1,1,IEL),IFC)
                   ENDIF
                   IF (HCODE(3,II).NE.' ') then
                      ISK = ISK + 1
                      QINTEG(ISK,IOBJ) = QINTEG(ISK,IOBJ) +
      $               SUMFC(BFZ(1,1,1,IEL),TS(1,1,1,IEL),IFC)
                   ENDIF
                ENDIF
   150       CONTINUE
          ENDIF
C
C        Temperature field
C
          IF (HCODE(5,II).NE.' ') then
             IFIELD = 2
             NTOT1 = NX1*NY1*NZ1*NELT
             CALL COPY  (TS,SMULT,NTOT1)
             CALL DSSUM (TS,NX1,NY1,NZ1)
             ISK=1
             DO 170 IQ=1,3
                IF (HCODE(IQ,II).NE.' ') ISK=ISK + 1
   170       CONTINUE
             DO 180 MEM=1,MEMTOT
                IEG   = OBJECT(IOBJ,MEM,1)
                IFC   = OBJECT(IOBJ,MEM,2)
                IF (GLLNID(IEG).EQ.NID) then
C                 This processor has a contribution
                   IEL = GLLEL(IEG)
c                 call outmat(t,nx1,nx1,'t  out',mem)
c                 call outmat(bq,nx1,nx1,'bq out',ifc)
c                 call outmat(ts,nx1,nx1,'bq out',mem)
                   QINTEG(ISK,IOBJ)=QINTEG(ISK,IOBJ) -
      $            SUMFC(BQ(1,1,1,IEL,IFIELD-1),TS(1,1,1,IEL),IFC)
                ENDIF
   180       CONTINUE
          ENDIF
c        call exitt
C
C        One passive scalar field
C
          IF (HCODE(6,II).NE.' ' .AND. HCODE(6,II).NE.'0') then
             READ (HCODE(6,II),'(I1)',ERR=210) INTQPS
   210       CONTINUE
             IFIELD = INTQPS + 2
             NEL   = NELFLD(IFIELD)
             NTOT1 = NX1*NY1*NZ1*NEL
             CALL COPY  (TS,SMULT,NTOT1)
             CALL DSSUM (TS,NX1,NY1,NZ1)
             ISK=1
             DO 270 IQ=1,3
                IF (HCODE(IQ,II).NE.' ') ISK=ISK + 1
   270       CONTINUE
             IF (HCODE(5,II).NE.' ') ISK=ISK + 1
             DO 280 MEM=1,MEMTOT
                IEG   = OBJECT(IOBJ,MEM,1)
                IFC   = OBJECT(IOBJ,MEM,2)
                IF (GLLNID(IEG).EQ.NID) then
C                 This processor has a contribution
                   IEL = GLLEL(IEG)
                   QINTEG(ISK,IOBJ)=QINTEG(ISK,IOBJ) -
      $            SUMFC(BQ(1,1,1,IEL,IFIELD-1),TS(1,1,1,IEL),IFC)
                ENDIF
   280       CONTINUE
          ENDIF
C
          ISK=0
          DO 310 IQ=1,6
             IF (HCODE(IQ,II).EQ.' ') GOTO 310
             ISK     = ISK + 1
             QINTEG(ISK,IOBJ) = GLSUM (QINTEG(ISK,IOBJ),1)
   310    CONTINUE
C
   100 CONTINUE
C
       IF (IFFLOW) then
          CALL COPY (BFX,SFX,NTOT1)
          CALL COPY (BFY,SFY,NTOT1)
          IF (NDIM.EQ.3) CALL COPY (BFZ,SFZ,NTOT1)
       ENDIF
C
       return
       end
c=======================================================================
       subroutine bdforce
C
C-----------------------------------------------------------------------
C
C     Compute total boundary force (components BFX,BFY,BFZ) on objects
C
C     Sign convention : these are the force exerted by
C                       the fluid on the object
C
C-----------------------------------------------------------------------
C
       include 'SIZE'
       include 'SOLN'
       include 'TSTEP'
       include 'INPUT'
       common /scrvh/ h1 (lx1,ly1,lz1,lelv)
      $             , h2 (lx1,ly1,lz1,lelv)
       common /scruz/ ta1(lx1,ly1,lz1,lelv)
      $             , ta2(lx1,ly1,lz1,lelv)
      $             , ta3(lx1,ly1,lz1,lelv)
C
       ITEMP = 0
       DO 100 II=1,NHIS
          IF (HCODE(10,II).NE.'I') GOTO 100
          IF (HCODE (1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
      $       HCODE (3,II).NE.' ')     ITEMP=ITEMP + 1
   100 CONTINUE
C
       IF (ITEMP.GT.0) then
C
       INTYPE = 0
       IF (IFTRAN) INTYPE = -1
       IFIELD = 1
       IMESH  = 1
       MATMOD = 0
       NTOT1  = NX1*NY1*NZ1*NELV
C
       IF (IFSTRS) then
          CALL OPCHSGN (BFX,BFY,BFZ)
          CALL BCNEUTR
          CALL TWALLSH
          CALL OPCHSGN (BFX,BFY,BFZ)
       ENDIF
       CALL SETHLM  (H1,H2,INTYPE)
       CALL OPGRADT (TA1,TA2,TA3,PR)
       CALL ADD2    (BFX,TA1,NTOT1)
       IF (.NOT.IFAXIS) CALL ADD2 (BFY,TA2,NTOT1)
       IF ( NDIM.EQ.3 ) CALL ADD2 (BFZ,TA3,NTOT1)
       CALL AXHMSF  (TA1,TA2,TA3,VX,VY,VZ,H1,H2,MATMOD)
       CALL SUB2    (BFX,TA1,NTOT1)
       IF (.NOT.IFAXIS) CALL SUB2 (BFY,TA2,NTOT1)
       IF ( NDIM.EQ.3 ) CALL SUB2 (BFZ,TA3,NTOT1)
       IF (IFAXIS) then
          TWOPI = 2.0*PI
          CALL CMULT (BFX,TWOPI,NTOT1)
          CALL RZERO (BFY,NTOT1)
       ENDIF
       CALL OPDSSUM (BFX,BFY,BFZ)
C
       ENDIF
C
       return
       end
c=======================================================================
       subroutine bdheat
C
C-----------------------------------------------------------------------
C
C     Compute total boundary flux-area product
C
C     Sign convention : flux enters the object from the continuum
C 
C
C-----------------------------------------------------------------------
C
       include 'SIZE'
       include 'SOLN'
       include 'TSTEP'
       include 'INPUT'
       common /scrvh/ h1(lx1,ly1,lz1,lelt)
      $             , h2(lx1,ly1,lz1,lelt)
       common /scruz/ ta(lx1,ly1,lz1,lelt)
C
       INTYPE = 0
       IF (IFTRAN) INTYPE = -1
C
C     Temperature field
C
       ITEMP = 0
       DO 100 II=1,NHIS
       IF ( HCODE(10,II).NE.'I') GOTO 100
       IF ( HCODE( 5,II).NE.' ') ITEMP=ITEMP + 1
   100 CONTINUE
       IF (ITEMP.GT.0) then
          IFIELD = 2
          NTOT1  = NX1*NY1*NZ1*NELT
          IMESH  = 2
          CALL BCNEUSC (TA,1)
          CALL SUB2    (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
          CALL SETHLM (H1,H2,INTYPE)
          CALL AXHELM (TA,T(1,1,1,1,IFIELD-1),H1,H2,IMESH,1)
          CALL SUB2   (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
          IF (IFAXIS) then
             TWOPI = 2.0*PI
             CALL CMULT (BQ(1,1,1,1,IFIELD-1),TWOPI,NTOT1)
          ENDIF
          CALL DSSUM  (BQ(1,1,1,1,IFIELD-1),NX1,NY1,NZ1)
       ENDIF
C
C     One passive scalar field
C
       ITEMP = 0
       DO 200 II=1,NHIS
       IF ( HCODE(10,II).NE.'I') GOTO 200
       IF ( HCODE(6,II).NE.' ' .AND. HCODE(6,II).NE.'0' ) then
          READ (HCODE(6,II),'(I1)',ERR=200) INTQPS
          ITEMP = ITEMP + 1
       ENDIF
   200 CONTINUE
       IF (ITEMP.GT.0) then
          IFIELD = INTQPS + 2
          NEL    = NELFLD(IFIELD)
          NTOT1  = NX1*NY1*NZ1*NEL
          IMESH  = 1
          IF (IFTMSH(IFIELD)) IMESH  = 2
          CALL BCNEUSC (TA,1)
          CALL SUB2    (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
          CALL SETHLM (H1,H2,INTYPE)
          CALL AXHELM (TA,T(1,1,1,1,IFIELD-1),H1,H2,IMESH,1)
          CALL SUB2   (BQ(1,1,1,1,IFIELD-1),TA,NTOT1)
          IF (IFAXIS) then
             TWOPI = 2.0*PI
             CALL CMULT (BQ(1,1,1,1,IFIELD-1),TWOPI,NTOT1)
          ENDIF
          CALL DSSUM  (BQ(1,1,1,1,IFIELD-1),NX1,NY1,NZ1)
       ENDIF
C
       return
       end
c=======================================================================
       subroutine setsmu (smult)
C
       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
C
       DIMENSION SMULT (LX1,LY1,LZ1,1)
C
       NTOT1=NX1*NY1*NZ1*NELT
       CALL RZERO (SMULT,NTOT1)
C
       DO 100 II=1,NHIS
          IF (HCODE(10,II).NE.'I') GOTO 100
             IOBJ   = LOCHIS(1,II)
             MEMTOT = NMEMBER(IOBJ)
             DO 150 MEM=1,MEMTOT
                IEG   = OBJECT(IOBJ,MEM,1)
                IFC   = OBJECT(IOBJ,MEM,2)
                IF (GLLNID(IEG).EQ.NID) then
C                 This processor has a contribution
                   IEL = GLLEL(IEG)
                   CALL FACIND (KX1,KX2,KY1,KY2,KZ1,KZ2,NX1,NY1,NZ1,IFC)
                   DO 200 IZ=KZ1,KZ2
                   DO 200 IY=KY1,KY2
                   DO 200 IX=KX1,KX2
   200                SMULT(IX,IY,IZ,IEL)=SMULT(IX,IY,IZ,IEL) + 1.0
                ENDIF
   150       CONTINUE
   100 CONTINUE
C
       return
       end
       FUNCTION SUMFC (FF,SM,IFC)
       include 'SIZE'
       REAL FF(LX1,LY1,LZ1),SM(LX1,LY1,LZ1)
       SUMFC=0.0
       CALL FACIND (KX1,KX2,KY1,KY2,KZ1,KZ2,NX1,NY1,NZ1,IFC)
       DO 70 IZ=KZ1,KZ2
       DO 70 IY=KY1,KY2
       DO 70 IX=KX1,KX2
          SUMFC=SUMFC + FF(IX,IY,IZ)/SM(IX,IY,IZ)
    70 CONTINUE
       return
       end
c=======================================================================
       subroutine file2(nopen,PREFIX)
C----------------------------------------------------------------------
C
C     Defines machine specific input and output file names.
C
C----------------------------------------------------------------------
       include 'SIZE'
       include 'INPUT'
       include 'TSTEP'
       include 'PARALLEL'
C
       CHARACTER*132 NAME
       CHARACTER*1   SESS1(132),PATH1(132),NAM1(132)
       EQUIVALENCE  (SESSION,SESS1)
       EQUIVALENCE  (PATH,PATH1)
       EQUIVALENCE  (NAME,NAM1)
       CHARACTER*1  DMP(4),FLD(4),REA(4),HIS(4),SCH(4) ,ORE(4), NRE(4)
       CHARACTER*4  DMP4  ,FLD4  ,REA4  ,HIS4  ,SCH4   ,ORE4  , NRE4
       EQUIVALENCE (DMP,DMP4), (FLD,FLD4), (REA,REA4), (HIS,HIS4)
      $          , (SCH,SCH4), (ORE,ORE4), (NRE,NRE4)
       CHARACTER*1  NUMRL(0:9)
       DATA DMP4,FLD4,REA4 /'.dmp','.fld','.rea'/
       DATA HIS4,SCH4      /'.his','.sch'/
       DATA ORE4,NRE4      /'.ore','.nre'/
       DATA NUMRL          /'0','1','2','3','4','5','6','7','8','9'/
       CHARACTER*78  STRING
c
       character*1    prefix(3)
C
       call blank(name  ,132)
       call blank(fldfle,132)
C
       LS=LTRUNC(SESSION,132)
       LPP=LTRUNC(PATH,132)
       LSP=LS+LPP
       l = 0

c     Construct file names containing full path to host:
c      DO 100 I=1,LPP
c         l = l+1
c         NAM1(l)=PATH1(I)
c  100 CONTINUE
C
       if (prefix(1).ne.' '.and.prefix(2).ne.' '.and.
      $     prefix(3).ne.' ') then
          do i=1,3
             l = l+1
             NAM1(l)=prefix(i)
          enddo
       endif
C
       DO 200 I=1,LS
          l = l+1
          NAM1(l)=SESS1(I)
   200 CONTINUE
C
C .fld file
       DO 300 I=1,4
          l = l+1
          NAM1(l)=FLD(I)
   300 CONTINUE
       if (nopen.lt.100) then
C        less than 100 dumps....
          ITEN=NOPEN/10
          l = l+1
          NAM1(l)=NUMRL(ITEN)
          IONE=MOD(NOPEN,10)
          l = l+1
          NAM1(l)=NUMRL(IONE)
       elseif (nopen.lt.1000) then
C        less than 1000 dumps....
          IHUN=NOPEN/100
          l = l+1
          NAM1(l)=NUMRL(IHUN)
          ITEN=MOD(NOPEN,100)/10
          l = l+1
          NAM1(l)=NUMRL(ITEN)
          IONE=MOD(NOPEN,10)
          l = l+1
          NAM1(l)=NUMRL(IONE)
       elseif (nopen.lt.10000) then
C        less than 10000 dumps....
          ITHO=NOPEN/1000
          l = l+1
          NAM1(l)=NUMRL(ITHO)
          IHUN=MOD(NOPEN,1000)/100
          l = l+1
          NAM1(l)=NUMRL(IHUN)
          ITEN=MOD(NOPEN,100)/10
          l = l+1
          NAM1(l)=NUMRL(ITEN)
          IONE=MOD(NOPEN,10)
          l = l+1
          NAM1(l)=NUMRL(IONE)
       endif
       FLDFLE=NAME
C
C     Write the name of the .fld file to the logfile.
C
       if (nid.eq.0) then
          call chcopy(string,fldfle,78)
          write(6,1000) istep,time,string
  1000    format(/,i9,1pe12.4,' OPEN: ',a78)
       endif

       return
       end
c=======================================================================
       subroutine rzero4(a,n)
       real*4 A(1)
       DO 100 I = 1, N
  100     A(I ) = 0.0
       return
       end
c=======================================================================
       subroutine copyX4(a,b,n)
       REAL*4 A(1)
       REAL   B(1)
       DO 100 I = 1, N
  100     A(I) = B(I)
       return
       end
c=======================================================================
       subroutine copy4r(a,b,n)
       real   a(1)
       real*4 b(1)
       do i = 1, n
          a(i) = b(i)
       enddo
       return
       end
c=======================================================================
       function i_find_prefix(prefix,imax)
c
       character*3 prefix
       character*3 prefixes(99)
       save        prefixes
       data        prefixes /99*'...'/
c
       integer nprefix
       save    nprefix
       data    nprefix /0/
c
c     Scan existing list of prefixes for a match to "prefix"
c
       do i=1,nprefix
          if (prefix.eq.prefixes(i)) then
             i_find_prefix = i
             return
          endif
       enddo
c
c     If we're here, we didn't find a match.. bump list and return
c
       nprefix                = nprefix + 1
       prefixes(nprefix)      = prefix
       i_find_prefix          = nprefix
c
c     Array bounds check on prefix list
c
       if (nprefix.gt.99.or.nprefix.gt.imax) then
          write(6,*) 'Hey! nprefix too big! ABORT in i_find_prefix'
      $      ,nprefix,imax
          call exitt
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine dump_header(excodein,p66)
c
       include 'SIZE'
       include 'TOTAL'

       character*30  excodein
c
       character*30 excode
       character*1  excode1(30)
       equivalence (excode,excode1) 
c
       real*4         test_pattern
c
       character*1 fhdfle1(132)
       character*132 fhdfle
       equivalence (fhdfle,fhdfle1)

       write(excode,'(A30)') excodein
c
       ikstep = istep
       do ik=1,10
          if (ikstep.gt.99999) ikstep = ikstep/10
       enddo

       call blank(fhdfle,132)

c       write(6,111)               !       print on screen
c     $     nelgt,nx1,ny1,nz1,time,istep,excode
c
       if (mod(p66,1.0).eq.0.0) then !       old header format
          if (p66.lt.1.0) then
             WRITE(24,'(4I4,1pe14.7,I5,1X,30A1,1X,A12)')
      $           NELGT,NX1,NY1,NZ1,TIME,ikstep,(EXCODE1(I),I=1,30),
      $           'NELT,NX,NY,N'
          else
             if (nelgt.lt.10000) then
                WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,30A1,1X,A12)')
      $              NELGT,NX1,NY1,NZ1,TIME,ikstep,(EXCODE1(I),I=1,30),
      $              ' 4 NELT,NX,NY,N'
             else
                write(fhdfle,'(i10,3i4,1P1e18.9,i9,1x,30a1)')
      $         nelgt,nx1,ny1,nz1,time,istep,(excode1(i),i=1,30)
             endif
             call byte_write(fhdfle,20)
          endif
       else                        !       new header format
          if (p66.eq.0.1) then
             write(24,111)
      $           nelgt,nx1,ny1,nz1,time,istep,excode
         else
              write(fhdfle,111)
      $            nelgt,nx1,ny1,nz1,time,istep,excode
              call byte_write(fhdfle,20)
         endif
  111    FORMAT(i10,1x,i2,1x,i2,1x,i2,1x,1P1e18.9,1x,i9,1x,a)
       endif

       CDRROR=0.0
       if (p66.LT.1.0) then       !       formatted i/o
          WRITE(24,'(6G11.4)')(CDRROR,I=1,NELGT)   ! dummy
       else
C       write byte-ordering test pattern to byte file...
         test_pattern = 6.54321
         call byte_write(test_pattern,1)
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine fill_tmp(tdump,id,ie)
C
       include 'SIZE'
       include 'TOTAL'
c
       common /scrcg/ pm1 (lx1,ly1,lz1,lelv)
C
C     Fill work array
C
       PARAMETER (LXYZ=LX1*LY1*LZ1)
       PARAMETER (LPSC9=LDIMT+9)
       real*4 tdump(lxyz,lpsc9)
C
       nxyz = nx1*ny1*nz1
c
       ID=0
       IF(IFXYO)then
          ID=ID+1
          CALL COPYx4(TDUMP(1,ID),XM1(1,1,1,IE),NXYZ)
          ID=ID+1
          CALL COPYx4(TDUMP(1,ID),YM1(1,1,1,IE),NXYZ)
          IF(IF3D) then
             ID=ID+1
             CALL COPYx4(TDUMP(1,ID),ZM1(1,1,1,IE),NXYZ)
          ENDIF
       ENDIF
c
       IF(IFVO)then
          IF (IE.LE.NELV) then
             ID=ID+1
             CALL COPYx4(TDUMP(1,ID),VX(1,1,1,IE),NXYZ)
             ID=ID+1
             CALL COPYx4(TDUMP(1,ID),VY(1,1,1,IE),NXYZ)
             IF(IF3D)then
                ID=ID+1
                CALL COPYx4(TDUMP(1,ID),VZ(1,1,1,IE),NXYZ)
             ENDIF
          ELSE
             ID=ID+1
             CALL RZERO4(TDUMP(1,ID),NXYZ)
             ID=ID+1
             CALL RZERO4(TDUMP(1,ID),NXYZ)
             IF(IF3D)then
                ID=ID+1
                CALL RZERO4(TDUMP(1,ID),NXYZ)
             ENDIF
          ENDIF
       ENDIF
       IF(IFPO)then
          IF (IE.LE.NELV) then
             ID=ID+1
             CALL COPYx4(TDUMP(1,ID),PM1(1,1,1,IE),NXYZ)
          ELSE
             ID=ID+1
             CALL RZERO4(TDUMP(1,ID),NXYZ)
          ENDIF
       ENDIF
       IF(IFTO)then
          ID=ID+1
          CALL COPYx4(TDUMP(1,ID),T(1,1,1,IE,1),NXYZ)
       ENDIF
C     PASSIVE SCALARS
       IF(NPSCAL.GT.0)then
          DO IIP=1,ldimt1
             IF(IFPSCO(IIP))then
                ID=ID+1
                CALL COPYx4(TDUMP(1,ID),T(1,1,1,IE,IIP+1),NXYZ)
            ENDIF
          ENDDO
       ENDIF 
c
       return
       end
c-----------------------------------------------------------------------
       subroutine get_id(id)
C
       include 'SIZE'
       include 'TOTAL'
C
C     Count up amount of data to be shipped
C
       ID=0
       IF(IFXYO)then
          ID=ID+1
          ID=ID+1
          IF(IF3D) then
             ID=ID+1
          ENDIF
       ENDIF
c
       IF(IFVO)then
          ID=ID+1
          ID=ID+1
          IF(IF3D)then
             ID=ID+1
          ENDIF
       ENDIF
       IF(IFPO) ID=ID+1
       IF(IFTO) ID=ID+1
C     PASSIVE SCALARS
       IF(NPSCAL.GT.0)then
          DO IIP=1,ldimt1
             IF(IFPSCO(IIP))then
                ID=ID+1
            ENDIF
          ENDDO
       ENDIF 
c
       return
       end
c-----------------------------------------------------------------------
       subroutine close_fld(p66)

       include 'SIZE'
       include 'TOTAL'

       if (nid.eq.0) then
          if (p66.lt.1) then
             close(unit=24)
          else
             call byte_close()
          endif
       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine out_tmp(id,p66)
c
       include 'SIZE'
       include 'TOTAL'
c
       PARAMETER (LXYZ=LX1*LY1*LZ1)
       PARAMETER (LPSC9=LDIMT+9)
c
       common /ctmp1/ tdump(lxyz,lpsc9)
       real*4         tdump
c
       CHARACTER*11 FRMAT
c
       nxyz = nx1*ny1*nz1
c
       call blank(frmat,11)
       if (id.le.9) then
          WRITE(FRMAT,1801) ID
  1801    FORMAT('(1p',I1,'e14.6)')
       else
          WRITE(FRMAT,1802) ID
  1802    FORMAT('(1p',I2,'e14.6)')
       endif

       if (p66.lt.1.0) then
C       formatted i/o
         WRITE(24,FRMAT)
      $      ((TDUMP(I,II),II=1,ID),I=1,NXYZ)
       else
c        C binary i/o
          do ii=1,id
             call byte_write(tdump(1,ii),nxyz)
          enddo
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine mfo_outfld(prefix)  ! muti-file output

       include 'SIZE'
       include 'TOTAL'
       include 'RESTART'
       common /scrcg/ pm1 (lx1,ly1,lz1,lelv)  ! mapped pressure

       integer*8 offs0,offs,nbyte,stride,strideB,nxyzo8
       character*3 prefix
       logical ifxyo_s

       common /SCRUZ/  ur1(lxo*lxo*lxo*lelt)
      &              , ur2(lxo*lxo*lxo*lelt)
      &              , ur3(lxo*lxo*lxo*lelt)

       tiostart=dnekclock()

       ifxyo_s = ifxyo
       ifxyo_  = ifxyo
       nout = nelt
       nxo  = nx1
       nyo  = ny1
       nzo  = nz1
       if (ifreguo) then ! dump on regular (uniform) mesh
          if (nrg.gt.lxo) then
             if (nid.eq.0) write(6,*)
      &         'WARNING: nrg too large, reset to lxo!'
             nrg = lxo
          endif
          nxo  = nrg
          nyo  = nrg
          nzo  = 1
          if(if3d) nzo = nrg
       endif
       offs0 = iHeaderSize + 4 + isize*nelgt

       if (nid.eq.pid0) then
          call mfo_open_files(prefix)         ! open files on i/o nodes
       endif
       call bcast(ifxyo_,lsize)
       ifxyo = ifxyo_
       call mfo_write_hdr                     ! create element mapping +
                                              ! write hdr
       nxyzo8  = nxo*nyo*nzo
       strideB = nelB * nxyzo8*wdsizo
       stride  = nelgt* nxyzo8*wdsizo

       ioflds = 0
       ! dump all fields based on the t-mesh to avoid different
       ! topologies in the post-processor
       if (ifxyo) then
c stefan: we need to change fldstideB to the number of elements
          offs = offs0 + ndim*strideB
          call byte_set_view(offs)
          if (ifreguo) then
             call map2reg(ur1,nrg,xm1,nout)
             call map2reg(ur2,nrg,ym1,nout)
             if (if3d) call map2reg(ur3,nrg,zm1,nout)
             call mfo_outv(ur1,ur2,ur3,nout,nxo,nyo,nzo)
          else
             call mfo_outv(xm1,ym1,zm1,nout,nxo,nyo,nzo)
          endif
          ioflds = ioflds + ndim
       endif
       if (ifvo ) then
          offs = offs0 + ioflds*stride + ndim*strideB
          call byte_set_view(offs)
          if (ifreguo) then
              call map2reg(ur1,nrg,vx,nout)
              call map2reg(ur2,nrg,vy,nout)
              if (if3d) call map2reg(ur3,nrg,vz,nout)
              call mfo_outv(ur1,ur2,ur3,nout,nxo,nyo,nzo)
          else
             call mfo_outv(vx,vy,vz,nout,nxo,nyo,nzo)  ! B-field handled thru outpost
          endif
          ioflds = ioflds + ndim
       endif
       if (ifpo ) then
          offs = offs0 + ioflds*stride + strideB
          call byte_set_view(offs)
          if (ifreguo) then
             call map2reg(ur1,nrg,pm1,nout)
             call mfo_outs(ur1,nout,nxo,nyo,nzo)
          else
             call mfo_outs(pm1,nout,nxo,nyo,nzo)
          endif
          ioflds = ioflds + 1
       endif
       if (ifto ) then
          offs = offs0 + ioflds*stride + strideB
          call byte_set_view(offs)
          if (ifreguo) then
             call map2reg(ur1,nrg,t,nout)
             call mfo_outs(ur1,nout,nxo,nyo,nzo)
          else
             call mfo_outs(t,nout,nxo,nyo,nzo)
          endif
          ioflds = ioflds + 1
       endif
       do k=1,ldimt-1
          if(ifpsco(k)) then
            offs = offs0 + ioflds*stride + strideB
            call byte_set_view(offs)
            if (ifreguo) then
               call map2reg(ur1,nrg,t(1,1,1,1,k+1),nout)
               call mfo_outs(ur1,nout,nxo,nyo,nzo)
            else
               call mfo_outs(t(1,1,1,1,k+1),nout,nxo,nyo,nzo)
            endif
            ioflds = ioflds + 1
          endif
       enddo
       nbyte = ioflds*nout*wdsizo*nxo*nyo*nzo

       if (if3d) then
          offs0   = offs0 + ioflds*stride
          strideB = nelB *2*4   ! min/max single precision
          stride  = nelgt*2*4
          ioflds  = 0
          ! add meta data to the end of the file
          if (ifxyo) then
             offs = offs0 + ndim*strideB
             call byte_set_view(offs)
             call mfo_mdatav(xm1,ym1,zm1,nout)
             ioflds = ioflds + ndim
          endif
          if (ifvo ) then
             offs = offs0 + ioflds*stride + ndim*strideB
             call byte_set_view(offs)
             call mfo_mdatav(vx,vy,vz,nout)
             ioflds = ioflds + ndim
          endif
          if (ifpo ) then
             offs = offs0 + ioflds*stride + strideB
             call byte_set_view(offs)
             call mfo_mdatas(pm1,nout)
             ioflds = ioflds + 1
          endif
          if (ifto ) then
             offs = offs0 + ioflds*stride + strideB
             call byte_set_view(offs)
             call mfo_mdatas(t,nout)
             ioflds = ioflds + 1
          endif
          do k=1,ldimt-1
             offs = offs0 + ioflds*stride + strideB
             call byte_set_view(offs)
             if(ifpsco(k)) call mfo_mdatas(t(1,1,1,1,k+1),nout)
             ioflds = ioflds + 1
          enddo
          nbyte = nbyte + 2*ioflds*nout*wdsizo
       endif

       if (nid.eq.pid0) 
#ifdef MPIIO
      &   call byte_close_mpi()
#else
      &   call byte_close()
#endif
       call gsync()
       tio = dnekclock()-tiostart

       dnbyte = nbyte
       nbyte = glsum(dnbyte,1)
       nbyte = nbyte + iHeaderSize + 4 + isize*nelgt
       if(nid.eq.0) write(6,7) istep,time,
      &             nbyte/tio/1024/1024/10,
      &             nfileo
     7 format(/,i9,1pe12.4,' done :: Write checkpoint',/,
      &       30X,'avg data-throughput = ',f7.1,'MBps',/,
      &       30X,'io-nodes = ',i5,/)

       ifxyo = ifxyo_s ! restore old value

       return
       end
c-----------------------------------------------------------------------
       subroutine io_init ! determine which nodes will output
       character*132 hname

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       ifdiro = .false.

#ifdef MPIIO

c#ifdef MPIIO_NOCOL
c      nfileo  = abs(param(65))
c      if(nfileo.eq.0) nfileo = 1
c      if(np.lt.nfileo) nfileo=np 
c      nproc_o = np / nfileo              !  # processors pointing to pid0
c      fid0    = nid/nproc_o              !  file id
c      pid0    = nproc_o*fid0             !  my parent i/o node
c      pid1    = min(np-1,pid0+nproc_o-1) !  range of sending procs
c      fid0    = 0 
c#else
       nfileo  = np
       nproc_o = 1
       fid0    = 0
       pid0    = nid
       pid1    = 0
c#endif

#else
       if(param(65).lt.0) ifdiro = .true. !  p65 < 0 --> multi subdirectories
       nfileo  = abs(param(65))
       if(nfileo.eq.0) nfileo = 1
       if(np.lt.nfileo) nfileo=np
       nproc_o = np / nfileo              !  # processors pointing to pid0
       fid0    = nid/nproc_o              !  file id
       pid0    = nproc_o*fid0             !  my parent i/o node
       pid1    = min(np-1,pid0+nproc_o-1) !  range of sending procs
#endif

       call nek_comm_io(nfileo)

       wdsizo = 4                             ! every proc needs this
       if (param(63).gt.0) wdsizo = 8         ! 64-bit .fld file
       if (wdsizo.gt.wdsize) then
          if(nid.eq.0) write(6,*) 'ABORT: wdsizo > wdsize!'
          call exitt
       endif

       ifreguo = .false.   ! by default we dump the data based on the GLL mesh
       nrg = lxo

       ! how many elements are present up to rank nid
       nn = nelt
       nelB = igl_running_sum(nn)
       nelB = nelB - nelt

       pid00 = glmin(pid0,1)

       return
       end
c-----------------------------------------------------------------------
       subroutine mfo_open_files(prefix) ! open files

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       character*1 prefix(3)

       character*132  fname
       character*1   fnam1(132)
       equivalence  (fnam1,fname)

       character*6  six,str
       save         six
       data         six / "??????" /


       character*1 slash,dot
       save        slash,dot
       data        slash,dot  / '/' , '.' /

       integer nopen(99,2)
       save    nopen
       data    nopen  / 198*0 /

       call blank(fname,132)      !  zero out for byte_open()

       iprefix        = i_find_prefix(prefix,99)
       if (ifreguo) then
          nopen(iprefix,2) = nopen(iprefix,2)+1
          nfld             = nopen(iprefix,2)
       else
          nopen(iprefix,1) = nopen(iprefix,1)+1
          nfld             = nopen(iprefix,1)
       endif
       call restart_nfld( nfld, prefix ) ! Check for Restart option.

       if (nfld.eq.1) ifxyo_ = .true.

#ifdef MPIIO
       rfileo = 1
#else
       rfileo = nfileo
#endif
       ndigit = log10(rfileo) + 1

       k = 1
       if (ifdiro) then                                  !  Add directory
          call chcopy(fnam1(1),'A',1)
          call chcopy(fnam1(2),six,ndigit)  ! put ???? in string
          k = 2 + ndigit
          call chcopy(fnam1(k),slash,1)
          k = k+1
       endif

       if (prefix(1).ne.' '.and.prefix(2).ne.' '.and.    !  Add prefix
      $    prefix(3).ne.' ') then
          call chcopy(fnam1(k),prefix,3)
          k = k+3
       endif

       len=ltrunc(session,132)                           !  Add SESSION
       call chcopy(fnam1(k),session,len)
       k = k+len

       if (ifreguo) then
          len=4
          call chcopy(fnam1(k),'_reg',len)
          k = k+len
       endif

       call chcopy(fnam1(k),six,ndigit)                  !  Add file-id holder
       k = k + ndigit

       call chcopy(fnam1(k  ),dot,1)                     !  Add .f appendix
       call chcopy(fnam1(k+1),'f',1)
       k = k + 2

       write(str,4) nfld                                 !  Add nfld number
     4 format(i5.5)
       call chcopy(fnam1(k),str,5)
       k = k + 5

       call mbyte_open(fname,fid0)                       !  Open blah000.fnnnn
c      write(6,*) nid,fid0,' FILE:',fname

       return
       end
c-----------------------------------------------------------------------

       subroutine restart_nfld( nfld, prefix )
       character*3 prefix
c
c     Check for Restart option and return proper nfld value.
c     Also, convenient spot to explain restart strategy.
c
c
c     The approach is as follows:
c
c         Prefix rs4 would indicate 4 files in the restart cycle.
c 
c         This would be normal usage for velocity only, with
c         checkpoints taking place in synch with standard io.
c
c         The resultant restart sequence might look like:
c
c         blah.fld09           Step 0
c         rs4blah.fld01             1
c         rs4blah.fld02             2
c
c         which implies that fld09 would be used as the i.c.
c         in the restart, rs4blah.fld01 would overwrite the
c         solution at Step 1, and rs4blah.fld02 would overwrite
c         Step 2.   Net result is that Steps 0-2 of the restart
c         session have solutions identical to those computed in
c         the prior run.   (It's important that both runs use
c         the same dt in this case.)
c
c
c         Another equally possible restart sequence would be:
c
c
c         blah.fld10           Step 0
c         rs4blah.fld03             1
c         rs4blah.fld04             2
c
c         Why the 3 & 4 ?   If one were to use only 1 & 2, there
c         is a risk that the system crashes while writing, say,
c         rs4blah.fld01, in which case the restart is compromised --
c         very frustrating at the end of a run that has been queued
c         for a week.  By providing a toggled sequence in pairs such as
c
c         (1,2),   (3,4),  (1,2), ...
c
c         ensures that one always has at least one complete restart
c         sequence.   In the example above, the following files would
c         be written, in order:
c
c         :
c         :
c         blah.fld09
c         rs4blah.fld01
c         rs4blah.fld02
c         blah.fld10
c         rs4blah.fld03
c         rs4blah.fld04
c         blah.fld11
c         rs4blah.fld01       (overwriting existing rs4blah.fld01)
c         rs4blah.fld02       (    "           "        "  .fld02)
c         blah.fld12
c         rs4blah.fld03       (   etc.  )
c         rs4blah.fld04
c         :
c         :
c
c
c         Other strategies are possible, according to taste.
c
c         Here is a data-intensive one:
c
c         MHD + double-precision restart, but single-precision std files
c
c         In this case, single-precision files are kept as the running
c         file sequence (i.e., for later post-processing) but dbl-prec.
c         is required for restart.  A total of 12 temporary restart files
c         must be saved:  (3 for velocity, 3 for B-field) x 2 for redundancy.
c
c         This is expressed, using hexadecimal notation (123456789abc...),
c         as prefix='rsc'.
c 
c
       character*16 kst
       save         kst
       data         kst / '0123456789abcdef' /
       character*1  ks1(0:15),kin
       equivalence (ks1,kst)

c
c
       if (indx1(prefix,'rs',2).eq.1) then
          read(prefix,3) kin
     3    format(2x,a1)
          do kfld=1,15
             if (ks1(kfld).eq.kin) goto 10
          enddo
    10    if (kfld.eq.16) kfld=4 ! std. default
          nfln = mod1(nfld,kfld) ! Restart A (1,2) and B (3,4)
          write(6,*) nfln,nfld,kfld,' kfld'
          nfld = nfln
       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine restart_save(iosave,save_size,nfldi)

       integer iosave,save_size,kfld


c     Save current fields for later restart.
c
c     Input arguments:
c
c       .iosave plays the usual triggering role, like iostep
c
c       .save_size = 8 ==> dbl. precision output
c
c       .kfld is the number of rs files to save before overwriting
c

       include 'SIZE'
       include 'TOTAL'

       character*3 prefix

       character*16 kst
       save         kst
       data         kst / '0123456789abcdef' /
       character*1  ks1(0:15)
       equivalence (ks1,kst)

       iosav = iosave

       if (iosav.eq.0) iosav = iostep
       if (iosav.eq.0) return

       iotest = 0
c     if (iosav.eq.iostep) iotest = 1  ! currently spoiled because of 
c                                      ! incompatible format of .fld
c                                      ! and multi-file i/o;  the latter
c                                      ! is the only form used for restart

       nfld  = nfldi*2
       nfld2 = nfld/2
       if (ifmhd) nfld2 = nfld/4
       if (istep.gt.iosav/2  .and.
      $   mod(istep+iosav-iotest,iosav).lt.nfld2) then ! save
          write(prefix,3) ks1(nfld)
     3    format('rs',a1)

          p63 = param(63) ! save existing p63, p66
          p66 = param(66)
          if (save_size.eq.8) param(63) = 8   ! output precision
          param(66) = 6                       ! force multi-file out

          if (ifmhd) call outpost2(bx,by,bz,pm,t,1,prefix)  ! first B
                     call outpost2(vx,vy,vz,pr,t,1,prefix)  ! then  U

          param(63) = p63  ! restore p63, p66
          param(66) = p66

       endif

       return
       end
c-----------------------------------------------------------------------

       subroutine mfo_mdatav(u,v,w,nel)

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       real u(lx1*ly1*lz1,1),v(lx1*ly1*lz1,1),w(lx1*ly1*lz1,1)

       real*4 buffer(1+6*lelt)

       integer e

       call gsync() ! clear outstanding message queues.

       nxyz = nx1*ny1*nz1
       n    = 2*ndim
       len  = 4 + 4*(n*lelt)   ! recv buffer size
       leo  = 4 + 4*(n*nelt)


       ! Am I an I/O node?
       if (nid.eq.pid0) then
          j = 1
          do e=1,nel
             buffer(j+0) = vlmin(u(1,e),nxyz)
             buffer(j+1) = vlmax(u(1,e),nxyz)
             buffer(j+2) = vlmin(v(1,e),nxyz)
             buffer(j+3) = vlmax(v(1,e),nxyz)
             j = j + 4
             if(if3d) then
               buffer(j+0) = vlmin(w(1,e),nxyz)
               buffer(j+1) = vlmax(w(1,e),nxyz)
               j = j + 2
             endif
          enddo

          ! write out my data
          nout = n*nel
#ifdef MPIIO
          call byte_write_mpi(buffer,nout,-1)
#else
          call byte_write(buffer,nout)
#endif

          ! write out the data of my childs
          idum  = 1
          do k=pid0+1,pid1
             mtype = k
             call csend(mtype,idum,4,k,0)           ! handshake
             call crecv(mtype,buffer,len)
             inelp = buffer(1)
             nout  = n*inelp
#ifdef MPIIO
             call byte_write_mpi(buffer(2),nout,-1)
#else
             call byte_write(buffer(2),nout)
#endif
          enddo
       else
          j = 1
          buffer(j) = nel
          j = j + 1
          do e=1,nel
             buffer(j+0) = vlmin(u(1,e),nxyz)
             buffer(j+1) = vlmax(u(1,e),nxyz)
             buffer(j+2) = vlmin(v(1,e),nxyz)
             buffer(j+3) = vlmax(v(1,e),nxyz)
             j = j + 4
             if(n.eq.6) then
               buffer(j+0) = vlmin(w(1,e),nxyz)
               buffer(j+1) = vlmax(w(1,e),nxyz)
               j = j + 2
             endif
          enddo

          ! send my data to my pararent I/O node
          mtype = nid
          call crecv(mtype,idum,4)                ! hand-shake
          call csend(mtype,buffer,leo,pid0,0)     ! u4 :=: u8
       endif

       return
       end
c-----------------------------------------------------------------------

       subroutine mfo_mdatas(u,nel)

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       real u(lx1*ly1*lz1,1)

       real*4 buffer(1+2*lelt)

       integer e

       call gsync() ! clear outstanding message queues.

       nxyz = nx1*ny1*nz1
       n    = 2
       len  = 4 + 4*(n*lelt)    ! recv buffer size
       leo  = 4 + 4*(n*nelt)


       ! Am I an I/O node?
       if (nid.eq.pid0) then
          j = 1
          do e=1,nel
             buffer(j+0) = vlmin(u(1,e),nxyz)
             buffer(j+1) = vlmax(u(1,e),nxyz)
             j = j + 2
          enddo

          ! write out my data
          nout = n*nel
#ifdef MPIIO
          call byte_write_mpi(buffer,nout,-1)
#else
          call byte_write(buffer,nout)
#endif
          ! write out the data of my childs
          idum  = 1
          do k=pid0+1,pid1
             mtype = k
             call csend(mtype,idum,4,k,0)           ! handshake
             call crecv(mtype,buffer,len)
             inelp = buffer(1)
             nout  = n*inelp
#ifdef MPIIO
             call byte_write_mpi(buffer(2),nout,-1)
#else
             call byte_write(buffer(2),nout)
#endif
          enddo
       else
          j = 1
          buffer(j) = nel
          j = j + 1
          do e=1,nel
             buffer(j+0) = vlmin(u(1,e),nxyz)
             buffer(j+1) = vlmax(u(1,e),nxyz)
             j = j + 2
          enddo

          ! send my data to my pararent I/O node
          mtype = nid
          call crecv(mtype,idum,4)                ! hand-shake
          call csend(mtype,buffer,leo,pid0,0)     ! u4 :=: u8
       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine mfo_outs(u,nel,mx,my,mz)   ! output a scalar field

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       real u(mx,my,mz,1)

       common /SCRNS/ u4(2+lxo*lxo*lxo*2*lelt)
       real*4         u4
       real*8         u8(1+lxo*lxo*lxo*1*lelt)
       equivalence    (u4,u8)

       integer e

       call gsync() ! clear outstanding message queues.
       if(mx.gt.lxo .or. my.gt.lxo .or. mz.gt.lxo) then
         if(nid.eq.0) write(6,*) 'ABORT: lxo too small'
         call exitt
       endif

       nxyz = mx*my*mz
       len  = 8 + 8*(lelt*nxyz)  ! recv buffer size
       leo  = 8 + wdsizo*(nel*nxyz)
       ntot = nxyz*nel

       idum = 1

       if (nid.eq.pid0) then

          if (wdsizo.eq.4) then             ! 32-bit output
              call copyx4 (u4,u,ntot)
          else
              call copy   (u8,u,ntot)
          endif
          nout = wdsizo/4 * ntot
#ifdef MPIIO
          call byte_write_mpi(u4,nout,-1)
#else
          call byte_write(u4,nout)          ! u4 :=: u8
#endif

          ! write out the data of my childs
          idum  = 1
          do k=pid0+1,pid1
             mtype = k
             call csend(mtype,idum,4,k,0)       ! handshake
             call crecv(mtype,u4,len)
             nout  = wdsizo/4 * nxyz * u8(1)
             if (wdsizo.eq.4) then
#ifdef MPIIO
                call byte_write_mpi(u4(3),nout,-1)
#else
                call byte_write(u4(3),nout)
#endif
             else
#ifdef MPIIO
                call byte_write_mpi(u8(2),nout,-1)
#else
                call byte_write(u8(2),nout)
#endif
             endif
          enddo

       else

          u8(1)= nel
          if (wdsizo.eq.4) then             ! 32-bit output
              call copyx4 (u4(3),u,ntot)
          else
              call copy   (u8(2),u,ntot)
          endif

          mtype = nid
          call crecv(mtype,idum,4)            ! hand-shake
          call csend(mtype,u4,leo,pid0,0)     ! u4 :=: u8

       endif


       return
       end
c-----------------------------------------------------------------------

       subroutine mfo_outv(u,v,w,nel,mx,my,mz)   ! output a vector field

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'

       real u(mx*my*mz,1),v(mx*my*mz,1),w(mx*my*mz,1)

       common /SCRNS/ u4(2+lxo*lxo*lxo*6*lelt)
       real*4         u4
       real*8         u8(1+lxo*lxo*lxo*3*lelt)
       equivalence    (u4,u8)

       integer e

       call gsync() ! clear outstanding message queues.
       if(mx.gt.lxo .or. my.gt.lxo .or. mz.gt.lxo) then
         if(nid.eq.0) write(6,*) 'ABORT: lxo too small'
         call exitt
       endif

       nxyz = mx*my*mz
       len  = 8 + 8*(lelt*nxyz*ndim)   ! recv buffer size (u4)
       leo  = 8 + wdsizo*(nel*nxyz*ndim)
       idum = 1

       if (nid.eq.pid0) then
          j = 0
          if (wdsizo.eq.4) then             ! 32-bit output
              do iel = 1,nel
                 call copyx4   (u4(j+1),u(1,iel),nxyz)
                 j = j + nxyz
                 call copyx4   (u4(j+1),v(1,iel),nxyz)
                 j = j + nxyz
                 if(if3d) then
                   call copyx4 (u4(j+1),w(1,iel),nxyz)
                   j = j + nxyz
                 endif
              enddo
          else
              do iel = 1,nel
                 call copy     (u8(j+1),u(1,iel),nxyz)
                 j = j + nxyz
                 call copy     (u8(j+1),v(1,iel),nxyz)
                 j = j + nxyz
                 if(if3d) then
                   call copy   (u8(j+1),w(1,iel),nxyz)
                   j = j + nxyz
                 endif
              enddo
          endif
          nout = wdsizo/4 * ndim*nel * nxyz
#ifdef MPIIO
          call byte_write_mpi(u4,nout,-1)
#else
          call byte_write(u4,nout)          ! u4 :=: u8
#endif
          ! write out the data of my childs
          do k=pid0+1,pid1
             mtype = k
             call csend(mtype,idum,4,k,0)           ! handshake
             call crecv(mtype,u4,len)
             nout  = wdsizo/4 * ndim*nxyz * u8(1)

             if (wdsizo.eq.4) then
#ifdef MPIIO
                call byte_write_mpi(u4(3),nout,-1)
#else
                call byte_write(u4(3),nout)
#endif
             else
#ifdef MPIIO
                call byte_write_mpi(u8(2),nout,-1)
#else
                call byte_write(u8(2),nout)
#endif
             endif
          enddo
       else

          u8(1) = nel
          if (wdsizo.eq.4) then             ! 32-bit output
              j = 2
              do iel = 1,nel
                 call copyx4   (u4(j+1),u(1,iel),nxyz)
                 j = j + nxyz
                 call copyx4   (u4(j+1),v(1,iel),nxyz)
                 j = j + nxyz
                 if(if3d) then
                   call copyx4 (u4(j+1),w(1,iel),nxyz)
                   j = j + nxyz
                 endif
              enddo
          else
              j = 1
              do iel = 1,nel
                 call copy     (u8(j+1),u(1,iel),nxyz)
                 j = j + nxyz
                 call copy     (u8(j+1),v(1,iel),nxyz)
                 j = j + nxyz
                 if(if3d) then
                   call copy   (u8(j+1),w(1,iel),nxyz)
                   j = j + nxyz
                 endif
              enddo
          endif

          mtype = nid
          call crecv(mtype,idum,4)            ! hand-shake
          call csend(mtype,u4,leo,pid0,0)     ! u4 :=: u8

       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine mfo_write_hdr          ! write hdr, byte key, els.

       include 'SIZE'
       include 'INPUT'
       include 'PARALLEL'
       include 'RESTART'
       include 'TSTEP'
       real*4 test_pattern
       common /ctmp0/ lglist(0:lelt)

       character*132 hdr
       integer*8 ioff

       call gsync()
       idum = 1

#ifdef MPIIO
       nfileoo = 1   ! all data into one file
       nelo = nelgt
#else
       nfileoo = nfileo
       if(nid.eq.pid0) then                ! how many elements to dump
         nelo = nelt
         do j = pid0+1,pid1
            mtype = j
            call csend(mtype,idum,4,j,0)   ! handshake
            call crecv(mtype,inelp,4)
            nelo = nelo + inelp
         enddo
       else
         mtype = nid
         call crecv(mtype,idum,4)          ! hand-shake
         call csend(mtype,nelt,4,pid0,0)   ! u4 :=: u8
       endif 
#endif

       if(nid.eq.pid0) then

       call blank(hdr,132)              ! write header
       call blank(rdcode1,10)
       i = 1
       IF (IFXYO) THEN
          rdcode1(i)='X'
          i = i + 1
       ENDIF
       IF (IFVO) THEN
          rdcode1(i)='U'
          i = i + 1
       ENDIF
       IF (IFPO) THEN
          rdcode1(i)='P'
          i = i + 1
       ENDIF
       IF (IFTO) THEN
          rdcode1(i)='T'
          i = i + 1
       ENDIF
       IF (LDIMT.GT.1) THEN
          NPSCALO = 0
          do k = 1,ldimt-1
            if(ifpsco(k)) NPSCALO = NPSCALO + 1
          enddo
          rdcode1(i) = 'S'
          IF (NPSCALO.GT.0) THEN
             WRITE(rdcode1(i+1),'(I1)') NPSCALO/10
             WRITE(rdcode1(i+2),'(I1)') NPSCALO-(NPSCALO/10)*10
          ENDIF
       ENDIF

       write(hdr,1) wdsizo,nxo,nyo,nzo,nelo,nelgt,time,istep,fid0,nfileoo
      $         ,   (rdcode1(i),i=1,10)        ! 74+20=94
     1 format('#std',1x,i1,1x,i2,1x,i2,1x,i2,1x,i10,1x,i10,1x,e20.13,
      &       1x,i9,1x,i6,1x,i6,1x,10a)

       ! if we want to switch the bytes for output
       ! switch it again because the hdr is in ASCII
       call get_bytesw_write(ibsw_out)
c      if (ibsw_out.ne.0) call set_bytesw_write(ibsw_out)
       if (ibsw_out.ne.0) call set_bytesw_write(0)

       test_pattern = 6.54321           ! write test pattern for byte swap

#ifdef MPIIO
       ! only rank0 (pid00) will write hdr + test_pattern
       call byte_write_mpi(hdr,iHeaderSize/4,pid00)
       call byte_write_mpi(test_pattern,1,pid00)
#else
       call byte_write(hdr,iHeaderSize/4)
       call byte_write(test_pattern,1)
#endif

       endif

       ! write global element numbering for this group
       if(nid.eq.pid0) then
#ifdef MPIIO
       ioff = iHeaderSize + 4 + nelB*isize
       call byte_set_view (ioff)
       call byte_write_mpi(lglel,nelt,-1)
#else
       call byte_write(lglel,nelt)
#endif
         do j = pid0+1,pid1
            mtype = j
            call csend(mtype,idum,4,j,0)   ! handshake
            len = 4*(lelt+1)
            call crecv(mtype,lglist,len)
#ifdef MPIIO
       call byte_write_mpi(lglist(1),lglist(0),-1)
#else
       call byte_write(lglist(1),lglist(0))
#endif
         enddo
       else
         mtype = nid
         call crecv(mtype,idum,4)          ! hand-shake

         lglist(0) = nelt
         call icopy(lglist(1),lglel,nelt)

         len = 4*(nelt+1)
         call csend(mtype,lglist,len,pid0,0)
       endif

       return
       end
uuuu
bdry.f:      SUBROUTINE SETLOG
bdry.f:C     Subroutine to initialize logical flags
bdry.f:      SUBROUTINE SETRZER
bdry.f:      SUBROUTINE CHKNORD (IFALGN,IFNORX,IFNORY,IFNORZ,IFC,IEL)
bdry.f:      SUBROUTINE CHKAXCB
bdry.f:      SUBROUTINE CHKCBC (CB,IEL,IFC,IFALGN)
bdry.f:      SUBROUTINE BCMASK
bdry.f:      SUBROUTINE BCDIRVC(V1,V2,V3,mask1,mask2,mask3)
bdry.f:      SUBROUTINE BCDIRSC(S)
bdry.f:      SUBROUTINE BCNEUSC(S,ITYPE)
bdry.f:      SUBROUTINE FACEIS (CB,S,IEL,IFACE,NX,NY,NZ)
bdry.f:      SUBROUTINE FACEIV (CB,V1,V2,V3,IEL,IFACE,NX,NY,NZ)
bdry.f:      SUBROUTINE NEKASGN (IX,IY,IZ,IEL)
bdry.f:      SUBROUTINE BCNEUTR
bdry.f:      SUBROUTINE TRCON (TRX,TRY,TRZ,TR1,TR2,TR3,IEL,IFC)
bdry.f:      SUBROUTINE TRST2D (TRX,TRY,SIGST,IEL,IFC)
bdry.f:      SUBROUTINE TRSTAX (TRX,TRY,SIGST,IEL,IFC)
bdry.f:      SUBROUTINE CTANG2D (CANG,SANG,IXN,IYN,IAN,IFC,IEL)
bdry.f:      SUBROUTINE TRST3D (TRX,TRY,TRZ,SIGST,IEL,IFC)
bdry.f:      SUBROUTINE SETDRS (DRM1,DRTM1,DSM1,DSTM1,IFC)
bdry.f:      SUBROUTINE GLOBROT (R1,R2,R3,IEL,IFC)
bdry.f:      SUBROUTINE FACEC2 (A1,A2,B1,B2,IFC)
bdry.f:      SUBROUTINE LFALSE (IFA,N)
bdry.f:      SUBROUTINE RZERO3 (A,B,C,N)
bdry.f:      SUBROUTINE UNITVEC (X,Y,Z,N)
bdry.f:      SUBROUTINE SETSHL
bdry.f:      SUBROUTINE CHKZVN (VMAX,IEL,IFC,IVNORL)
bdry.f:      SUBROUTINE BCTWALL (TMP1,TMP2,TMP3)
bdry.f:      SUBROUTINE ANTIMSK1(X,XMASK,N)
bdry.f:      subroutine check_cyclic  ! check for cyclic bcs
byte_mpi.f:      subroutine byte_open_mpi(fname)
byte_mpi.f:      subroutine byte_read_mpi(buf,icount,iorank)
byte_mpi.f:      subroutine byte_write_mpi(buf,icount,iorank)
byte_mpi.f:      subroutine byte_close_mpi
byte_mpi.f:      subroutine byte_set_view(ioff_in)
byte_mpi.f:      subroutine nek_comm_io(nn)
calcz.f:      subroutine calcz(d,e,n,dmax,dmin,z,ierr)
calcz.f:      subroutine ident(a,n)
coef.f:      subroutine genwz
coef.f:      subroutine geom1 (xm3,ym3,zm3)
coef.f:      subroutine glmapm3 (xm3,ym3,zm3)
coef.f:      subroutine glmapm1
coef.f:C     Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3 
coef.f:      subroutine geodat1
coef.f:C     Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3 
coef.f:      subroutine geom2
coef.f:      subroutine xyzrst (xrm1,yrm1,zrm1,xsm1,ysm1,zsm1,
coef.f:      subroutine chkjac(jac,n,iel,X,Y,Z,ND,IERR)
coef.f:      subroutine volume
coef.f:      subroutine setarea
coef.f:      subroutine area2
coef.f:C     Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3 
coef.f:      subroutine setwgtr (wgtr1,wgtr2,wgtr3,wgtr4)
coef.f:C     Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3 
coef.f:      subroutine area3
coef.f:C     Note: Subroutines GLMAPM1, GEODAT1, AREA2, SETWGTR and AREA3 
coef.f:      subroutine lagmass
coef.f:      subroutine setinvm
coef.f:      subroutine maprs(y,x,xa,nrest,iel)
coef.f:      subroutine map31 (y,x,iel)
coef.f:      subroutine map13 (y,x,iel)
coef.f:      subroutine map12 (y,x,iel)
coef.f:      subroutine map21t (y,x,iel)
coef.f:      subroutine map21e (y,x,iel)
coef.f:      subroutine out_xyz_el(x,y,z,e)
coef.f:      subroutine out_fld_el(x,e,c2)
coef.f:      subroutine outxm3j(xm3,ym3,jm3)
coef.f:      SUBROUTINE INVMT(A,B,AA,N)
coef.f:      SUBROUTINE LUBKSB(A,N,NP,INDX,B)
coef.f:      SUBROUTINE LUDCMP(A,N,NP,INDX,D)
comm_mpi.f:      subroutine iniproc
comm_mpi.f:      subroutine init_nek_comm
comm_mpi.f:      subroutine gop( x, w, op, n)
comm_mpi.f:      subroutine igop( x, w, op, n)
comm_mpi.f:      subroutine i8gop( x, w, op, n)
comm_mpi.f:      subroutine csend(mtype,buf,len,jnid,jpid)
comm_mpi.f:      subroutine crecv(mtype,buf,lenm)
comm_mpi.f:      subroutine crecv3(mtype,buf,len,lenm)
comm_mpi.f:      subroutine lbcast(ifif)
comm_mpi.f:      subroutine bcast(buf,len)
comm_mpi.f:      subroutine create_comm(icomm)
comm_mpi.f:      subroutine msgwait(imsg)
comm_mpi.f:      subroutine gsync()
comm_mpi.f:      subroutine exittr(stringi,rdata,idata)
comm_mpi.f:      subroutine exitti(stringi,idata)
comm_mpi.f:      subroutine err_chk(ierr,string)
comm_mpi.f:      subroutine exitt
comm_mpi.f:      subroutine printHeader
conduct.f:      subroutine cdscal (igeom)
conduct.f:      subroutine makeuq
conduct.f:      subroutine setqvol(bql)
conduct.f:      subroutine nekuq (bql,iel)
conduct.f:      subroutine convab
conduct.f:      subroutine makeabq
conduct.f:      subroutine makebdq
conduct.f:      subroutine convch_old
conduct.f:      subroutine thyprk (tch,ilag)
conduct.f:      subroutine thypab (tch,ilag)
conduct.f:      subroutine hypmsk1 (htmask)
conduct.f:      subroutine tchinit (tch,ilag)
conduct.f:      subroutine lagscal
conduct.f:      subroutine outfldrq (x,txt10,ichk)
conduct.f:      subroutine cdscal_expl (igeom)
conduct.f:      subroutine diffab  ! explicit treatment of diffusion operator
connect1.f:      subroutine setup_topo
connect1.f:      subroutine initds
connect1.f:      subroutine setedge
connect1.f:      subroutine dsset(nx,ny,nz)
connect1.f:      subroutine genxyzl
connect1.f:      subroutine verify
connect1.f:      subroutine setside
connect1.f:      subroutine verrhe
connect1.f:      subroutine facind (kx1,kx2,ky1,ky2,kz1,kz2,nx,ny,nz,iface)
connect1.f:      subroutine facindr (kx1,kx2,ky1,ky2,kz1,kz2,nx,ny,nz,iface)
connect1.f:      subroutine facev(a,ie,iface,val,nx,ny,nz)
connect1.f:      subroutine ifacev(a,ie,iface,val,nx,ny,nz)
connect1.f:      subroutine facec(a,b,ie,iface,nx,ny,nz,nel)
connect1.f:      subroutine combin2(glnm1,glnm2,nglob)
connect1.f:      subroutine outfldio (x,txt10)
connect1.f:      subroutine outfldi (x,txt10)
connect1.f:      subroutine outfldr (x,txt10)
connect1.f:      subroutine checkit(idum)
connect1.f:      subroutine outfldro (x,txt10,ichk)
connect1.f:      subroutine outfldrp (x,txt10,ichk)
connect1.f:      subroutine outmatp(a,m,n,name6,ie)
connect1.f:      subroutine gs_chkr(glo_num)
connect1.f:      subroutine gs_counter(glo_num,gsh_std)
connect1.f:      subroutine gs_new_tstr(glo_num,x,c,gsh_std)
connect1.f:      subroutine xfill(x,c,n)
connect1.f:      subroutine setup_mesh_dssum ! Set up dssum for mesh
connect2.f:      subroutine readat
connect2.f:      subroutine rdparam
connect2.f:      subroutine rdmesh
connect2.f:      subroutine rdcurve
connect2.f:      subroutine rdbdry
connect2.f:      subroutine rdicdf
connect2.f:      subroutine rdmatp
connect2.f:      subroutine rdhist
connect2.f:      subroutine rdout
connect2.f:      subroutine rdobj
connect2.f:      subroutine vrdsmsh
connect2.f:      subroutine vrdsmshx  ! verify mesh topology
connect2.f:      subroutine rotat2(xyz,angle,npts)
connect2.f:      subroutine scale(xyzl,nl)
connect2.f:      subroutine inrtia(xyzi,cg,xyzl,n,itype)
connect2.f:      subroutine volume2(vol,xyz,n)
connect2.f:      subroutine findcg(cg,xyz,n)
connect2.f:      subroutine divide(list1,list2,nl1,nl2,ifok,list,nl,xyzi,cg,WGT)
connect2.f:      subroutine bin_rd1(ifbswap)  ! read mesh, curve, and bc info
connect2.f:      subroutine buf_to_xyz(buf,e,ifbswap)    ! version 1 of binary reader
connect2.f:      subroutine buf_to_curve(buf)    ! version 1 of binary reader
connect2.f:      subroutine buf_to_bc(cbl,bl,buf)    ! version 1 of binary reader
connect2.f:      subroutine bin_rd1_mesh(ifbswap)    ! version 1 of binary reader
connect2.f:      subroutine bin_rd1_curve (ifbswap) ! v. 1 of curve side reader
connect2.f:      subroutine bin_rd1_bc (cbl,bl,ifbswap) ! v. 1 of bc reader
connect2.f:      subroutine buf_close_outv  ! this is the stupid O(P) formulation
connect2.f:      subroutine buf_close_out  ! this is the stupid O(P) formulation
connect2.f:      subroutine open_bin_file(ifbswap) ! open file & chk for byteswap
connect2.f:      subroutine chk_xyz
connect2.f:      subroutine chk_nel
connect2.f:      subroutine cscan(sout,key,nk)
convect.f:      subroutine setup_convect(igeom)
convect.f:      subroutine char_conv(p0,u,ulag,msk,c,cs,gsl)
convect.f:      subroutine char_conv1
convect.f:      subroutine int_vel(c_t,t0,c,n,nc,ct,nid)
convect.f:      subroutine conv_rhs (du,u,c,bmsk,gsl)
convect.f:      subroutine convop_fst_3d(du,u,c,mx,md,nel)
convect.f:      subroutine convop_fst_2d(du,u,c,mx,md,nel)
convect.f:      subroutine grad_rstd(ur,us,ut,u,mx,md,if3d,ju)
convect.f:      subroutine intp_rstd(ju,u,mx,md,if3d,idir)
convect.f:      subroutine gen_int(jgl,jgt,mp,np,w)
convect.f:      subroutine gen_dgl(dgl,dgt,mp,np,w)
convect.f:      subroutine lim_chk(n,m,avar5,lvar5,sub_name10)
convect.f:      subroutine get_int_ptr (ip,mx,md)
convect.f:      subroutine get_dgl_ptr (ip,mx,md)
convect.f:      subroutine set_conv_char(ct,c,ux,uy,uz,nelc,tau,ifnew)
convect.f:      subroutine set_ct_cvx(ct,c,m,u,v,w,tau,nc,mc,nelc,ifnew)
convect.f:      subroutine grad_rst(ur,us,ut,u,md,if3d)
convect.f:      subroutine convect_new(bdu,u,ifuf,cx,cy,cz,ifcf)
convect.f:      subroutine convect_cons(bdu,u,ifuf,cx,cy,cz,ifcf)
convect.f:      subroutine set_convect_cons(cx,cy,cz,ux,uy,uz)
convect.f:      subroutine set_convect_new(cr,cs,ct,ux,uy,uz)
convect.f:      subroutine set_char_mask(mask,u,v,w) ! mask for hyperbolic system 
convect.f:      subroutine advchar
convect.f:      subroutine convch
convect.f:      subroutine convop_cons_3d(du,u,c,mx,md,nel) ! Conservation form
convect.f:      subroutine convop_cons_2d(du,u,c,mx,md,nel) ! Conservation form
cvode_aux.f:      subroutine add_fcvfun_usr(ydot)
cvode_aux.f:      subroutine cv_unpack_sol(y)
cvode_aux.f:      subroutine cv_pack_sol(y)
cvode_driver.f:      subroutine cv_setsize(n_in,nfld_last)
cvode_driver.f:      subroutine cv_init
cvode_driver.f:      subroutine cdscal_cvode(igeom)
cvode_driver.f:      subroutine cv_setsize(n_in,nfld_last)
cvode_driver.f:      subroutine cv_init
cvode_driver.f:      subroutine cdscal_cvode(igeom)
cvode_driver.f:      SUBROUTINE FCVJTIMES (V,FJV,TT,Y,FY,H,IPAR,RPAR,WORK,IER)
cvode_driver.f:      subroutine store_vel(vx_,vy_,vz_)
cvode_driver.f:      subroutine set_vel(vx_,vy_,vz_)
cvode_driver.f:      subroutine update_vel(time_)
cvode_driver.f:      subroutine fcvfun (cv_time, y, ydot, ipar, rpar, ier)
drive1.f:      subroutine nek_init
drive1.f:      subroutine nek_solve
drive1.f:      subroutine nek_advance
drive1.f:      subroutine nek_end
drive2.f:      subroutine initdim
drive2.f:      subroutine initdat
drive2.f:      subroutine comment
drive2.f:      subroutine setvar
drive2.f:      subroutine echopar
drive2.f:      subroutine gengeom (igeom)
drive2.f:      subroutine files
drive2.f:      subroutine settime
drive2.f:      subroutine geneig (igeom)
drive2.f:      subroutine fluid (igeom)
drive2.f:      subroutine heat (igeom)
drive2.f:      subroutine meshv (igeom)
drive2.f:      subroutine rescont (ind)
drive2.f:      subroutine rstartc (ind)
drive2.f:      subroutine time00
drive2.f:      subroutine runstat
drive2.f:      subroutine pprint_all(s,n_in,io)
drive2.f:      subroutine opcount(ICALL)
drive2.f:      subroutine dofcnt
drive2.f:      subroutine vol_flow
drive2.f:      subroutine compute_vol_soln(vxc,vyc,vzc,prc)
drive2.f:      subroutine plan2_vol(vxc,vyc,vzc,prc)
drive2.f:      subroutine plan3_vol(vxc,vyc,vzc,prc)
drive2.f:      subroutine a_dmp
drive2.f:      subroutine outrio (v,n,io)
drive2.f:      subroutine reset_prop
dssum.f:      subroutine setupds(gs_handle,nx,ny,nz,nel,melg,vertex,glo_num)
dssum.f:      subroutine dssum(u,nx,ny,nz)
dssum.f:      subroutine dsop(u,op,nx,ny,nz)
dssum.f:      subroutine vec_dssum(u,v,w,nx,ny,nz)
dssum.f:      subroutine vec_dsop(u,v,w,nx,ny,nz,op)
dssum.f:      subroutine nvec_dssum(u,stride,n,gs_handle)
dssum.f:      subroutine matvec3(uout,Jmat,uin,iftrsp,n1,n2)
dssum.f:      subroutine matvec3t(uout,Jmat,uin,iftrsp,n1,n2)
dssum.f:      subroutine matvect (out,d,vec,n1,n2)
dssum.f:c      subroutine opq_in_place(a,b,c)
dssum.f:      subroutine vectof_add(b,a,ie,iface,nx,ny,nz)
dssum.f:      subroutine zero_f(b,ie,iface,nx,ny,nz)
dssum.f:      subroutine ftovec_0(a,b,ie,iface,nx,ny,nz)
dssum.f:      subroutine ftovec(a,b,ie,iface,nx,ny,nz)
dssum.f:      subroutine vectof(b,a,ie,iface,nx,ny,nz)
dssum.f:      subroutine ftoveci(a,b,ie,iface,nx,ny,nz)
dssum.f:      subroutine vectofi(b,a,ie,iface,nx,ny,nz)
dssum.f:      subroutine apply_Jt(u,nx,ny,nz,nel)
dssum.f:      subroutine apply_J(u,nx,ny,nz,nel)
dssum.f:      subroutine h1_proj(u,nx,ny,nz)
dssum.f:      subroutine dssum_msk(u,mask,nx,ny,nz)
dssum.f:      subroutine dssum_msk2(u,mask,binv,nx,ny,nz)
eigsolv.f:      SUBROUTINE ESTEIG
eigsolv.f:      SUBROUTINE EIGENV
eigsolv.f:      SUBROUTINE ALPHAM1 (ALPHA,MASK,MULT,H1,H2,ISD)
eigsolv.f:      SUBROUTINE GAMMAM1 (GAMMA,MASK,MULT,H1,H2,ISD)
eigsolv.f:      SUBROUTINE ALPHAM2 (ALPHA,H1,H2,H2INV,INLOC)
eigsolv.f:      SUBROUTINE GAMMAM2 (GAMMA,H1,H2,H2INV,INLOC)
eigsolv.f:      SUBROUTINE STARTX1 (X1,Y1,MASK,MULT,NEL)
eigsolv.f:      SUBROUTINE STARTX2 (X2,Y2)
fast3d.f:      subroutine gen_fast(x,y,z)
fast3d.f:      subroutine plane_space_std(lr,ls,lt,i1,i2,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f:      subroutine plane_space(lr,ls,lt,i1,i2,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f:      subroutine plane_space2(lr,ls,lt,i1,w,x,y,z,nx,nxn,nz0,nzn)
fast3d.f:      subroutine set_up_fast_1D_fem(s,lam,n,lbc,rbc,ll,lm,lr,z,nz,ie)
fast3d.f:      subroutine set_up_1D_geom(dx,lbc,rbc,ll,lm,lr,z,nz)
fast3d.f:      subroutine gen_eigs_A_fem(sf,sft,atd,n,l,lbc,rbc)
fast3d.f:      subroutine get_fast_bc(lbr,rbr,lbs,rbs,lbt,rbt,ie,ierr)
fast3d.f:      subroutine get_fast_bc2(lbr,rbr,lbs,rbs,lbt,rbt,ie,ierr)
fast3d.f:      subroutine outv(x,n,name3)
fast3d.f:      subroutine outmat(a,m,n,name6,ie)
fast3d.f:      subroutine set_up_fast_1D_fem_ax
fast3d.f:      subroutine set_up_1D_geom_ax(dx,lbc,rbc,ll,lm,lr,z,y,nz)
fast3d.f:      subroutine gen_eigs_A_fem_ax(sf,sft,atd,n,l,y,lbc,rbc)
fast3d.f:      subroutine load_semhat_weighted    !   Fills the SEMHAT arrays
fast3d.f:      subroutine do_semhat_weight(jgl,dgl,bgl,n)
fast3d.f:      subroutine semhat(a,b,c,d,z,dgll,jgll,bgl,zgl,dgl,jgl,n,w)
fast3d.f:      subroutine fd_weights_full(xx,x,n,m,c)
fast3d.f:      subroutine set_up_fast_1D_sem(s,lam,n,lbc,rbc,ll,lm,lr,ie)
fast3d.f:      subroutine set_up_fast_1D_sem_op(g,b0,b1,l,r,ll,lm,lr,bh,jgl,jscl)
fast3d.f:      subroutine swap_lengths
fast3d.f:      subroutine row_zero(a,m,n,i)
fasts.f:      subroutine local_solves_fdm(u,v)
fasts.f:      subroutine fastdm1(R,ie,w1,w2)
fasts.f:      subroutine tensr3(v,nv,u,nu,A,Bt,Ct,w)
fasts.f:      subroutine s_face_to_int(x,c)
fasts.f:      subroutine dface_ext(x)
fasts.f:      subroutine dface_add1si(x,c)
fasts.f:      subroutine init_weight_op
fasts.f:      subroutine do_weight_op(x)
gauss.f:      SUBROUTINE LU(A,N,NDIM,IR,IC)
gauss.f:C  IT IS THE FIRST SUBROUTINE TO COMPUTE THE MX. INV.
gauss.f:      SUBROUTINE SOLVE(F,A,K,N,NDIM,IR,IC)
genbox.f:      subroutine genbox
genbox.f:      subroutine gen_gtp_vertex (vertex,ncrnr)
genbox.f:      subroutine getbox(x,y,z,nfld)
genbox.f:      subroutine mapbox(melx,mely,melz)
genbox.f:      subroutine makebox(x,y,z,nfld)
genbox.f:      subroutine geti1(i,iend,io)
genbox.f:      subroutine geti2(i1,i2,iend,io)
genbox.f:      subroutine geti3(i1,i2,i3,iend,io)
genbox.f:      subroutine getr2(r1,r2,iend,io)
genbox.f:      subroutine getr3(r1,r2,r3,iend,io)
genbox.f:      subroutine getrv(r,n,iend,io)
genbox.f:      subroutine getiv(r,n,iend,io)
genbox.f:      subroutine getcv0(c,m,n,iend,io)
genbox.f:      subroutine getcv(c,m,n,iend,io)
genbox.f:      subroutine gets(c,n,iend,io)
genbox.f:      subroutine get_multi_seg(nelxyz,x,y,z,m,if3d)
genbox.f:      subroutine geometric_x(x,n,x0,x1,gain)
genbox.f:      subroutine get_xyz_distribution (x,nelx)
genbox.f:      subroutine scannocom(iend,infile)
genbox.f:      subroutine jjnt(x,n)
genbox.f:      subroutine bcpbox(nfld)
genbox.f:      subroutine outbox_mesh
genxyz.f:      subroutine arcsrf(xml,yml,zml,nxl,nyl,nzl,ie,isid)
genxyz.f:      subroutine defsrf(xml,yml,zml,nxl,nyl,nzl,ie,iface1,ccv)
genxyz.f:      subroutine intrsc(x3,x2,x1,delt,ie,iface)
genxyz.f:      subroutine zbrac(x1,x2,succes)
genxyz.f:      subroutine setdef
genxyz.f:      subroutine gencoor (xm3,ym3,zm3)
genxyz.f:      subroutine genxyz (xml,yml,zml,nxl,nyl,nzl)
genxyz.f:      subroutine setzgml (zgml,iel,nxl,nyl,nzl,ifaxis)
genxyz.f:      subroutine sphsrf(xml,yml,zml,ifce,ie,nx,ny,nz,xysrf) 
genxyz.f:      subroutine edg3d(xysrf,x1,x2,i1,i2,j1,j2,nx,ny)
genxyz.f:      subroutine cross(v1,v2,v3)
genxyz.f:      subroutine norm3d(v1)
genxyz.f:      subroutine crn3d(xcv,xc,yc,zc,curve,iface)
genxyz.f:      subroutine rotxyz 
genxyz.f:      subroutine gensrf(XML,YML,ZML,IFCE,IE,MX,MY,MZ,zgml)
genxyz.f:      subroutine prjects(x0,dxc,c,cc)
genxyz.f:      subroutine srfind(x1,x0,c,cc)
genxyz.f:      subroutine linquad(xl,yl,zl,nxl,nyl,nzl)
genxyz.f:      subroutine xyzlin(xl,yl,zl,nxl,nyl,nzl,e)
genxyz.f:      subroutine xyzquad(xl,yl,zl,nxl,nyl,nzl,e)
gfdm_op.f:      subroutine gfdm_ops
gfdm_op.f:      subroutine gfdm_set_prs_op(mfld)
gfdm_op.f:      subroutine set_1d_e_mat(eigv,eigs,n,length,nel,nxv,nxp
gfdm_op.f:      subroutine build_D1d_d(DI,II,dgg1,igg1,wm1,b1d,length,nel,nxv,nxp
gfdm_op.f:      subroutine gfdm_set_diagp(eigi,tpn,nn,eigx,l,eigy,m,eigz,n)
gfdm_op.f:      subroutine gfdm_set_geom(work,melx,mely,melz)
gfdm_op.f:      subroutine gfdm_set_genwz(nx,nxp)
gfdm_op.f:      subroutine gfdm_set_bc(cb0,cbn,mfld)
gfdm_op.f:      subroutine add2s2mat2p(a,ma,na,i1,j1,b,ldb,s,m,n)
gfdm_op.f:      subroutine overflow_chk(n_req,n_avail,var,sub)
gfdm_op.f:      subroutine solveMp(z,r,n,w,nza)
gfdm_op.f:      subroutine map12q(r2,r1,rt)
gfdm_op.f:      subroutine cgpa(x,b,r,p,z,w,niter,tolin)
gfdm_op.f:      subroutine row_mult (A,B,n1,n2)
gfdm_op.f:      subroutine a1d (A1,A1t,d2,b2,d1,d1t,wgl,nx)
gfdm_op.f:      subroutine set_diagA (da,dat,b,d,w,nx)
gfdm_op.f:      subroutine gfdm_chk_size
gfdm_par.f:      subroutine g25d_init
gfdm_par.f:      subroutine gfdm_init
gfdm_par.f:      subroutine gfdm_check_array_sizes
gfdm_par.f:      subroutine gfdm_mappings
gfdm_par.f:      subroutine assign_tp_numbering_pres(tpn,nex,ney,nez,nx,ny,nz
gfdm_par.f:      subroutine reassign_tp_numbering
gfdm_par.f:      subroutine cex_setup(part_in,nr,part_out,m,n,nid,np)
gfdm_par.f:      subroutine cexr(w,u,m,n,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f:      subroutine cextr(u,m,n,w,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f:      subroutine cexi(w,u,m,n,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_par.f:      subroutine cexti(u,m,n,w,part_out,part_in,msg_id,wdsize,nid,np)
gfdm_solve.f:      subroutine gfdm_pres_solv(z,r,ug,wg)
gmres.f:      subroutine uzawa_gmres(res,h1,h2,h2inv,intype,iter)
gmres.f:      subroutine uzawa_gmres_split0(l,u,b,binv,n)
gmres.f:      subroutine uzawa_gmres_split(l,u,b,binv,n)
gmres.f:      subroutine uzawa_gmres_temp(a,b,n)
gmres.f:      subroutine ax(w,x,h1,h2,n)
gmres.f:      subroutine hmh_gmres(res,h1,h2,wt,iter)
gmres.f:      subroutine set_overlap2
gmres.f:      subroutine h1_overlap_2(u,v,mask)
gmres.f:      subroutine dd_swap_vals(v1,v0,gsh_dd)
gmres.f:      subroutine gen_fast_g
gmres.f:      subroutine set_up_fast_1D_sem_g(s,lam,n,lbc,rbc,ll,lm,lr,ie)
gmres.f:      subroutine set_up_fast_1D_sem_op_a(g,b0,b1,l
gmres.f:      subroutine set_up_fast_1D_sem_op_b(g,b0,b1,l
gmres.f:      subroutine fill_interior_g(v1,v,e,nx,nz,iz1,nel)
gmres.f:      subroutine dface_ext_g(x,t,e,nx,nz)
gmres.f:      subroutine dface_add1si_g(x,c,t,e,nx,nz)
gmres.f:      subroutine fastdm1_g(R,ie,w1,w2)
gmres.f:      subroutine s_face_to_int2_g(x,c,t,e,nx,nz)
gmres.f:      subroutine outfldr_g(x,txt10,nx,nz,ichk)
gmres.f:      subroutine outfldi_g(x,txt10,nx,nz,ichk)
gmres.f:      subroutine setupds_no_crn(gs_h,nx,ny,nz,nel,melg,vertex,glo_num)
gmres.f:      subroutine rzero_g(a,e,nx,ny,nz)
hmholtz.f:      subroutine hmholtz(name,u,rhs,h1,h2,mask,mult,imsh,tli,maxit,isd)
hmholtz.f:      subroutine axhelm (au,u,helm1,helm2,imesh,isd)
hmholtz.f:      subroutine setfast (helm1,helm2,imesh)
hmholtz.f:      subroutine sfastax
hmholtz.f:      subroutine setprec (dpcm1,helm1,helm2,imesh,isd)
hmholtz.f:      subroutine chktcg1 (tol,res,h1,h2,mask,mult,imesh,isd)
hmholtz.f:      subroutine cggo(x,f,h1,h2,mask,mult,imsh,tin,maxit,isd,binv,name)
hmholtz.f:      subroutine calc (diag,upper,d,e,n,dmax,dmin)
hmholtz.f:      subroutine fdm_h1(z,r,d,mask,mult,nel,kt,rr)
hmholtz.f:      subroutine set_fdm_prec_h1A_gen
hmholtz.f:      subroutine set_fdm_prec_h1A_els
hmholtz.f:      subroutine set_fdm_prec_h1b(d,h1,h2,nel)
hmholtz.f:      subroutine set_fdm_prec_h1A
hmholtz.f:      subroutine generalev(a,b,lam,n,w)
hmholtz.f:      subroutine outmat2(a,m,n,k,name)
hmholtz.f:      subroutine rescale_abhalf (a,b,w,n)
hsmg.f:      subroutine hsmg_setup()
hsmg.f:      subroutine hsmg_setup_semhat
hsmg.f:      subroutine hsmg_setup_intp
hsmg.f:      subroutine hsmg_setup_intpm(jh,zf,zc,nf,nc)
hsmg.f:      subroutine hsmg_setup_dssum
hsmg.f:      subroutine hsmg_setup_wtmask
hsmg.f:      subroutine hsmg_intp(uf,uc,l) ! l is coarse level
hsmg.f:      subroutine hsmg_rstr(uc,uf,l) ! l is coarse level
hsmg.f:      subroutine hsmg_rstr_no_dssum(uc,uf,l) ! l is coarse level
hsmg.f:      subroutine hsmg_tnsr(v,nv,u,nu,A,At)
hsmg.f:      subroutine hsmg_tnsr2d(v,nv,u,nu,A,Bt)
hsmg.f:      subroutine hsmg_tnsr3d(v,nv,u,nu,A,Bt,Ct)
hsmg.f:      subroutine hsmg_tnsr2d_el(v,nv,u,nu,A,Bt)
hsmg.f:      subroutine hsmg_tnsr3d_el(v,nv,u,nu,A,Bt,Ct)
hsmg.f:      subroutine hsmg_dssum(u,l)
hsmg.f:      subroutine hsmg_dsprod(u,l)
hsmg.f:      subroutine hsmg_schwarz_dssum(u,l)
hsmg.f:      subroutine hsmg_extrude(arr1,l1,f1,arr2,l2,f2,nx,ny,nz)
hsmg.f:      subroutine hsmg_schwarz(e,r,l)
hsmg.f:      subroutine hsmg_schwarz_toext2d(a,b,n)
hsmg.f:      subroutine hsmg_schwarz_toext3d(a,b,n)
hsmg.f:      subroutine hsmg_schwarz_toreg2d(b,a,n)
hsmg.f:      subroutine hsmg_schwarz_toreg3d(b,a,n)
hsmg.f:      subroutine hsmg_setup_fdm()
hsmg.f:      subroutine hsmg_setup_fast(s,d,nl,ah,bh,n)
hsmg.f:      subroutine hsmg_setup_fast1d(s,lam,nl,lbc,rbc,ll,lm,lr,ah,bh,n,ie)
hsmg.f:      subroutine hsmg_setup_fast1d_a(a,lbc,rbc,ll,lm,lr,ah,n)
hsmg.f:      subroutine hsmg_setup_fast1d_b(b,lbc,rbc,ll,lm,lr,bh,n)
hsmg.f:      subroutine hsmg_fdm(e,r,l)
hsmg.f:      subroutine hsmg_do_fast(e,r,s,d,nl)
hsmg.f:      subroutine hsmg_do_wt(u,wt,nx,ny,nz)
hsmg.f:      subroutine hsmg_setup_rstr_wt(wt,nx,ny,nz,l,w)
hsmg.f:      subroutine hsmg_setup_mask(wt,nx,ny,nz,l,w)
hsmg.f:      subroutine hsmg_setup_schwarz_wt(ifsqrt)
hsmg.f:      subroutine hsmg_setup_schwarz_wt2d(wt,n,work,ifsqrt)
hsmg.f:      subroutine hsmg_setup_schwarz_wt3d(wt,n,work,ifsqrt)
hsmg.f:      subroutine hsmg_schwarz_wt(e,l)
hsmg.f:      subroutine hsmg_schwarz_wt2d(e,wt,n)
hsmg.f:      subroutine hsmg_schwarz_wt3d(e,wt,n)
hsmg.f:      subroutine hsmg_coarse_solve(e,r)
hsmg.f:      subroutine hsmg_setup_solve
hsmg.f:      subroutine hsmg_solve(e,r)
hsmg.f:      subroutine hsmg_setup_mg_nx()
ic.f:      subroutine setics
ic.f:c     mesh coordinates (see Subroutine INIGEOM)
ic.f:      subroutine slogic (iffort,ifrest,ifprsl,nfiles)
ic.f:      subroutine restart(nfiles)
ic.f:      subroutine sioflag(ndumps,fname,rsopts)
ic.f:      subroutine mapdmp(sdump,tdump,ieg,nxr,nyr,nzr,if_byte_sw)
ic.f:      subroutine mapab(x,y,nxr,nel)
ic.f:      subroutine mapab4R(x,y,nxr,nel)
ic.f:      subroutine csplit(s0,s1,s2,l0)
ic.f:      subroutine lshft(string,ipt)
ic.f:      subroutine ljust(string)
ic.f:      subroutine chknorm (ifzero)
ic.f:      subroutine prsolvt
ic.f:      subroutine prsolvv
ic.f:      subroutine nekuic
ic.f:      subroutine capit(lettrs,n)
ic.f:      subroutine perturb(tt,ifld,eps)
ic.f:      subroutine vcospf(x,y,n)
ic.f:      subroutine vbyte_swap(x,n)
ic.f:      subroutine geom_reset(icall)
ic.f:      subroutine dsavg(u)
ic.f:      subroutine map13_all(x3,x1)
ic.f:      subroutine mfi_gets(u,wk,lwk,iskip)
ic.f:      subroutine mfi_getv(u,v,w,wk,lwk,iskip)
ic.f:      subroutine mfi_parse_hdr(hdr)
ic.f:      subroutine parse_std_hdr(hdr)
ic.f:      subroutine parse_std_hdr_2006(hdr,rlcode)
ic.f:      subroutine mfi(fname)
ic.f:      subroutine mbyte_open(hname,fid) ! open  blah000.fldnn
ic.f:      subroutine mfi_prepare(hname)  ! determine which nodes are readers
induct.f:      subroutine induct (igeom)
induct.f:      subroutine lagbfield
induct.f:      subroutine makebsource_mhd
induct.f:      subroutine makeufb
induct.f:      subroutine makextb
induct.f:      subroutine makebdfb
induct.f:      subroutine cresvib(resv1,resv2,resv3,h1,h2)
induct.f:      subroutine cresvibp(resv1,resv2,resv3,h1,h2)
induct.f:      subroutine incomprn (ux,uy,uz,up)
induct.f:      subroutine opzero(ux,uy,uz)
induct.f:      subroutine opnorm(unorm,ux,uy,uz,type3)
induct.f:      subroutine lorentz_force (lf,b1,b2,b3,w1,w2)
induct.f:      subroutine curl(vort,u,v,w,ifavg,work1,work2)
induct.f:      subroutine lorentz_force2(lf,b1,b2,b3)
induct.f:      subroutine lorentz_force_e(lf,b1,b2,b3,e)
induct.f:      subroutine spec_curl_e (cb,b1,b2,b3,rx,ry,rz,sx,sy,sz,tx,ty,tz) 
induct.f:      subroutine specx(b,nb,a,na,ba,ab,w)
induct.f:      subroutine phys_to_elsasser(u1,u2,u3,b1,b2,b3,n)
induct.f:      subroutine elsasser_to_phys(u1,u2,u3,b1,b2,b3,n)
induct.f:      subroutine phys_to_elsasser2(u1,b1,n)
induct.f:      subroutine elsasser_to_phys2(u1,b1,n)
induct.f:      subroutine elsasserh(igeom)
induct.f:      subroutine compute_cfl(cfl,u,v,w,dt)
induct.f:      subroutine getdr(dri,zgm1,nx1)
induct.f:      subroutine ophinv_pr(o1,o2,o3,i1,i2,i3,h1,h2,tolh,nmxhi)
induct.f:      subroutine ophinvm(o1,o2,o3,i1,i2,i3,m1,m2,m3,h1,h2,tolh,nmxhi)
induct.f:      subroutine set_ifbcor(ifbcor)
induct.f:      subroutine setrhsp(p,h1,h2,h2inv,pset,nprev)
induct.f:      subroutine gensolnp(p,h1,h2,h2inv,pset,nprev)
induct.f:      subroutine econjp(pset,nprev,h1,h2,h2inv,ierr)
induct.f:      subroutine advab_elsasser_fast
induct.f:      subroutine set_dealias_rx
induct.f:      subroutine cfl_check
init_plugin.f:      subroutine init_plugin
makeq.f:      subroutine makeq
makeq_aux.f:      subroutine makeq_aux
map2.f:      subroutine mapelpr()
map2.f:      subroutine set_proc_map()
map2.f:      subroutine gfdm_elm_to_proc(gllnid,np)
map2.f:      subroutine gfdm_map_2d(map_st,nes,net,num_el,np)
map2.f:      subroutine gfdm_set_pst(ip,is,it,nelbox,nstride_box,nxp,nyp,nzp)
map2.f:      subroutine gfdm_build_global_el_map (gllnid,map_st,nes,net
map2.f:      subroutine outmati(u,m,n,name6)
map2.f:      subroutine get_map
math.f:      SUBROUTINE BLANK(A,N)
math.f:      SUBROUTINE VSQ (A,N)
math.f:      SUBROUTINE VSQRT(A,N)
math.f:      subroutine invers2(a,b,n)
math.f:      subroutine invcol1(a,n)
math.f:      subroutine invcol2(a,b,n)
math.f:      subroutine invcol3(a,b,c,n)
math.f:      subroutine col4(a,b,c,d,n)
math.f:      subroutine Xaddcol3(a,b,c,n)
math.f:      subroutine addcol4(a,b,c,d,n)
math.f:      subroutine ascol5 (a,b,c,d,e,n)
math.f:      subroutine sub2(a,b,n)
math.f:      subroutine sub3(a,b,c,n)
math.f:      subroutine subcol3(a,b,c,n)
math.f:      subroutine subcol4(a,b,c,d,n)
math.f:      subroutine rzero(a,n)
math.f:      subroutine izero(a,n)
math.f:      subroutine ione(a,n)
math.f:      subroutine rone(a,n)
math.f:      subroutine cfill(a,b,n)
math.f:      subroutine ifill(ia,ib,n)
math.f:      subroutine copy(a,b,n)
math.f:      subroutine chcopy(a,b,n)
math.f:      subroutine icopy(a,b,n)
math.f:      subroutine i8copy(a,b,n)
math.f:      subroutine chsign(a,n)
math.f:      subroutine cmult(a,const,n)
math.f:      subroutine cadd(a,const,n)
math.f:      subroutine iadd(i1,iscal,n)
math.f:      subroutine cadd2(a,b,const,n)
math.f:      subroutine vcross (u1,u2,u3,v1,v2,v3,w1,w2,w3,n)
math.f:      subroutine vdot2 (dot,u1,u2,v1,v2,n)
math.f:      subroutine vdot3 (dot,u1,u2,u3,v1,v2,v3,n)
math.f:      subroutine addtnsr(s,h1,h2,h3,nx,ny,nz)
math.f:      subroutine iflip(i1,n)
math.f:      subroutine iswap(b,ind,n,temp)
math.f:      subroutine col2(a,b,n)
math.f:      subroutine col2c(a,b,c,n)
math.f:      subroutine col3(a,b,c,n)
math.f:      subroutine add2(a,b,n)
math.f:      subroutine add3(a,b,c,n)
math.f:      subroutine addcol3(a,b,c,n)
math.f:      subroutine add2s1(a,b,c1,n)
math.f:      subroutine add2s2(a,b,c1,n)
math.f:      subroutine add3s2(a,b,c,c1,c2,n)
math.f:      subroutine add4(a,b,c,d,n)
math.f:      subroutine gllog(la,lb)
math.f:      subroutine dcadd(a,const,n)
math.f:      subroutine dsub2(a,b,n)
math.f:      subroutine dadd2(a,b,n)
math.f:      subroutine chswapr(b,L,ind,n,temp)
math.f:      subroutine drcopy(r,d,N)
math.f:      subroutine sorts(xout,xin,work,n)
math.f:      subroutine icadd(a,c,n)
math.f:      subroutine isort(a,ind,n)
math.f:      subroutine sort(a,ind,n)
math.f:      subroutine iswap_ip(x,p,n)
math.f:      subroutine iswapt_ip(x,p,n)
math.f:      subroutine swap_ip(x,p,n)
math.f:      subroutine swapt_ip(x,p,n)
math.f:      subroutine glvadd(x,w,n)
math.f:      subroutine add3s12(x,y,z,c1,c2,n)
math.f:      subroutine admcol3(a,b,c,d,n)
math.f:      subroutine add2col2(a,b,c,n)
math.f:      subroutine add2sxy(x,a,y,b,n)
math.f:      subroutine col2s2(x,y,s,n)
mpi_dummy.f:      subroutine mpi_scan(data1, data2, n, datatype,
mpi_dummy.f:      subroutine mpi_abort ( comm, errorcode, ierror )
mpi_dummy.f:      subroutine mpi_allgather ( data1, nsend, sendtype, data2, 
mpi_dummy.f:      subroutine mpi_allgatherv ( data1, nsend, sendtype,
mpi_dummy.f:      subroutine mpi_allreduce ( data1, data2, n, datatype,
mpi_dummy.f:      subroutine mpi_barrier ( comm, ierror )
mpi_dummy.f:      subroutine mpi_bcast ( data, n, datatype, node, comm, ierror )
mpi_dummy.f:      subroutine mpi_bsend ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_cart_create ( comm, ndims, dims, periods,
mpi_dummy.f:      subroutine mpi_cart_get ( comm, ndims, dims, periods,
mpi_dummy.f:      subroutine mpi_cart_shift ( comm, idir, idisp, isource, 
mpi_dummy.f:      subroutine mpi_comm_dup ( comm, comm_out, ierror )
mpi_dummy.f:      subroutine mpi_comm_free ( comm, ierror )
mpi_dummy.f:      subroutine mpi_comm_rank ( comm, me, ierror )
mpi_dummy.f:      subroutine mpi_comm_size ( comm, nprocs, ierror )
mpi_dummy.f:      subroutine mpi_comm_split ( comm, icolor, ikey, comm_new,
mpi_dummy.f:      subroutine mpi_copy_double_precision ( data1, data2, n, ierror )
mpi_dummy.f:      subroutine mpi_copy_integer ( data1, data2, n, ierror )
mpi_dummy.f:      subroutine mpi_copy_real ( data1, data2, n, ierror )
mpi_dummy.f:      subroutine mpi_finalize ( ierror )
mpi_dummy.f:      subroutine mpi_get_count ( istatus, datatype, icount, ierror )
mpi_dummy.f:      subroutine mpi_init ( ierror )
mpi_dummy.f:      subroutine mpi_irecv ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_isend ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_recv ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_reduce ( data1, data2, n, datatype, operation,
mpi_dummy.f:      subroutine mpi_reduce_double_precision ( 
mpi_dummy.f:      subroutine mpi_reduce_integer8 ( 
mpi_dummy.f:      subroutine mpi_reduce_integer ( 
mpi_dummy.f:      subroutine mpi_reduce_real ( 
mpi_dummy.f:      subroutine mpi_reduce_scatter ( data1, data2, n, datatype,
mpi_dummy.f:      subroutine mpi_rsend ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_send ( data, n, datatype, iproc, itag,
mpi_dummy.f:      subroutine mpi_wait ( irequest, istatus, ierror )
mpi_dummy.f:      subroutine mpi_waitall ( icount, irequest, istatus, ierror )
mpi_dummy.f:      subroutine mpi_waitany ( icount, array_of_requests, index, 
mpi_dummy.f:      subroutine mpi_initialized(mpi_is_initialized, ierr)
mpi_dummy.f:      subroutine mpi_comm_create(icomm,igroup,icommd,ierr)
mpi_dummy.f:      subroutine mpi_comm_group(icomm,igroup,ierr)
mpi_dummy.f:      subroutine mpi_group_free
mpi_dummy.f:      subroutine mpi_attr_get(icomm,ikey,ival,iflag,ierr)
mvmesh.f:      subroutine cbcmesh
mvmesh.f:      subroutine admeshv
mvmesh.f:      subroutine admesht
mvmesh.f:      subroutine divws (fms,sfv,phi,nel,idir)
mvmesh.f:      subroutine axifms (fms,sfv,phi,nel,idir)
mvmesh.f:      subroutine updcoor
mvmesh.f:C     Subroutine to update geometry for moving boundary problems
mvmesh.f:      subroutine mvbdry (nel)
mvmesh.f:      subroutine norcmp (wt1,wt2,wt3,rnx,rny,rnz,ifc)
mvmesh.f:      subroutine facemv (wt1,wt2,wt3,rnx,rny,rnz,smt,ifc)
mvmesh.f:      subroutine faczqn (wt1,wt2,wt3,ifc,iel)
mvmesh.f:      subroutine facsmt (smt,ifc)
mvmesh.f:      subroutine cqnet (qni,ta,nel)
mvmesh.f:      subroutine facemt (w1,w2,w3,rnx,rny,rnz,qni,dsa,smt,rhola,ifc)
mvmesh.f:      subroutine elasolv (nel)
mvmesh.f:      subroutine meshtol (ta,tolmsh,nel,imsolv)
mvmesh.f:      subroutine updxyz (nel)
mvmesh.f:      subroutine lagmshv (nel)
mvmesh.f:      subroutine facec3 (a1,a2,a3,b1,b2,b3,ifc)
mvmesh.f:      subroutine ptbgeom
mvmesh.f:C     Subroutine to impose perturbation to geometry before solution
mvmesh.f:      subroutine ibdgeom (nel)
mvmesh.f:      subroutine inigeom (ux,uy,uz,x,y,z,iside,iel)
mvmesh.f:      subroutine quickmv
mvmesh.f:      subroutine quickmv2d
mvmesh.f:      subroutine quickmv3d
mxm_std.f:      subroutine mxmf2(A,N1,B,N2,C,N3)
mxm_std.f:      subroutine mxf1(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf2(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf3(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf4(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf5(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf6(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf7(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf8(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf9(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf10(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf11(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf12(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf13(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf14(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf15(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf16(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf17(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf18(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf19(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf20(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf21(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf22(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf23(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxf24(a,n1,b,n2,c,n3)
mxm_std.f:      subroutine mxm44_0(a, m, b, k, c, n)
mxm_std.f:      subroutine mxm44_2(a, m, b, k, c, n)
mxm_wrapper.f:      subroutine mxm(a,n1,b,n2,c,n3)
navier0.f:      SUBROUTINE ESOLVER (RES,H1,H2,H2INV,INTYPE)
navier0.f:      SUBROUTINE ESTRAT
navier0.f:      SUBROUTINE EINIT
navier0.f:      subroutine dmp_map(imap)
navier0.f:      subroutine p_outvec_ir(ia,a,lda,name9)
navier1.f:      subroutine plan1 (igeom)
navier1.f:      subroutine crespuz (respr,g1,g2,g3,h1,h2,h2inv,intype)
navier1.f:      subroutine cresvuz (resv1,resv2,resv3)
navier1.f:      subroutine makeg (out1,out2,out3,h1,h2,intype)
navier1.f:      subroutine ctolspl (tolspl,respr)
navier1.f:      subroutine ortho (respr)
navier1.f:      subroutine zaver1 (pm1)
navier1.f:      subroutine cdabdtp (ap,wp,h1,h2,h2inv,intype)
navier1.f:      subroutine opgrad (out1,out2,out3,inp)
navier1.f:      subroutine cdtp (dtx,x,rm2,sm2,tm2,isd)
navier1.f:      subroutine multd (dx,x,rm2,sm2,tm2,isd,iflg)
navier1.f:      subroutine ophinv (out1,out2,out3,inp1,inp2,inp3,h1,h2,tolh,nmxi)
navier1.f:      subroutine ophx (out1,out2,out3,inp1,inp2,inp3,h1,h2)
navier1.f:      subroutine opbinv (out1,out2,out3,inp1,inp2,inp3,h2inv)
navier1.f:      subroutine opbinv1(out1,out2,out3,inp1,inp2,inp3,SCALE)
navier1.f:      subroutine uzprec (rpcg,rcg,h1m1,h2m1,intype,wp)
navier1.f:      subroutine eprec (z2,r2)
navier1.f:      subroutine convprn (iconv,rbnorm,rrpt,res,z,tol)
navier1.f:      subroutine convpr (res,tol,iconv,rbnorm)
navier1.f:      subroutine chktcg2 (tol,res,iconv)
navier1.f:      subroutine dudxyz (du,u,rm1,sm1,tm1,jm1,imsh,isd)
navier1.f:      subroutine convopo (conv,fi)
navier1.f:      subroutine conv2 (dtfi,fi)
navier1.f:      subroutine cmask (cmask1,cmask2)
navier1.f:      subroutine makef
navier1.f:      subroutine makeuf
navier1.f:      subroutine nekuf (f1,f2,f3)
navier1.f:      subroutine natconv 
navier1.f:      subroutine settbar (tbar)
navier1.f:      subroutine advab
navier1.f:      subroutine makebdf
navier1.f:      subroutine makeabf
navier1.f:      subroutine setab3 (ab0,ab1,ab2)
navier1.f:      subroutine setabbd (ab,dtlag,nab,nbd)
navier1.f:      subroutine setbd (bd,dtbd,nbd)
navier1.f:      subroutine bdsys (a,b,dt,nbd,ndim)
navier1.f:      subroutine advchar_old
navier1.f:      subroutine ophyprkn(vel1,vel2,vel3,ilag)
navier1.f:      subroutine ophypab (vel1,vel2,vel3,ilag)
navier1.f:      subroutine tauinit (tau,ilag)
navier1.f:      subroutine velinit (vel1,vel2,vel3,ilag)
navier1.f:      subroutine velconv (vxn,vyn,vzn,tau)
navier1.f:      subroutine frkconv (y,x,mask)
navier1.f:      subroutine velchar (vel,vn,vlag,nbd,tau,dtbd)
navier1.f:      subroutine lagvel
navier1.f:      subroutine hypmsk3 (hv1msk,hv2msk,hv3msk)
navier1.f:      subroutine setordbd
navier1.f:      subroutine testmom (rmom,resv1,resv2,resv3,w1,w2,w3)
navier1.f:      subroutine testdtp
navier1.f:      subroutine tmultd
navier1.f:      subroutine normsc (h1,semi,l2,linf,x,imesh)
navier1.f:      subroutine normvc (h1,semi,l2,linf,x1,x2,x3)
navier1.f:      subroutine genwp (wp,wm2,p)
navier1.f:      subroutine convuz (ifstuz)
navier1.f:      subroutine convsp (ifstsp)
navier1.f:      subroutine antimsk (y,x,xmask,n)
navier1.f:      subroutine opamask (vbdry1,vbdry2,vbdry3) 
navier1.f:      subroutine opmask (res1,res2,res3)
navier1.f:      subroutine opadd2 (a1,a2,a3,b1,b2,b3)
navier1.f:      subroutine opsub2 (a1,a2,a3,b1,b2,b3)
navier1.f:      subroutine opsub3 (a1,a2,a3,b1,b2,b3,c1,c2,c3)
navier1.f:      subroutine opcolv3(a1,a2,a3,b1,b2,b3,c)
navier1.f:      subroutine opcolv (a1,a2,a3,c)
navier1.f:      subroutine opcol2 (a1,a2,a3,b1,b2,b3)
navier1.f:      subroutine opchsgn (a,b,c)
navier1.f:      subroutine opcopy (a1,a2,a3,b1,b2,b3)
navier1.f:      subroutine rotate_cyc(r1,r2,r3,idir)
navier1.f:      subroutine opdssum (a,b,c)! NOTE: opdssum works on FLUID/MHD arrays only!
navier1.f:      subroutine opdsop (a,b,c,op)! opdsop works on FLUID/MHD arrays only!
navier1.f:      subroutine opicol2 (a1,a2,a3,b1,b2,b3)
navier1.f:      subroutine oprzero (a,b,c)
navier1.f:      subroutine oprone (a,b,c)
navier1.f:      subroutine opcmult (a,b,c,const)
navier1.f:      subroutine opcolv2c(a1,a2,a3,b1,b2,c)
navier1.f:      subroutine opcolv2(a1,a2,a3,b1,b2)
navier1.f:      subroutine opadd2col(a1,a2,a3,b1,b2,b3,c)
navier1.f:      subroutine opcolv3c(a1,a2,a3,b1,b2,b3,c,d)
navier1.f:      subroutine uzawa (rcg,h1,h2,h2inv,intype,iter)
navier1.f:      subroutine spbslpf(abd,lda,n,m,b)
navier1.f:      subroutine spbfapf(abd,lda,n,m,info)
navier1.f:      subroutine mapw(md,nd,m1,n1,mflg)
navier1.f:      subroutine mapwp(md,nd,m1,n1,mflg)
navier1.f:      subroutine specmp(b,nb,a,na,ba,ab,w)
navier1.f:      subroutine setmap(n1,nd)
navier1.f:      subroutine set_PND(P,LkD,LkNt,N,D)
navier1.f:      subroutine transpose(a,lda,b,ldb)
navier1.f:      subroutine convop(conv,fi)
navier1.f:      subroutine conv1d (dfi,fi)
navier1.f:      subroutine conv1n(du,u)
navier1.f:      subroutine conv1o(dfi,fi)
navier1.f:      subroutine conv1 (dfi,fi)
navier1.f:      subroutine conv1no(du,u)
navier1.f:      subroutine conv1rk(du,dv,dw,u,v,w)
navier1.f:      subroutine velconvv(vxn,vyn,vzn,tau)
navier1.f:      subroutine frkconvv (du,dv,dw,u,v,w,mu)
navier1.f:      subroutine conv1rk2(du,dv,dw,u,v,w,cu,cv,cw,beta,wk)
navier1.f:      subroutine frkconvv2(du,dv,dw,u,v,w,cu,cv,cw,beta,mu,wk)
navier1.f:      subroutine hypmsk3v(msk,mask)
navier1.f:      subroutine ophyprk (vel1,vel2,vel3,ilag)
navier1.f:      subroutine opdiv(outfld,inpx,inpy,inpz)
navier1.f:      subroutine opgradt(outx,outy,outz,inpfld)
navier1.f:      subroutine setproj(n1,nd)
navier1.f:      subroutine set_PNDoi(Pt,P,LkNt,N,D)
navier1.f:      subroutine wgradm1(ux,uy,uz,u,nel) ! weak form of grad 
navier1.f:      SUBROUTINE MAKEVIS
navier1.f:      SUBROUTINE COMP_SIEJ (U1,U2,U3)
navier1.f:      subroutine wlaplacian(out,a,diff,ifld)
navier2.f:      subroutine aspect_ratios(ar)
navier2.f:      subroutine eig2(AA,eign,eig1)
navier2.f:      subroutine quadratic_h(x1,x2,a,b,c)
navier2.f:      subroutine out_sem(iel)
navier2.f:      subroutine gradm11(ux,uy,uz,u,e)
navier2.f:      subroutine gradm11ts(u,ux,uy,uz,e)
navier2.f:      subroutine makemsf(afx,afy,afz)
navier3.f:      SUBROUTINE EPREC2(Z2,R2)
navier3.f:      subroutine dd_solver(u,v)
navier3.f:      subroutine rar2_out(x,name13)
navier3.f:      subroutine rarr_out2(x,name13)
navier4.f:      subroutine incompr
navier4.f:      subroutine setrhs(p,h1,h2,h2inv)
navier4.f:      subroutine gensoln(p,h1,h2,h2inv)
navier4.f:      subroutine updtset(p,h1,h2,h2inv,IERR)
navier4.f:      subroutine econj(kprev,h1,h2,h2inv,ierr)
navier4.f:      subroutine chkptol
navier4.f:      subroutine updrhse(p,h1,h2,h2inv,ierr)
navier4.f:      subroutine echeck(kprev,h1,h2,h2inv,intetype)
navier4.f:      subroutine savep(P,H1,H2,H2INV)
navier4.f:      subroutine projh(r,h1,h2,bi,vml,vmk,approx,napprox,wl,ws,name4)
navier4.f:      subroutine gensh(v1,h1,h2,vml,vmk,approx,napprox,wl,ws,name4)
navier4.f:      subroutine hconj(approx,k,h1,h2,vml,vmk,ws,name4,ierr)
navier4.f:      subroutine updrhsh(approx,napprox,h1,h2,vml,vmk,ws,name4)
navier4.f:      subroutine hmhzpf(name,u,r,h1,h2,mask,mult,imesh,tli,maxit,isd,bi)
navier4.f:      subroutine hsolve(name,u,r,h1,h2,vmk,vml,imsh,tol,maxit,isd
navier5.f:      subroutine q_filter(wght)
navier5.f:      subroutine filterq(v,f,nx,nz,w1,w2,ft,if3d,dmax)
navier5.f:      subroutine outmatx(a,m,n,io,name)
navier5.f:      subroutine drag_calc(scale)
navier5.f:      subroutine mappr(pm1,pm2,pa,pb)
navier5.f:      subroutine out_csrmats(acsr,ia,ja,n,name9)
navier5.f:      subroutine local_grad3(ur,us,ut,u,N,e,D,Dt)
navier5.f:      subroutine local_grad2(ur,us,u,N,e,D,Dt)
navier5.f:      subroutine gradm1(ux,uy,uz,u)
navier5.f:      subroutine outpost(v1,v2,v3,vp,vt,name3)
navier5.f:      subroutine outpost2(v1,v2,v3,vp,vt,nfldt,name3)
navier5.f:      subroutine comp_vort3(vort,work1,work2,u,v,w)
navier5.f:      subroutine surface_int(sint,sarea,a,ie,iface1)
navier5.f:      subroutine surface_flux(dq,qx,qy,qz,ie,iface,w)
navier5.f:      subroutine gaujordf(a,m,n,indr,indc,ipiv,ierr,rmult)
navier5.f:      subroutine legendre_poly(L,x,N)
navier5.f:      subroutine build_new_filter(intv,zpts,nx,kut,wght,nid)
navier5.f:      subroutine avg_all
navier5.f:      subroutine avg1(avg,f,alpha,beta,n,name,ifverbose)
navier5.f:      subroutine avg2(avg,f,alpha,beta,n,name,ifverbose)
navier5.f:      subroutine avg3(avg,f,g,alpha,beta,n,name,ifverbose)
navier5.f:      subroutine build_legend_transform(Lj,Ljt,zpts,nx)
navier5.f:      subroutine local_err_est(err,u,nx,Lj,Ljt,uh,w,if3d)
navier5.f:      subroutine transpose1(a,n)
navier5.f:      subroutine get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
navier5.f:      subroutine dump_header2d(excode,nx,ny,nlx,nly)
navier5.f:      subroutine outfld2d_p(u,v,w,nx,ny,nlx,nly,name,ifld,jid,npido)
navier5.f:      subroutine outfld2d(u,v,w,nx,ny,nlx,nly,name,ifld)
navier5.f:      subroutine planar_average_z(ua,u,w1,w2)
navier5.f:      subroutine drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,visc,f,e)
navier5.f:      subroutine torque_calc(scale,x0,ifdout,iftout)
navier5.f:      subroutine comp_sij(sij,nij,u,v,w,ur,us,ut,vr,vs,vt,wr,ws,wt)
navier5.f:      subroutine y_slice (ua,u,w1,w2)
navier5.f:      subroutine z_slice (ua,u,w1,w2)
navier5.f:      subroutine y_average(ua,u,w1,w2)
navier5.f:      subroutine z_average(ua,u,w1,w2)
navier5.f:      subroutine y_avg_buff(ux,uy,uz,c2,name,icount)
navier5.f:      subroutine z_avg_buff(ux,uy,uz,c2,name,icount)
navier5.f:      subroutine y_ins_buff(ux,uy,uz,c2,name,icount)
navier5.f:      subroutine z_ins_buff(ux,uy,uz,c2,name,icount)
navier5.f:      subroutine buff_2d_out(u,v,w,nx,ny,nex,ney,c2,name,ifld)
navier5.f:      subroutine y2d(u,v,w,p,c1,icount)
navier5.f:      subroutine z2d(u,v,w,p,c1,icount)
navier5.f:      subroutine anal_2d
navier5.f:      subroutine chkit(u,name4,n)
navier5.f:      subroutine outmesh
navier5.f:      subroutine out_el(xt,e)
navier5.f:      subroutine get_el(xt,x,y,z)
navier5.f:      subroutine shear_calc_max(strsmx,scale,x0,ifdout,iftout)
navier5.f:      subroutine get_strsmax(strsmax,xm0,ym0,zm0,sij,pm1,visc,f,e)
navier5.f:      subroutine fix_geom ! fix up geometry irregularities
navier5.f:      subroutine gh_face_extend(x,zg,n,gh_type,e,v)
navier5.f:      subroutine gh_face_extend_2d(x,zg,n,gh_type,e,v)
navier5.f:      subroutine gh_face_extend_3d(x,zg,n,gh_type,e,v)
navier5.f:      subroutine rand_fld_h1(x)
navier5.f:      subroutine rescale_x (x,x0,x1)
navier6.f:      subroutine set_overlap
navier6.f:      subroutine overflow_ck(n_req,n_avail,signal)
navier6.f:      subroutine iunswap(b,ind,n,temp)
navier6.f:      subroutine set_fem_data_l2(nep,nd,no,x,y,z,p)
navier6.f:      subroutine map_face12(x2,x1,w1,w2)
navier6.f:      subroutine map_one_face12(x2,x1,iface,i12,i12t,w1,w2)
navier6.f:      subroutine dface_add1sa(x)
navier6.f:      subroutine faces(a,s,ie,iface,nx,ny,nz)
navier7.f:      subroutine out_acsr(acsr,ia,ja,n)
navier7.f:      subroutine compress_acsr(acsr,ia,ja,n)
navier7.f:      subroutine outbox(xmax,xmin,ymax,ymin,io)
navier7.f:      subroutine imout(x,m,n,name)
navier7.f:      subroutine out_abd(abd,lda,n,m)
navier7.f:      subroutine rarr_out(x,name13)
navier7.f:      subroutine iarr_out(x,name)
navier7.f:      subroutine iar2_out(x,name)
navier7.f:      subroutine scsr_permute(bcsr,ib,jb,acsr,ia,ja,n
navier7.f:      write(6,*) 'HMT HACK in subroutine scsr_permute() ... pls fix!'
navier7.f:      subroutine scsr_to_spb(abd,lda,acsr,ia,ja,n)
navier7.f:      subroutine scsr_to_spbm(abd,lda,acsr,ia,ja,n)
navier7.f:      subroutine out_spbmat(abd,n,lda,name)
navier7.f:      subroutine swap(b,ind,n,temp)
navier7.f:      subroutine ipermute(a,icperm,n,b)
navier7.f:      subroutine out_csrmat(acsr,ia,ja,n,name9)
navier8.f:      subroutine set_vert(glo_num,ngv,nx,nel,vertex,ifcenter)
navier8.f:      subroutine crs_solve_l2(uf,vf)
navier8.f:c      subroutine test_h1_crs
navier8.f:      subroutine set_up_h1_crs
navier8.f:      subroutine set_jl_crs_mask(n, mask, se_to_gcrs)
navier8.f:      subroutine set_mat_ij(ia,ja,n,ne)
navier8.f:      subroutine irank_vec(ind,nn,a,m,n,key,nkey,aa)
navier8.f:      subroutine ituple_sort(a,lda,n,key,nkey,ind,aa)
navier8.f:      subroutine tuple_sort(a,lda,n,key,nkey,ind,aa)
navier8.f:      subroutine get_local_crs(a,lda,nxc,h1,h2,w,ldw)
navier8.f:      subroutine a_crs_enriched(a,h1,h2,x1,y1,z1,nxc,if3d,ie)
navier8.f:      subroutine a_crs_3d(a,h1,h2,xc,yc,zc,ie)
navier8.f:      subroutine bindec(bin_in)
navier8.f:      subroutine get_local_A_tet(a,x,y,z,kt,ie)
navier8.f:      subroutine a_crs_2d(a,h1,h2,x,y,ie)
navier8.f:      subroutine map_m_to_n(a,na,b,nb,if3d,w,ldw)
navier8.f:      subroutine specmpn(b,nb,a,na,ba,ab,if3d,w,ldw)
navier8.f:      subroutine irank(A,IND,N)
navier8.f:      subroutine iranku(r,input,n,w,ind)
navier8.f:      subroutine ifacev_redef(a,ie,iface,val,nx,ny,nz)
navier8.f:      subroutine map_c_to_f_l2_bilin(uf,uc,w)
navier8.f:      subroutine map_f_to_c_l2_bilin(uc,uf,w)
navier8.f:      subroutine maph1_to_l2(a,na,b,nb,if3d,w,ldw)
navier8.f:      subroutine maph1_to_l2t(b,nb,a,na,if3d,w,ldw)
navier8.f:      subroutine irank_vec_tally(ind,nn,a,m,n,key,nkey,key2,aa)
navier8.f:      subroutine out_se1(se2crs,nx,name)
navier8.f:      subroutine out_se0(se2crs,nx,nel,name)
navier8.f:      subroutine crs_solve_h1(uf,vf)
navier8.f:      subroutine set_h1_basis_bilin
navier8.f:      subroutine map_c_to_f_h1_bilin(uf,uc)
navier8.f:      subroutine map_f_to_c_h1_bilin(uc,uf)
navier8.f:      subroutine get_local_crs_galerkin(a,ncl,nxc,h1,h2,w1,w2)
navier8.f:      subroutine gen_crs_basis(b,j) ! bi- tri-linear
navier8.f:      subroutine gen_crs_basis2(b,j) ! bi- tri-quadratic
navier8.f:      subroutine get_vertex
navier8.f:      subroutine assign_gllnid(gllnid,iunsort,nelgt,nelgv,np)
navier8.f:      subroutine get_vert
navier8.f:      subroutine get_vert_map(vertex, nlv, nel, suffix)
navier8.f:      subroutine irank_vecn(ind,nn,a,m,n,key,nkey,aa)
navier8.f:      subroutine gbtuple_rank(tuple,m,n,nmax,cr_h,nid,np,ind)
navier8.f:      subroutine setvert3d(glo_num,ngv,nx,nel,vertex,ifcenter)
navier8.f:      subroutine setvert2d(glo_num,ngv,nx,nel,vertex,ifcenter)
papi.f:      subroutine nek_flops(flops,mflops)
papi.f:      subroutine getflops_papi(flops,mflops)
pertsupport.f:      subroutine flushBuffer(k)
pertsupport.f:      subroutine opscale(v1,v2,v3,temp,alpha)
pertsupport.f:      subroutine opscaleV(v1,v2,v3,alpha)
pertsupport.f:      subroutine computelyap
pertsupport.f:      subroutine computelyap1(vxq,vyq,vzq,tq,jpp)
pertsupport.f:      subroutine rescalepert(pertnorm,pertinvnorm,jpp)
pertsupport.f:      subroutine writehist(v1,v2,v3,temp,jpp)
pertsupport.f:      subroutine initialize
pertsupport.f:      subroutine initialize1(jpp)
pertsupport.f:      subroutine get_useric
pertsupport.f:      subroutine out_pert  ! dump perturbation .fld files
pertsupport.f:      subroutine pert_add2s2(i,j,scale)   ! xi = xi + scale * xj
pertsupport.f:      subroutine pert_ortho_norm ! orthogonalize and rescale pert. arrays
pertsupport.f:      subroutine pert_ortho_norm1 (k) ! orthogonalize k against 1...k-1
perturb.f:      subroutine fluidp (igeom)
perturb.f:      subroutine perturbv (igeom)
perturb.f:      subroutine lagfieldp
perturb.f:      subroutine makefp
perturb.f:      subroutine makeufp
perturb.f:      subroutine advabp
perturb.f:      subroutine makextp
perturb.f:      subroutine makebdfp
perturb.f:      subroutine cresvipp(resv1,resv2,resv3,h1,h2)
perturb.f:      subroutine heatp (igeom)
perturb.f:      subroutine cdscalp (igeom)
perturb.f:      subroutine makeqp
perturb.f:      subroutine makeuqp
perturb.f:      subroutine convabp
perturb.f:      subroutine makeabqp
perturb.f:      subroutine makebdqp
perturb.f:      subroutine lagscalp
perturb.f:      subroutine incomprp (ux,uy,uz,up)
perturb.f:      subroutine extrapprp (prextr)
perturb.f:      subroutine lagpresp
perturb.f:      subroutine lyap_scale ! Rescale / orthogonalize perturbation fields
perturb.f:      subroutine out_pert  ! dump perturbation .fld files
perturb.f:      subroutine pert_add2s2(i,j,scale)   ! xi = xi + scale * xj
perturb.f:      subroutine pert_ortho_norm ! orthogonalize and rescale pert. arrays
perturb.f:      subroutine pert_ortho_norm1 (k) ! orthogonalize k against 1...k-1
perturb.f:      subroutine opscale(v1,v2,v3,temp,alpha)
perturb.f:      subroutine opscaleV(v1,v2,v3,alpha)
perturb.f:      subroutine computelyap
perturb.f:      subroutine computelyap1(vxq,vyq,vzq,tq,jpp)
perturb.f:      subroutine rescalepert(pertnorm,pertinvnorm,jpp)
plan4.f:      subroutine plan4
plan4.f:c           by an external subroutine e.g qthermal
plan4.f:      subroutine crespsp (respr)
plan4.f:      subroutine cresvsp (resv1,resv2,resv3,h1,h2)
plan4.f:      subroutine op_curl(w1,w2,w3,u1,u2,u3,ifavg,work1,work2)
plan4.f:      subroutine opadd2cm (a1,a2,a3,b1,b2,b3,c)
plan4.f:      subroutine split_vis
plan4.f:      subroutine redo_split_vis
plan4.f:      subroutine v_extrap(vext)
planx.f:      SUBROUTINE PLAN3 (IGEOM)
planx.f:      SUBROUTINE LAGPRES 
planx.f:      SUBROUTINE CRESVIF (RESV1,RESV2,RESV3,H1,H2)
planx.f:      SUBROUTINE EXTRAPP (PREXTR)
planx.f:      subroutine ophinvpr(ot1,ot2,ot3,in1,in2,in3,h1,h2,tolh,nmxi)
planx.f:      subroutine hmzpf2(nm,u,rhs,h1,h2,mask,mult,imsh,tol,mxit,isd)
planx.f:      subroutine projh2(v1,h1,h2,vml,vmask,isd)
planx.f:      subroutine gensh2(v1,h1,h2,vml,vmask,isd)
planx.f:      subroutine updtseth2(v1,h1,h2,vml,vmask,isd)
planx.f:      subroutine hconj2(kprev,h1,h2,vml,vmask,isd)
planx.f:      subroutine updrhsh2(h1,h2,vml,vmask,isd)
postpro.f:      subroutine load_fld(string)
postpro.f:      subroutine lambda2(l2)
postpro.f:      subroutine find_lam3(lam,aa,w,ndim,ierr)
postpro.f:      subroutine quadratic(x1,x2,a,b,c,ierr)
postpro.f:      subroutine cubic(xo,ai1,ai2,ai3,ierr)
postpro.f:      subroutine comp_gije(gije,u,v,w,e)
postpro.f:      subroutine filter_s1(scalar,tf,nx,nel) ! filter scalar field 
postpro.f:      subroutine filter_s0(scalar,wght,ncut,name5) ! filter scalar field 
postpro.f:      subroutine intpts_setup(tolin)
postpro.f:      subroutine intpts(fieldin,nfld,iTl,mi,rTl,mr,n,iffindin,ih)
postpro.f:      subroutine intpts_done()
postpro.f:      subroutine tens3d1(v,u,f,ft,nv,nu)  ! v = F x F x F x u
postpro.f:      subroutine build_1d_filt(fh,fht,trnsfr,nx,nid)
postpro.f:      subroutine mag_tensor_e(mag,aije)
postpro.f:      subroutine comp_sije(gije)
postpro.f:      subroutine map2reg(ur,n,u,nel)
postpro.f:      subroutine map2reg_2di_e(uf,n,uc,m) ! Fine, uniform pt
postpro.f:      subroutine map2reg_3di_e(uf,n,uc,m) ! Fine, uniform pt
postpro.f:      subroutine gen_int_gz(j,jt,g,n,z,m)
postpro.f:      subroutine zuni(z,np)
postpro.f:      subroutine gen_rea(imid)  ! Generate and output essential parts of .rea
postpro.f:      subroutine gen_rea_xyz
postpro.f:      subroutine gen_rea_curve(imid)
postpro.f:      subroutine gen_rea_bc (ifld)
postpro.f:      subroutine gen_rea_midside_e(e)
postpro.f:      subroutine hpts
prepost.f:      subroutine prepost(ifdoin,prefin)
prepost.f:      subroutine prepost_map(isave) ! isave=0-->fwd, isave=1-->bkwd
prepost.f:      subroutine outfld(prefix)
prepost.f:      subroutine outhis(ifhis) ! output time history info
prepost.f:      subroutine intglq
prepost.f:      subroutine bdforce
prepost.f:      subroutine bdheat
prepost.f:      subroutine setsmu (smult)
prepost.f:      subroutine file2(nopen,PREFIX)
prepost.f:      subroutine rzero4(a,n)
prepost.f:      subroutine copyX4(a,b,n)
prepost.f:      subroutine copy4r(a,b,n)
prepost.f:      subroutine dump_header(excodein,p66)
prepost.f:      subroutine fill_tmp(tdump,id,ie)
prepost.f:      subroutine get_id(id)
prepost.f:      subroutine close_fld(p66)
prepost.f:      subroutine out_tmp(id,p66)
prepost.f:      subroutine mfo_outfld(prefix)  ! muti-file output
prepost.f:      subroutine io_init ! determine which nodes will output
prepost.f:      subroutine mfo_open_files(prefix) ! open files
prepost.f:      subroutine restart_nfld( nfld, prefix ) 
prepost.f:      subroutine restart_save(iosave,save_size,nfldi)
prepost.f:      subroutine mfo_mdatav(u,v,w,nel)
prepost.f:      subroutine mfo_mdatas(u,nel)
prepost.f:      subroutine mfo_outs(u,nel,mx,my,mz)   ! output a scalar field
prepost.f:      subroutine mfo_outv(u,v,w,nel,mx,my,mz)   ! output a vector field
prepost.f:      subroutine mfo_write_hdr          ! write hdr, byte key, els.
qthermal.f:      subroutine qthermal
setprop.f:      subroutine setprop
speclib.f:      SUBROUTINE ZWGL (Z,W,NP)
speclib.f:      SUBROUTINE ZWGLL (Z,W,NP)
speclib.f:      SUBROUTINE ZWGJ (Z,W,NP,ALPHA,BETA)
speclib.f:      SUBROUTINE ZWGJD (Z,W,NP,ALPHA,BETA)
speclib.f:      SUBROUTINE ZWGLJ (Z,W,NP,ALPHA,BETA)
speclib.f:      SUBROUTINE ZWGLJD (Z,W,NP,ALPHA,BETA)
speclib.f:      SUBROUTINE JACG (XJAC,NP,ALPHA,BETA)
speclib.f:      SUBROUTINE JACOBF (POLY,PDER,POLYM1,PDERM1,POLYM2,PDERM2,
speclib.f:      SUBROUTINE DGJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f:      SUBROUTINE DGJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f:      SUBROUTINE DGLJ (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f:      SUBROUTINE DGLJD (D,DT,Z,NZ,NZD,ALPHA,BETA)
speclib.f:      SUBROUTINE DGLL (D,DT,Z,NZ,NZD)
speclib.f:         WRITE (6,*) 'Subroutine DGLL'
speclib.f:      SUBROUTINE DGLLGL (D,DT,ZM1,ZM2,IM12,NZM1,NZM2,ND1,ND2)
speclib.f:C     (see subroutine IGLLGL).
speclib.f:      SUBROUTINE DGLJGJ (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
speclib.f:C     (see subroutine IGLJGJ).
speclib.f:      SUBROUTINE DGLJGJD (D,DT,ZGL,ZG,IGLG,NPGL,NPG,ND1,ND2,ALPHA,BETA)
speclib.f:C     (see subroutine IGLJGJ).
speclib.f:      SUBROUTINE IGLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
speclib.f:      SUBROUTINE IGLLM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2)
speclib.f:      SUBROUTINE IGJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
speclib.f:      SUBROUTINE IGLJM (I12,IT12,Z1,Z2,NZ1,NZ2,ND1,ND2,ALPHA,BETA)
ssolv.f:      SUBROUTINE SSTEST (ISSS)
ssolv.f:      SUBROUTINE SSINIT (KMAX)
ssolv.f:      SUBROUTINE CHKEXT (IFACCX,Z,S)
ssolv.f:      SUBROUTINE FILLLAG
ssolv.f:      SUBROUTINE GONSTEP (N,ITEST)
ssolv.f:      SUBROUTINE GO1STEP (X,Y,NVEC)
ssolv.f:      SUBROUTINE GOSTEP 
ssolv.f:      SUBROUTINE MODPROP
ssolv.f:      SUBROUTINE MKVEC (X)
ssolv.f:      SUBROUTINE MKARR (X)
ssolv.f:      SUBROUTINE SSPARAM (KMAX,L)
ssolv.f:      SUBROUTINE CHKSSVT
ssolv.f:      SUBROUTINE CHKSSV
ssolv.f:      SUBROUTINE CHKSST 
ssolv.f:      SUBROUTINE SSNORMD (DV1,DV2,DV3)
ssolv.f:      SUBROUTINE SSNORMP (DV1,DV2,DV3)
ssolv.f:      SUBROUTINE SETTOLV
ssolv.f:C           See subroutine CHKSSV
ssolv.f:      SUBROUTINE SETTOLT
ssolv.f:      SUBROUTINE CHKTOLP (TOLMIN)
ssolv.f:      SUBROUTINE SETCHAR
ssolv.f:      SUBROUTINE PROJECT
subs1.f:      SUBROUTINE SETDT
subs1.f:      SUBROUTINE CVGNLPS (IFCONV)
subs1.f:      SUBROUTINE UNORM
subs1.f:      SUBROUTINE CHKTMG (TOL,RES,W1,W2,MULT,MASK,IMESH)
subs1.f:      SUBROUTINE SETDTC
subs1.f:      SUBROUTINE CUMAX (V1,V2,V3,UMAX)
subs1.f:      SUBROUTINE SETDTFS (DTFS)
subs1.f:      SUBROUTINE CDXMIN2 (DTST,RHOSIG,IEL,IFC,IFAXIS)
subs1.f:      SUBROUTINE CDXMIN3 (DTST,RHOSIG,IEL,IFC)
subs1.f:      SUBROUTINE FCAVER(XAVER,A,IEL,IFACE1)
subs1.f:      SUBROUTINE FACCL2(A,B,IFACE1)
subs1.f:      SUBROUTINE FACCL3(A,B,C,IFACE1)
subs1.f:      SUBROUTINE FADDCL3(A,B,C,IFACE1)
subs1.f:      subroutine sethlm (h1,h2,intloc)
subs1.f:      SUBROUTINE VPROPS 
subs1.f:      SUBROUTINE NEKUVP (IEL)
subs1.f:      SUBROUTINE DIAGNOS
subs1.f:      SUBROUTINE SETSOLV
subs1.f:      SUBROUTINE MGGO
subs1.f:      SUBROUTINE MGINIT
subs1.f:      SUBROUTINE HMHZSF (NAME,U1,U2,U3,R1,R2,R3,H1,H2,
subs1.f:      SUBROUTINE CHKTCGS (R1,R2,R3,RMASK1,RMASK2,RMASK3,RMULT,BINV,
subs1.f:      SUBROUTINE CGGOSF (U1,U2,U3,R1,R2,R3,H1,H2,RMULT,BINV,
subs1.f:      SUBROUTINE AXHMSF (AU1,AU2,AU3,U1,U2,U3,H1,H2,MATMOD)
subs1.f:      SUBROUTINE STNRATE (U1,U2,U3,NEL,MATMOD)
subs1.f:      SUBROUTINE UXYZ (U,EX,EY,EZ,NEL)
subs1.f:      SUBROUTINE URST (U,UR,US,UT,NEL)
subs1.f:      SUBROUTINE DDRST (U,UR,US,UT)
subs1.f:      SUBROUTINE AXIEZZ (U2,EYY,EZZ,NEL)
subs1.f:      subroutine flush_io
subs1.f:      subroutine fcsum2(xsum,asum,x,e,f)
subs2.f:      SUBROUTINE STRESS (H1,H2,NEL,MATMOD,IFAXIS)
subs2.f:      SUBROUTINE AIJUJ (AU1,AU2,AU3,NEL,IFAXIS)
subs2.f:      SUBROUTINE TTXYZ (FF,TX,TY,TZ,NEL)
subs2.f:      SUBROUTINE TTRST (FF,FR,FS,FT,TA)
subs2.f:      SUBROUTINE AXITZZ (VFY,TZZ,NEL)
subs2.f:      SUBROUTINE SETAXDY (IFAXDY)
subs2.f:      SUBROUTINE SETAXW1 (IFAXWG)
subs2.f:      SUBROUTINE SETAXW2 (IFAXWG)
subs2.f:      SUBROUTINE STNRINV
subs2.f:      SUBROUTINE OPDOT (DP,A1,A2,A3,B1,B2,B3,N)
subs2.f:      SUBROUTINE OPADDS (A1,A2,A3,B1,B2,B3,CONST,N,ISC)
subs2.f:      SUBROUTINE FACEXS (A,B,IFACE1,IOP)
subs2.f:      SUBROUTINE FACEXV (A1,A2,A3,B1,B2,B3,IFACE1,IOP)
subs2.f:      SUBROUTINE FACSUB2 (A1,A2,A3,B1,B2,B3,IFACE1)
subs2.f:      SUBROUTINE GAMMASF (H1,H2)
subs2.f:      SUBROUTINE CMULT2 (A,B,CONST,N)
subs2.f:      SUBROUTINE ADD3S (A,B,C,CONST,N)
subs2.f:      SUBROUTINE EMERXIT
subs2.f:      SUBROUTINE FACCVS (A1,A2,A3,B,IFACE1)
subs2.f:      SUBROUTINE STX1SF
subs2.f:      SUBROUTINE SOLVEL
subs2.f:      SUBROUTINE VSOLN (UX,UY,UZ,X,Y,Z,PI)
subs2.f:      SUBROUTINE SOLPRES
subs2.f:      SUBROUTINE PRSOLN (P,X,Y,Z,PI)
subs2.f:      SUBROUTINE STORE
subs2.f:      SUBROUTINE PRINTEL (TA,A,IEL)
subs2.f:      SUBROUTINE PRINTV (TA,A,NEL)
subs2.f:      SUBROUTINE OUTF1 (X,TXT,IEL,IFC)
subs2.f:      SUBROUTINE OUTM1 (X,TXT,NP,IEL,IP)
subs2.f:      SUBROUTINE OUTM2 (X,TXT,NP,IEL,IP)
subs2.f:      SUBROUTINE STSMASK (C1MASK,C2MASK,C3MASK)
subs2.f:      SUBROUTINE UPDMSYS (IFLD)
subs2.f:      SUBROUTINE SETHMSK (HVMASK,HFMASK,IFLD,NEL)
subs2.f:      SUBROUTINE SKIPCNR (NEL)
subs2.f:      SUBROUTINE SETMASK (C1MASK,C2MASK,C3MASK,HVMASK,NEL) 
subs2.f:      SUBROUTINE SETMLOG (HVMASK,HFMASK,IFLD,NEL)
subs2.f:      SUBROUTINE SETCSYS (HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE COMAVN2 (HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE COMAVN3 (HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE FIXWMSK (W2MASK,W3MASK,HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE FXWMS2 (W2MASK,HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE FXWMS3 (W2MASK,W3MASK,HVMASK,HFMASK,NEL)
subs2.f:      SUBROUTINE SETCDAT 
subs2.f:      SUBROUTINE EDGINDF (LF1,LF2,LFSKIP,ISD,IFCN)
subs2.f:      SUBROUTINE EDGINDV (LV1,LV2,LVSKIP,ISD)
subs2.f:      SUBROUTINE SETCDOF
subs2.f:      SUBROUTINE AMASK (VB1,VB2,VB3,V1,V2,V3,NEL)
subs2.f:      SUBROUTINE RMASK (R1,R2,R3,NEL)
subs2.f:      SUBROUTINE QMASK (R1,R2,R3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f:      SUBROUTINE FCMSK2 (R1,R2,S1,S2,R1MASK,R2MASK,NEL)
subs2.f:      SUBROUTINE FCMSK3 (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f:      SUBROUTINE EGMASK (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f:      SUBROUTINE CRMSK2 (R1,R2,S1,S2,R1MASK,R2MASK,NEL)
subs2.f:      SUBROUTINE CRMSK3 (R1,R2,R3,S1,S2,S3,R1MASK,R2MASK,R3MASK,NEL)
subs2.f:      subroutine getSnormal(sn,ix,iy,iz,iside,e)
turb.f:      SUBROUTINE SETTURB
turb.f:      SUBROUTINE PRETMIC
turb.f:      SUBROUTINE POSTMIC
turb.f:      SUBROUTINE CBCTURB
turb.f:      SUBROUTINE WHATFLD (IFTURB)
turb.f:      SUBROUTINE TURBFLD (IFKFLD,IFEFLD)
turb.f:      SUBROUTINE TVISCOS
turb.f:      SUBROUTINE TVISCKE 
turb.f:      SUBROUTINE TVISCA
turb.f:      SUBROUTINE TPROPK
turb.f:      SUBROUTINE TPROPE
turb.f:      SUBROUTINE MAKETQ 
turb.f:      SUBROUTINE SETQK
turb.f:      SUBROUTINE SETQE
turb.f:      SUBROUTINE TURBQK
turb.f:      SUBROUTINE TURBQE
turb.f:      SUBROUTINE TURBWBC (TMP,TMA,SMU)
turb.f:      SUBROUTINE FACEWSK (S,IEL,IFC)
turb.f:      SUBROUTINE FACEWSE (S,IEL,IFC)
turb.f:      SUBROUTINE SETTMC
turb.f:      SUBROUTINE COMPHI (PHI)
turb.f:      SUBROUTINE INIPHI (PHI)
turb.f:      SUBROUTINE TWALLUZ (IGEOM)
turb.f:      SUBROUTINE TWALLSH
turb.f:      SUBROUTINE FACEWS (TRX,TRY,TRZ,IEL,IFC)
turb.f:      SUBROUTINE COMWUZ (XWLL,YWLL,ZWLL,V1,V2,V3,VISKIN,VISMIN,IEL,IFC)
turb.f:      SUBROUTINE NORIND (JS3,JF3,JSKIP3,IWX,IWY,IFC,ISCH)
turb.f:      SUBROUTINE CWREF (XWLL,YWLL,ZWLL,UTW,ZNW,VTAN1,VTAN2,VTAN3,
turb.f:      SUBROUTINE COMTDIR (VTAN1,VTAN2,VTAN3,JWX,JWY,IWZ,IEL,IFC)
turb.f:      SUBROUTINE SUBGRID (UTW,ZNW,UW,ZW,ZL,ZU,UL,UU,AKVIS,UST1,IEL,IFC,
turb.f:      SUBROUTINE COMUFR (UST,U,Z,AKVIS,UST1,IEL,IFC,JWX,JWY)
turb.f:      SUBROUTINE COMLSQ
turb.f:      SUBROUTINE LSCALE
turb.f:      SUBROUTINE TLMASK (SMASK)
turb.f:      SUBROUTINE BCDIRTL (TLS,SMS,TMP)
turb.f:      SUBROUTINE FACEWL (S,IEL,IFC)
turb.f:      SUBROUTINE GETVAR (V,VP,RP)
turb.f:      SUBROUTINE INVCHK2 (A,B,N)
turb.f:      SUBROUTINE FACIND2 (JS1,JF1,JSKIP1,JS2,JF2,JSKIP2,IFC)
bdry.f:C     Assign fortran function boundary conditions to 
calcz.f:      function pythag(a,b)
comm_mpi.f:      integer function numnodes()
comm_mpi.f:      integer function mynode()
comm_mpi.f:      real*8 function dnekclock()
comm_mpi.f:      real*8 function dnekclock_sync()
comm_mpi.f:      function isend(msgtag,x,len,jnid,jpid)
comm_mpi.f:      function irecv(msgtag,x,len)
comm_mpi.f:      function igl_running_sum(in)
conduct.f:c     Fill up user defined forcing function and collocate will the
conduct.f:      time = time-dt        ! Set time to t^n-1 for user function
conduct.f:c     Set user specified volumetric forcing function (e.g. heat source).
conduct.f:C     Eulerian scheme, add convection term to forcing function 
conduct.f:c     Eulerian scheme, add diffusion term to forcing function 
connect1.f:      FUNCTION VOLUM0(P1,P2,P3,P0)
connect1.f:      FUNCTION CRSS2D(XY1,XY2,XY0)
connect2.f:C              check for fortran function as denoted by lower case bc's:
connect2.f:C              check for fortran function as denoted by lower case bc's:
connect2.f:C              check for fortran function as denoted by lower case bc's:
cvode_driver.f:c     f denotes the RHS function and is evaluated in fcvfun().
cvode_driver.f:c     Compute RHS function f (allocated within cvode)
dssum.f:c             o note: a binary function pointer flavor exists.
genbox.f:      function ilsum(x,n)
genxyz.f:C     Load parameters for surface function FNC
genxyz.f:C     Given a function FNC and an initial guess (X1,X2), the routine
genxyz.f:      FUNCTION ZBRENT(X1,X2,TOL)
genxyz.f:C     of a function FNC known to lie between X1 and X2.  The root,
genxyz.f:      FUNCTION FNC(ETA)
genxyz.f:      LOGICAL FUNCTION IFVCHK(VEC,I1,I2,I3)
genxyz.f:      REAL FUNCTION DOT(V1,V2,N)
genxyz.f:      function ressrf(x,c,cc)
hmholtz.f:      function vlsc32(r,b,m,n)
ic.f:C     (1) - User specified fortran function (default is zero i.c.)
ic.f:C     Fortran function initial conditions for temp/pass. scalars.
ic.f:C     Fortran function initial conditions for velocity.
ic.f:C     Fortran function initial conditions for turbulence k-e model
ic.f:C     Default is user specified fortran function (=0 if not specified)
ic.f:      function i1_from_char(s1)
ic.f:      integer function indx2(s1,l1,s2,l2)
ic.f:      INTEGER FUNCTION INDX1(S1,S2,L2)
ic.f:      INTEGER FUNCTION INDX_CUT(S1,S2,L2)
ic.f:C     User specified fortran function (=0 if not specified)
ic.f:      LOGICAL FUNCTION IFGTRL(VALUE,LINE)
ic.f:C     This complicated function is necessary thanks to the Ardent,
ic.f:      LOGICAL FUNCTION IFGTIL(IVALUE,LINE)
ic.f:C     This complicated function is necessary thanks to the Ardent,
ic.f:      logical function if_byte_swap_test(bytetest)
induct.f:c     Compute and add: (1) user specified forcing function (FX,FY,FZ)
induct.f:C     Eulerian scheme, add convection term to forcing function
induct.f:C     Eulerian scheme, add convection term to forcing function
makeq.f:C     Generate forcing function for the solution of a passive scalar.
math.f:      real function vlmin(vec,n)
math.f:      integer function ivlmin(vec,n)
math.f:      integer function ivlmax(vec,n)
math.f:      real function vlmax(vec,n)
math.f:      real function vlamax(vec,n)
math.f:      real function vlsum(vec,n)
math.f:C     Map and add to S a tensor product form of the three functions H1,H2,H3.
math.f:      function ltrunc(string,l)
math.f:      function mod1(i,n)
math.f:     $  'WARNING:  Attempt to take MOD(I,0) in function mod1.'
math.f:      integer function log2(k)
math.f:      real function vlsc2(x,y,n)
math.f:      real function vlsc21(x,y,n)
math.f:      function glsc3(a,b,mult,n)
math.f:      function glsc2(x,y,n)
math.f:      function glsc23(x,y,z,n)
math.f:      real function gl2norm(a,n)
math.f:      function glsum (x,n)
math.f:      real function glamax(a,n)
math.f:      real function glamin(a,n)
math.f:      function iglmin(a,n)
math.f:      function iglmax(a,n)
math.f:      function iglsum(a,n)
math.f:      integer*8 function i8glsum(a,n)
math.f:      function glmax(a,n)
math.f:      function glmin(a,n)
math.f:      function fmdian(a,n,ifok)
math.f:      function ivlsum(a,n)
math.f:      integer*8 function i8glmax(a,n)
mpi_dummy.f:      function mpi_wtick ( )
mpi_dummy.f:      function mpi_wtime ( )
navier1.f:C     Compute and add: (1) user specified forcing function (FX,FY,FZ)
navier1.f:C     Compute and add: (1) user specified forcing function (FX,FY,FZ)
navier1.f:C     Eulerian scheme, add convection term to forcing function 
navier4.f:      FUNCTION VLSC3(X,Y,B,N)
navier5.f:      function facint(a,b,area,ifc,ie)
navier5.f:      function facint2(a,b,c,area,ifc,ie)
navier5.f:c     This routing builds a 1D filter with a transfer function that
navier5.f:c     Set up transfer function
navier5.f:      function ran1(idum)
navier7.f:      function mbw_csr(ia,ja,n) 
navier8.f:      logical function iftuple_ialtb(a,b,key,nkey)
navier8.f:      logical function iftuple_altb(a,b,key,nkey)
navier8.f:      logical function iftuple_ianeb(a,b,key,nkey)
pertsupport.f:      function opnormOld(v1,v2,v3,weight)
pertsupport.f:      function opnorm2(v1,v2,v3)
pertsupport.f:      function Tnorm(temp)
pertsupport.f:      function dmnorm(v1,v2,v3,temp)
pertsupport.f:      function pert_inner_prod(i,j) ! weighted inner product vi^T vj
perturb.f:c     Compute and add: (1) user specified forcing function (FX,FY,FZ)
perturb.f:C     Eulerian scheme, add convection term to forcing function
perturb.f:C     Generate forcing function for the solution of a passive scalar.
perturb.f:C     Fill up user defined forcing function and collocate will the
perturb.f:C     Eulerian scheme, add convection term to forcing function 
perturb.f:      function pert_inner_prod(i,j) ! weighted inner product vi^T vj
perturb.f:      function opnorm2(v1,v2,v3)
perturb.f:      function Tnorm(temp)
perturb.f:      function dmnorm(v1,v2,v3,temp)
postpro.f:c     Build 1D-filter based on the transfer function (tf)
postpro.f:c     This routing builds a 1D filter with transfer function diag()
prepost.f:      FUNCTION SUMFC (FF,SM,IFC)
prepost.f:      function i_find_prefix(prefix,imax)
speclib.f:C [2] Abramowitz & Stegun: Handbook of Mathematical Functions,
speclib.f:      REAL*8  FUNCTION ENDW1 (N,ALPHA,BETA)
speclib.f:      REAL*8  FUNCTION ENDW2 (N,ALPHA,BETA)
speclib.f:      REAL*8  FUNCTION GAMMAF (X)
speclib.f:      REAL*8  FUNCTION PNORMJ (N,ALPHA,BETA)
speclib.f:      REAL FUNCTION HGJ (II,Z,ZGJ,NP,ALPHA,BETA)
speclib.f:      REAL*8  FUNCTION HGJD (II,Z,ZGJ,NP,ALPHA,BETA)
speclib.f:      REAL FUNCTION HGLJ (II,Z,ZGLJ,NP,ALPHA,BETA)
speclib.f:      REAL*8  FUNCTION HGLJD (I,Z,ZGLJ,NP,ALPHA,BETA)
speclib.f:      REAL FUNCTION HGLL (I,Z,ZGLL,NZ)
speclib.f:      REAL FUNCTION HGL (I,Z,ZGL,NZ)
speclib.f:      REAL FUNCTION PNLEG (Z,N)
speclib.f:      REAL FUNCTION PNDLEG (Z,N)
subs1.f:      FUNCTION FACDOT(A,B,IFACE1)
subs1.f:C                    2 for fortran function;
subs1.f:C           User specified fortran function   (pff 2/13/01)
subs1.f:C           User specified fortran function
subs1.f:      function surf_mean(u,ifld,bc_in,ierr)
c-----------------------------------------------------------------------
       subroutine q_filter(wght)
c
c     filter vx,vy,vz, and p by simple interpolation
c
       include 'SIZE'
       include 'TOTAL'
c
c
c     These are the dimensions that we interpolate onto for v and p:
       parameter(lxv=lx1-1)
       parameter(lxp=lx2-1)
c
       real intdv(lx1,lx1)
       real intuv(lx1,lx1)
       real intdp(lx1,lx1)
       real intup(lx1,lx1)
       real intv(lx1,lx1)
       real intp(lx1,lx1)
c
       save intdv
       save intuv
       save intdp
       save intup
       save intv
       save intp

       common /ctmp0/ intw,intt
      $             , wk1,wk2
      $             , zgmv,wgtv,zgmp,wgtp,tmax(100),omax(103)

       real intw(lx1,lx1)
       real intt(lx1,lx1)
       real wk1  (lx1,lx1,lx1,lelt)
       real wk2  (lx1,lx1,lx1)
       real zgmv(lx1),wgtv(lx1),zgmp(lx1),wgtp(lx1)
c
c     outpost arrays
       parameter (lt=lx1*ly1*lz1*lelv)
       common /scruz/ w1(lt),w2(lt),w3(lt),wt(lt)

       character*18 sfmt

       integer icalld
       save    icalld
       data    icalld /0/

       logical ifdmpflt
C
       imax = nid
       imax = iglmax(imax,1)
       jmax = iglmax(imax,1)
       if (icalld.eq.0) then
          icalld = 1
          ncut = param(101)+1
          call build_new_filter(intv,zgm1,nx1,ncut,wght,nid)
       elseif (icalld.lt.0) then   ! old (std.) filter
          icalld = 1
          call zwgll(zgmv,wgtv,lxv)
          call igllm(intuv,intw,zgmv,zgm1,lxv,nx1,lxv,nx1)
          call igllm(intdv,intw,zgm1,zgmv,nx1,lxv,nx1,lxv)
c
          call zwgl (zgmp,wgtp,lxp)
          call iglm (intup,intw,zgmp,zgm2,lxp,nx2,lxp,nx2)
          call iglm (intdp,intw,zgm2,zgmp,nx2,lxp,nx2,lxp)
c
c        Multiply up and down interpolation into single operator
c
          call mxm(intup,nx2,intdp,lxp,intp,nx2)
          call mxm(intuv,nx1,intdv,lxv,intv,nx1)
c
c        Weight the filter to make it a smooth (as opposed to truncated)
c        decay in wave space
c
          w0 = 1.-wght
          call ident(intup,nx2)
          call add2sxy(intp,wght,intup,w0,nx2*nx2)
c
          call ident   (intuv,nx1)
          call add2sxy (intv ,wght,intuv,w0,nx1*nx1)
c
c        if (nid.eq.0) call outmatx(intp,nx2,nx2,21,'flt2')
c        if (nid.eq.0) call outmatx(zgm2 ,nx2,1  ,22,'zgm2')
c        if (nid.eq.0) call outmatx(intv,nx1,nx1,11,'flt1')
c        if (nid.eq.0) call outmatx(zgm1 ,nx1,1  ,12,'zgm1')
c
       endif
c
c - - - - - - - - - - - - - - - - - - - - - -
c     Check to see if we should dump U-F(U)
       ifdmpflt = .false.
       if (param(106).ne.0) then
          i106 = param(106)
          if (mod(istep,i106).eq.0) ifdmpflt = .true.
       endif
c
       if (ifdmpflt) then
          call opcopy(w1,w2,w3,vx,vy,vz)
          ntot = nx1*ny1*nz1*nelt
          if (ifheat) call copy(wt,t,ntot)
       endif
c - - - - - - - - - - - - - - - - - - - - - -

       ifldt  = ifield
c     ifield = 1

       if ( (ifflow.and. .not. ifmhd)  .or.
      $     (ifield.eq.1 .and. ifmhd)      ) then
          call filterq(vx,intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
          call filterq(vy,intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
          if (if3d)
      $      call filterq(vz,intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
          if (ifsplit.and..not.iflomach)
      $      call filterq(pr,intv,nx1,nz1,wk1,wk2,intt,if3d,pmax)
       endif
c
       if (ifmhd.and.ifield.eq.ifldmhd) then
          call filterq(bx,intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
          call filterq(by,intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
          if (if3d)
      $   call filterq(bz,intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)
       endif
c
       if (ifpert) then
         do j=1,npert

          ifield = 2
          call filterq(vxp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,umax)
          call filterq(vyp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,vmax)
          if (if3d)
      $   call filterq(vzp(1,j),intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)

          ifield = 1
          if (ifheat .and. .not.ifcvode)
      $   call filterq(tp(1,j,1),intv,nx1,nz1,wk1,wk2,intt,if3d,wmax)

         enddo
       endif
c
       mmax = 0
       if (ifflow) then
c        pmax    = glmax(pmax,1)
          omax(1) = glmax(umax,1)
          omax(2) = glmax(vmax,1)
          omax(3) = glmax(wmax,1)
          mmax = ndim
       endif

c
       nfldt = 1+npscal
       if (ifheat .and. .not.ifcvode) then
          do ifld=1,nfldt
             ifield = ifld + 1
             call filterq(t(1,1,1,1,ifld),intv
      $                  ,nx1,nz1,wk1,wk2,intt,if3d,tmax(ifld))
             mmax = mmax+1
             omax(mmax) = glmax(tmax(ifld),1)
          enddo
       endif

       if (nid.eq.0) then
          if (npscal.eq.0) then
c           write(6,101) mmax
c           write(sfmt,101) mmax
c 101       format('''(i8,1p',i1,'e12.4,a6)''')
c           write(6,sfmt) istep,(omax(k),k=1,mmax),' qfilt'
c         write(6,'(i8,1p4e12.4,a6)') istep,(omax(k),k=1,mmax),' qfilt'
          else
             if (if3d) then
                write(6,1) istep,ifield,umax,vmax,wmax
             else
                write(6,1) istep,ifield,umax,vmax
             endif
     1       format(4x,i7,i3,' qfilt:',1p3e12.4)
             if(ifheat .and. .not.ifcvode)
      &            write(6,'(1p50e12.4)') (tmax(k),k=1,nfldt)
          endif
       endif


c
c - - - - - - - - - - - - - - - - - - - - - -
c     Check to see if we should dump U-F(U)
       if (ifdmpflt) then
          ntot1 = nx1*ny1*nz1*nelv
          ntot2 = nx2*ny2*nz2*nelv
c
          call opsub2(w1,w2,w3,vx,vy,vz)
          call copy  (wk1,pr,ntot2)
          if (ifheat) call sub2(wt,t,ntot1)
c
          call outpost2(w1,w2,w3,wk1,wt,1,'flt')
       endif
c - - - - - - - - - - - - - - - - - - - - - -
c     write(6,*) 'this is wght:',wght,param(103)
c     call exitt
c

       ifield = ifldt   ! RESTORE ifield


       return
       end
c-----------------------------------------------------------------------
       subroutine filterq(v,f,nx,nz,w1,w2,ft,if3d,dmax)
c
       include 'SIZE'
       include 'TSTEP'

       real v(nx*nx*nz,nelt),w1(1),w2(1)
       logical if3d
c
       real f(nx,nx),ft(nx,nx)
c
       integer e
c
       call transpose(ft,nx,f,nx)
c
       nxyz=nx*nx*nz
       dmax = 0.


       nel = nelfld(ifield)


       if (if3d) then
          do e=1,nel
c           Filter
             call copy(w2,v(1,e),nxyz)
             call mxm(f,nx,w2,nx,w1,nx*nx)
             i=1
             j=1
             do k=1,nx
                call mxm(w1(i),nx,ft,nx,w2(j),nx)
                i = i+nx*nx
                j = j+nx*nx
             enddo
             call mxm (w2,nx*nx,ft,nx,w1,nx)
             call sub3(w2,v(1,e),w1,nxyz)
             call copy(v(1,e),w1,nxyz)
             smax = vlamax(w2,nxyz)
             dmax = max(dmax,abs(smax))
          enddo
c
       else
          do e=1,nel
c           Filter
             call copy(w1,v(1,e),nxyz)
             call mxm(f ,nx,w1,nx,w2,nx)
             call mxm(w2,nx,ft,nx,w1,nx)
c
             call sub3(w2,v(1,e),w1,nxyz)
             call copy(v(1,e),w1,nxyz)
             smax = vlamax(w2,nxyz)
             dmax = max(dmax,abs(smax))
          enddo
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine outmatx(a,m,n,io,name)
       real a(m*n)
       character*4 name
c
       open(unit=io,file=name)
       do i=1,m*n
          write(io,1) a(i)
       enddo
     1 format(1p1e22.13)
       close(unit=io)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine drag_calc(scale)
c
       INCLUDE 'SIZE'
       INCLUDE 'TOTAL' 
c
       common /scrns/         pm1(lx1,ly1,lz1,lelv)
      $,vxx(lx1,ly1,lz1,lelv),vxy(lx1,ly1,lz1,lelv),vxz(lx1,ly1,lz1,lelv)
      $,vyx(lx1,ly1,lz1,lelv),vyy(lx1,ly1,lz1,lelv),vyz(lx1,ly1,lz1,lelv)
       common /scruz/
      $ vzx(lx1,ly1,lz1,lelv),vzy(lx1,ly1,lz1,lelv),vzz(lx1,ly1,lz1,lelv)
      $,one(lx1,ly1,lz1,lelv)
        real work(1)
        equivalence (work,one)
c
       common /cdrag/ dragx(0:maxobj),dragy(0:maxobj),dragz(0:maxobj)
      $             ,  momx(0:maxobj), momy(0:maxobj), momz(0:maxobj)
      $             ,  dpdx_mean,dpdy_mean,dpdz_mean
       real momx ,momy ,momz
c
       common /tdrag/ drag(11)
       real dragpx,dragpy,dragpz,dragvx,dragvy,dragvz
       real momvx ,momvy ,momvz
       real check1,check2
c
       equivalence (dragpx,drag(1)),(dragpy,drag(2)),(dragpz,drag(3))
       equivalence (dragvx,drag(4)),(dragvy,drag(5)),(dragvz,drag(6))
       equivalence (momvx ,drag(7)),(momvy ,drag(8)),(momvz ,drag(9))
       equivalence (check1,drag(10)),(check2,drag(11))

       common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
      $                , scale_vf(3)

       ntot1  = nx1*ny1*nz1*nelv

c    Map pressure onto mesh 1   (vxx and vyy are used as work arrays)
       call mappr(pm1,pr,vxx,vyy)
       call rone (one,ntot1)
c
c    Add mean_pressure_gradient.X to p:

       if (param(55).ne.0) then
          dpdx_mean = -scale_vf(1)
          dpdy_mean = -scale_vf(2)
          dpdz_mean = -scale_vf(3)
       endif

       call add2s2(pm1,xm1,dpdx_mean,ntot1)  ! Doesn't work if object is cut by
       call add2s2(pm1,ym1,dpdy_mean,ntot1)  ! periodicboundary.  In this case,
       call add2s2(pm1,zm1,dpdz_mean,ntot1)  ! set ._mean=0 and compensate in
c                                           ! usrchk()  [ pff 10/21/04 ].

c    Compute du/dn
                 CALL DUDXYZ (vxx,vx,RXM1,SXM1,TXM1,JACM1,1,1)
                 CALL DUDXYZ (vxy,vx,RYM1,SYM1,TYM1,JACM1,1,1)
       if (if3d) CALL DUDXYZ (vxz,vx,RZM1,SZM1,TZM1,JACM1,1,1)
c
                 CALL DUDXYZ (vyx,vy,RXM1,SXM1,TXM1,JACM1,1,1)
                 CALL DUDXYZ (vyy,vy,RYM1,SYM1,TYM1,JACM1,1,1)
       if (if3d) CALL DUDXYZ (vyz,vy,RZM1,SZM1,TZM1,JACM1,1,1)
c
       if (if3d) then
                 CALL DUDXYZ (vzx,vz,RXM1,SXM1,TXM1,JACM1,1,1)
                 CALL DUDXYZ (vzy,vz,RYM1,SYM1,TYM1,JACM1,1,1)
                 CALL DUDXYZ (vzz,vz,RZM1,SZM1,TZM1,JACM1,1,1)
       endif
c
c     Fill up viscous array w/ default
c
       if (istep.lt.1) call cfill(vdiff,param(2),ntot1)
c
       call col2(vxx,vdiff,ntot1)
       call col2(vxy,vdiff,ntot1)
       call col2(vxz,vdiff,ntot1)
       call col2(vyx,vdiff,ntot1)
       call col2(vyy,vdiff,ntot1)
       call col2(vyz,vdiff,ntot1)
       call col2(vzx,vdiff,ntot1)
       call col2(vzy,vdiff,ntot1)
       call col2(vzz,vdiff,ntot1)
c
       dragxt=0.0
       dragyt=0.0
       dragzt=0.0
c
       DO 100 II=1,NHIS
          IF (HCODE(10,II).NE.'I') GOTO 100
          IOBJ   = LOCHIS(1,II)
          MEMTOT = NMEMBER(IOBJ)
C
c
          IF (HCODE(1,II).NE.' ' .OR. HCODE(2,II).NE.' ' .OR.
      $       HCODE(3,II).NE.' ' ) THEN
             IFIELD = 1
c
c---------------------------------------------------------------------------
c           Compute drag for this object
c---------------------------------------------------------------------------
c
             dragvx=0.0
             dragvy=0.0
             dragvz=0.0
             dragpx=0.0
             dragpy=0.0
             dragpz=0.0
c
             momvx=0.0
             momvy=0.0
             momvz=0.0
c
             check1=0.0
             check2=0.0
             DO 50 MEM=1,MEMTOT
                ISK   = 0
                IEG   = OBJECT(IOBJ,MEM,1)
                IFC   = OBJECT(IOBJ,MEM,2)
                IF (GLLNID(IEG).EQ.NID) THEN
C                 This processor has a contribution
                   IE = GLLEL(IEG)
c
c                 Pressure drag
                   check1=check1+facint(one,one,area,ifc,ie)
                   check2=check2+facint(one,uny,area,ifc,ie)
c
                   dragpx=dragpx+facint(pm1,unx,area,ifc,ie)
                   dragpy=dragpy+facint(pm1,uny,area,ifc,ie)
                   if (if3d) dragpz=dragpz+facint(pm1,unz,area,ifc,ie)
c
c                 Viscous drag
                   if (if3d) then
                      dragvx=dragvx+facint(vxx,unx,area,ifc,ie)
      $                            +facint(vxy,uny,area,ifc,ie)
      $                            +facint(vxz,unz,area,ifc,ie)
      $                            +facint(vxx,unx,area,ifc,ie)
      $                            +facint(vyx,uny,area,ifc,ie)
      $                            +facint(vzx,unz,area,ifc,ie)
                      dragvy=dragvy+facint(vyx,unx,area,ifc,ie)
      $                            +facint(vyy,uny,area,ifc,ie)
      $                            +facint(vyz,unz,area,ifc,ie)
      $                            +facint(vxy,unx,area,ifc,ie)
      $                            +facint(vyy,uny,area,ifc,ie)
      $                            +facint(vzy,unz,area,ifc,ie)
                      dragvz=dragvz+facint(vzx,unx,area,ifc,ie)
      $                            +facint(vzy,uny,area,ifc,ie)
      $                            +facint(vzz,unz,area,ifc,ie)
      $                            +facint(vxz,unx,area,ifc,ie)
      $                            +facint(vyz,uny,area,ifc,ie)
      $                            +facint(vzz,unz,area,ifc,ie)
c
                      momvx=momvx-facint2(vxy,unx,unz,area,ifc,ie)
      $                        -facint2(vyx,unx,unz,area,ifc,ie)
      $                        -facint2(vyy,uny,unz,area,ifc,ie)
      $                        -facint2(vyy,uny,unz,area,ifc,ie)
      $                        -facint2(vzy,unz,unz,area,ifc,ie)
      $                        -facint2(vyz,unz,unz,area,ifc,ie)
      $                        +facint2(vxz,unx,uny,area,ifc,ie)
      $                        +facint2(vzx,unx,uny,area,ifc,ie)
      $                        +facint2(vyz,uny,uny,area,ifc,ie)
      $                        +facint2(vzy,uny,uny,area,ifc,ie)
      $                        +facint2(vzz,unz,uny,area,ifc,ie)
      $                        +facint2(vzz,unz,uny,area,ifc,ie)
                      momvy=momvy+facint2(vxx,unx,unz,area,ifc,ie)
      $                        +facint2(vxx,unx,unz,area,ifc,ie)
      $                        +facint2(vyx,uny,unz,area,ifc,ie)
      $                        +facint2(vxy,uny,unz,area,ifc,ie)
      $                        +facint2(vzx,unz,unz,area,ifc,ie)
      $                        +facint2(vxz,unz,unz,area,ifc,ie)
      $                        -facint2(vxz,unx,unx,area,ifc,ie)
      $                        -facint2(vzx,unx,unx,area,ifc,ie)
      $                        -facint2(vyz,uny,unx,area,ifc,ie)
      $                        -facint2(vzy,uny,unx,area,ifc,ie)
      $                        -facint2(vzz,unz,unx,area,ifc,ie)
      $                        -facint2(vzz,unz,unx,area,ifc,ie)
                      momvz=momvz-facint2(vxx,unx,uny,area,ifc,ie)
      $                        -facint2(vxx,unx,uny,area,ifc,ie)
      $                        -facint2(vyx,uny,uny,area,ifc,ie)
      $                        -facint2(vxy,uny,uny,area,ifc,ie)
      $                        -facint2(vzx,unz,uny,area,ifc,ie)
      $                        -facint2(vxz,unz,uny,area,ifc,ie)
      $                        +facint2(vxy,unx,unx,area,ifc,ie)
      $                        +facint2(vyx,unx,unx,area,ifc,ie)
      $                        +facint2(vyy,uny,unx,area,ifc,ie)
      $                        +facint2(vyy,uny,unx,area,ifc,ie)
      $                        +facint2(vzy,unz,unx,area,ifc,ie)
      $                        +facint2(vyz,unz,unx,area,ifc,ie) 
c
                   else
                      dragvx=dragvx+facint(vxx,unx,area,ifc,ie)
      $                            +facint(vxy,uny,area,ifc,ie)
                      dragvy=dragvy+facint(vyx,unx,area,ifc,ie)
      $                            +facint(vyy,uny,area,ifc,ie)
                   endif
                ENDIF
    50       CONTINUE
c
c          Sum contributions from all processors
             call gop(drag,work,'+  ',11)
             dragvx = -dragvx
             dragvy = -dragvy
             dragvz = -dragvz
          ENDIF
c
c        Scale by user specified scale factor (for convenience)
c
          dragvx = scale*dragvx
          dragvy = scale*dragvy
          dragvz = scale*dragvz
c
          dragpx = scale*dragpx
          dragpy = scale*dragpy
          dragpz = scale*dragpz
c
          dragx(iobj) = dragvx+dragpx
          dragy(iobj) = dragvy+dragpy
          dragz(iobj) = dragvz+dragpz
c
c
          momx(iobj)  = 0.5*momvx
          momy(iobj)  = 0.5*momvy
          momz(iobj)  = 0.5*momvz
c
          dragxt = dragxt + dragx(iobj)
          dragyt = dragyt + dragy(iobj)
          dragzt = dragzt + dragz(iobj)
c
          if (nid.eq.0.and.istep.eq.1)
      $      write(6,*) 'drag_calc: scale=',scale
          if (nid.eq.0) then
             write(6,6) istep,time,dragx(iobj),dragpx,dragvx,'dragx',iobj
             write(6,6) istep,time,dragy(iobj),dragpy,dragvy,'dragy',iobj
             if (if3d)
      $      write(6,6) istep,time,dragz(iobj),dragpz,dragvz,'dragz',iobj
c
c done by zly (3/17/03)
c          if(if3d) then
c             write(6,113) istep,time,momx,momy,momz
c          else
c             write(6,112) istep,time,momx,momy
c          endif
c
          endif
     6    format(i8,1p4e15.7,2x,a5,i5)
   112    format(i6,1p3e15.7,'  momx')
   113    format(i6,1p4e15.7,'  momx')
          if (istep.lt.10.and.nid.eq.0)
      $      write(6,9) 'check:',check1,check2,dpdx_mean,istep
     9    format(a6,1p3e16.8,i9)
c        if (time.gt.1.0.and.dragx.gt.10.) call emerxit
   100 continue
c
       if (nid.eq.0) then
          write(6,6) istep,time,dragxt,dragpx,dragvx,'drgxt',iobj
          write(6,6) istep,time,dragyt,dragpy,dragvy,'drgyt',iobj
          if (if3d)
      $   write(6,6) istep,time,dragzt,dragpz,dragvz,'drgzt',iobj
       endif
c
       dragx(0) = dragxt
       dragy(0) = dragyt
       dragz(0) = dragzt
c
       return
       end
c-----------------------------------------------------------------------
       subroutine mappr(pm1,pm2,pa,pb)
c
       INCLUDE 'SIZE'
       INCLUDE 'TOTAL'
       real pm1(lx1,ly1,lz1,lelv),pm2(lx2,ly2,lz2,lelv)
      $    ,pa (lx1,ly2,lz2)     ,pb (lx1,ly1,lz2)
c
C     Map the pressure onto the velocity mesh
C
       NGLOB1 = NX1*NY1*NZ1*NELV
       NYZ2   = NY2*NZ2
       NXY1   = NX1*NY1
       NXYZ   = NX1*NY1*NZ1
C
       IF (IFSPLIT) THEN
          CALL COPY(PM1,PM2,NGLOB1)
       ELSE
          DO 1000 IEL=1,NELV
             CALL MXM (IXM21,NX1,PM2(1,1,1,IEL),NX2,pa (1,1,1),NYZ2)
             DO 100 IZ=1,NZ2
                CALL MXM (PA(1,1,IZ),NX1,IYTM21,NY2,PB(1,1,IZ),NY1)
  100        CONTINUE
             CALL MXM (PB(1,1,1),NXY1,IZTM21,NZ2,PM1(1,1,1,IEL),NZ1)
  1000    CONTINUE

C     Average the pressure on elemental boundaries
        IFIELD=1
        CALL DSSUM (PM1,NX1,NY1,NZ1)
        CALL COL2  (PM1,VMULT,NGLOB1)

       ENDIF
C
C
       return
       end
c
c-----------------------------------------------------------------------
       function facint(a,b,area,ifc,ie)
c
C
C     Take the dot product of A and B on the surface IFACE1 of element IE.
C
C         IFACE1 is in the preprocessor notation
C         IFACE  is the dssum notation.
C         5 Jan 1989 15:12:22      PFF
C
       INCLUDE 'SIZE'
       INCLUDE 'TOPOL'
       DIMENSION A    (LX1,LY1,LZ1,lelv)
      $         ,B    (lx1,lz1,6,lelv)
      $         ,area (lx1,lz1,6,lelv)
C
C     Set up counters
C
       CALL DSSET(NX1,NY1,NZ1)
       IFACE  = EFACE1(IFC)
       JS1    = SKPDAT(1,IFACE)
       JF1    = SKPDAT(2,IFACE)
       JSKIP1 = SKPDAT(3,IFACE)
       JS2    = SKPDAT(4,IFACE)
       JF2    = SKPDAT(5,IFACE)
       JSKIP2 = SKPDAT(6,IFACE)
C
       SUM=0.0
       I = 0
       DO 100 J2=JS2,JF2,JSKIP2
       DO 100 J1=JS1,JF1,JSKIP1
          I = I+1
          SUM = SUM + A(J1,J2,1,ie)*B(I,1,ifc,ie)*area(I,1,ifc,ie)
c        SUM = SUM + A(J1,J2,1,ie)*B(J1,J2,1,ie)*area(I,1,ifc,ie)
   100 CONTINUE
C
       facint = SUM
c
       return
       end
c-----------------------------------------------------------------------
       function facint2(a,b,c,area,ifc,ie)
       include 'SIZE'
       include 'TOPOL'
       dimension a    (lx1,ly1,lz1,lelv)
      $        , b    (lx1,lz1,6,lelv)
      $        , c    (lx1,lz1,6,lelv)
      $        , area (lx1,lz1,6,lelv)
       call dsset(nx1,ny1,nz1)
       iface  = eface1(ifc)
       js1    = skpdat(1,iface)
       jf1    = skpdat(2,iface)
       jskip1 = skpdat(3,iface)
       js2    = skpdat(4,iface)
       jf2    = skpdat(5,iface)
       jskip2 = skpdat(6,iface)
       sum=0.0
       i=0
       do j2=js2,jf2,jskip2
       do j1=js1,jf1,jskip1
          i=i+1
          sum=sum+a(j1,j2,1,ie)*b(i,1,ifc,ie)*c(i,1,ifc,ie)
      $          *area(i,1,ifc,ie)
       end do
       end do
       facint2=sum
       return
       end 
c-----------------------------------------------------------------------
       subroutine out_csrmats(acsr,ia,ja,n,name9)
       real    acsr(1)
       integer ia(1),ja(1)
c
       character*9 name9
       character*9 s(16)
c
       nnz = ia(n+1)-ia(1)
c
       write(6,1) name9,n,nnz
     1 format(/,'CSR Mat:',a9,3x,'n =',i5,3x,'nnz =',i5,/)
c
       n16 = min(n,16)
       n29 = min(n,29)
       do i=1,n29
          call blank(s,9*16)
          n1 = ia(i)
          n2 = ia(i+1)-1
          do jj=n1,n2
             j = ja  (jj)
             a = acsr(jj)
             if (a.ne.0..and.j.le.n16) write(s(j),9) a
          enddo
          write(6,16) (s(k),k=1,n16)
       enddo
     9 format(f9.4)
    16 format(16a9)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine local_grad3(ur,us,ut,u,N,e,D,Dt)
c     Output: ur,us,ut         Input:u,N,e,D,Dt
       real ur(0:N,0:N,0:N),us(0:N,0:N,0:N),ut(0:N,0:N,0:N)
       real u (0:N,0:N,0:N,1)
       real D (0:N,0:N),Dt(0:N,0:N)
       integer e
c
       m1 = N+1
       m2 = m1*m1
c
       call mxm(D ,m1,u(0,0,0,e),m1,ur,m2)
       do k=0,N
          call mxm(u(0,0,k,e),m1,Dt,m1,us(0,0,k),m1)
       enddo
       call mxm(u(0,0,0,e),m2,Dt,m1,ut,m1)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine local_grad2(ur,us,u,N,e,D,Dt)
c     Output: ur,us         Input:u,N,e,D,Dt
       real ur(0:N,0:N),us(0:N,0:N)
       real u (0:N,0:N,1)
       real D (0:N,0:N),Dt(0:N,0:N)
       integer e
c
       m1 = N+1
c
       call mxm(D ,m1,u(0,0,e),m1,ur,m1)
       call mxm(u(0,0,e),m1,Dt,m1,us,m1)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine gradm1(ux,uy,uz,u)
c
c     Compute gradient of T -- mesh 1 to mesh 1 (vel. to vel.)
c
       include 'SIZE'
       include 'DXYZ'
       include 'GEOM'
       include 'INPUT'
       include 'TSTEP'
c
       parameter (lxyz=lx1*ly1*lz1)
       real ux(lxyz,1),uy(lxyz,1),uz(lxyz,1),u(lxyz,1)

       common /ctmp1/ ur(lxyz),us(lxyz),ut(lxyz)

       integer e

       nxyz = nx1*ny1*nz1
       ntot = nxyz*nelt

       N = nx1-1
       do e=1,nelt
          if (if3d) then
             call local_grad3(ur,us,ut,u,N,e,dxm1,dxtm1)
             do i=1,lxyz
                ux(i,e) = jacmi(i,e)*(ur(i)*rxm1(i,1,1,e)
      $                             + us(i)*sxm1(i,1,1,e)
      $                             + ut(i)*txm1(i,1,1,e) )
                uy(i,e) = jacmi(i,e)*(ur(i)*rym1(i,1,1,e)
      $                             + us(i)*sym1(i,1,1,e)
      $                             + ut(i)*tym1(i,1,1,e) )
                uz(i,e) = jacmi(i,e)*(ur(i)*rzm1(i,1,1,e)
      $                             + us(i)*szm1(i,1,1,e)
      $                             + ut(i)*tzm1(i,1,1,e) )
             enddo
          else
             if (ifaxis) call setaxdy (ifrzer(e))
             call local_grad2(ur,us,u,N,e,dxm1,dytm1)
             do i=1,lxyz
                ux(i,e) =jacmi(i,e)*(ur(i)*rxm1(i,1,1,e)
      $                            + us(i)*sxm1(i,1,1,e) )
                uy(i,e) =jacmi(i,e)*(ur(i)*rym1(i,1,1,e)
      $                            + us(i)*sym1(i,1,1,e) )
             enddo
          endif
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine outpost(v1,v2,v3,vp,vt,name3)
       real v1(1),v2(1),v3(1),vp(1),vt(1)
       character*3 name3

       call outpost2(v1,v2,v3,vp,vt,1,name3)

       return
       end
c-----------------------------------------------------------------------
       subroutine outpost2(v1,v2,v3,vp,vt,nfldt,name3)

       include 'SIZE'
       include 'SOLN'
       include 'INPUT'

       parameter(ltot1=lx1*ly1*lz1*lelt)
       parameter(ltot2=lx2*ly2*lz2*lelv)
       common /outtmp/  w1(ltot1),w2(ltot1),w3(ltot1),wp(ltot2)
      &                ,wt(ltot1,ldimt)
c
       real v1(1),v2(1),v3(1),vp(1),vt(ltot1,1)
       character*3 name3
       logical if_save(ldimt)
c
       ntot1  = nx1*ny1*nz1*nelv
       ntot1t = nx1*ny1*nz1*nelt
       ntot2  = nx2*ny2*nz2*nelv

       if(nfldt.gt.ldimt) then
         write(6,*) 'ABORT: outpost data too large (nfldt>ldimt)!'
         call exitt
       endif

c store solution
       call copy(w1,vx,ntot1)
       call copy(w2,vy,ntot1)
       call copy(w3,vz,ntot1)
       call copy(wp,pr,ntot2)
       do i = 1,nfldt
          call copy(wt(1,i),t(1,1,1,1,i),ntot1t)
       enddo

c swap with data to dump
       call copy(vx,v1,ntot1)
       call copy(vy,v2,ntot1)
       call copy(vz,v3,ntot1)
       call copy(pr,vp,ntot2)
       do i = 1,nfldt
          call copy(t(1,1,1,1,i),vt(1,i),ntot1t)
       enddo

c dump data
       if_save(1) = ifto
       ifto = .false.
       if(nfldt.gt.0) ifto = .true.
       do i = 1,ldimt-1
          if_save(i+1) = ifpsco(i)
          ifpsco(i) = .false.
          if(i+1.le.nfldt) ifpsco(i) = .true.
       enddo

       if (nid.eq.0) write(6,*) 'calling prepost ',name3, nfldt
       call prepost(.true.,name3)

       ifto = if_save(1)
       do i = 1,ldimt-1
          ifpsco(i) = if_save(i+1)
       enddo

c restore solution data
       call copy(vx,w1,ntot1)
       call copy(vy,w2,ntot1)
       call copy(vz,w3,ntot1)
       call copy(pr,wp,ntot2)
       do i = 1,nfldt
          call copy(t(1,1,1,1,i),wt(1,i),ntot1t)
       enddo

       return
       end
c-----------------------------------------------------------------------
       subroutine comp_vort3(vort,work1,work2,u,v,w)
c
       include 'SIZE'
       include 'TOTAL'
c
       parameter(lt=lx1*ly1*lz1*lelv)
       real vort(lt,3),work1(1),work2(1),u(1),v(1),w(1)
c
       ntot  = nx1*ny1*nz1*nelv
       if (if3d) then
c        work1=dw/dy ; work2=dv/dz
            call dudxyz(work1,w,rym1,sym1,tym1,jacm1,1,2)
            call dudxyz(work2,v,rzm1,szm1,tzm1,jacm1,1,3)
            call sub3(vort(1,1),work1,work2,ntot)
c        work1=du/dz ; work2=dw/dx
            call dudxyz(work1,u,rzm1,szm1,tzm1,jacm1,1,3)
            call dudxyz(work2,w,rxm1,sxm1,txm1,jacm1,1,1)
            call sub3(vort(1,2),work1,work2,ntot)
c        work1=dv/dx ; work2=du/dy
            call dudxyz(work1,v,rxm1,sxm1,txm1,jacm1,1,1)
            call dudxyz(work2,u,rym1,sym1,tym1,jacm1,1,2)
            call sub3(vort(1,3),work1,work2,ntot)
       else
c        work1=dv/dx ; work2=du/dy
            call dudxyz(work1,v,rxm1,sxm1,txm1,jacm1,1,1)
            call dudxyz(work2,u,rym1,sym1,tym1,jacm1,1,2)
            call sub3(vort,work1,work2,ntot)
       endif
c
c    Avg at bndry
c
       ifielt = ifield
       ifield = 1
       if (if3d) then
          do idim=1,ndim
             call col2  (vort(1,idim),bm1,ntot)
             call dssum (vort(1,idim),nx1,ny1,nz1)
             call col2  (vort(1,idim),binvm1,ntot)
          enddo
       else
          call col2  (vort,bm1,ntot)
          call dssum (vort,nx1,ny1,nz1)
          call col2  (vort,binvm1,ntot)
       endif
       ifield = ifielt
c
       return
       end
c-----------------------------------------------------------------------
       subroutine surface_int(sint,sarea,a,ie,iface1)
C
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'TOPOL'
       real a(lx1,ly1,lz1,1)
c
       integer icalld
       save    icalld
       data    icalld/0/
       logical ifpf
       save    ifpf
c
       if (icalld.eq.0) then
          icalld=icalld+1
          if (skpdat(1,2).eq.nx1) then
c           write(6,*) 'In surface_int, using pf version of skpdat.'
             ifpf = .true.
          else
c           write(6,*) 'In surface_int, using std version of skpdat.'
             ifpf = .false.
          endif
       endif
C
       sarea = 0.
       sint  = 0.
C
       call dsset(nx1,ny1,nz1)
       iface  = eface1(iface1)
c
c     Check skpdat (because of difference in pf vs. commercial version...arrghh)
c
       if (ifpf) then
c        pf version
          js1    = skpdat(1,iface)
          jf1    = skpdat(2,iface)
          jskip1 = skpdat(3,iface)
          js2    = skpdat(4,iface)
          jf2    = skpdat(5,iface)
          jskip2 = skpdat(6,iface)
       else
c        std version
          js1    = skpdat(iface,1)
          jf1    = skpdat(iface,2)
          jskip1 = skpdat(iface,3)
          js2    = skpdat(iface,4)
          jf2    = skpdat(iface,5)
          jskip2 = skpdat(iface,6)
       endif
C
       I = 0
       do 100 j2=js2,jf2,jskip2
       do 100 j1=js1,jf1,jskip1
          I = I+1
          sarea = sarea+area(i,1,iface1,ie)
          sint  = sint +area(i,1,iface1,ie)*a(j1,j2,1,ie)
   100 continue
C
       return
       end
c-----------------------------------------------------------------------
       subroutine surface_flux(dq,qx,qy,qz,ie,iface,w)
C
       include 'SIZE'
       include 'GEOM'
       include 'INPUT'
       include 'PARALLEL'
       include 'TOPOL'
       parameter (l=lx1*ly1*lz1)
       real w(lx1,ly1,lz1),qx(l,1),qy(l,1),qz(l,1)
c
       integer icalld
       save    icalld
       data    icalld/0/
       logical ifpf
       save    ifpf
c
       call dsset(nx1,ny1,nz1)
       if (icalld.eq.0) then
          icalld=icalld+1
          if (skpdat(1,2).eq.nx1) then
             write(6,*) 'In surface_flux, using pf version of skpdat.'
             ifpf = .true.
          else
             write(6,*) 'In surface_flux, using std version of skpdat.'
             ifpf = .false.
          endif
       endif
C
       ifacepf  = eface1(iface)
c
c     Check skpdat (because of difference in pf vs. commercial version...arrghh)
c
       if (ifpf) then
c        pf version
          js1    = skpdat(1,ifacepf)
          jf1    = skpdat(2,ifacepf)
          jskip1 = skpdat(3,ifacepf)
          js2    = skpdat(4,ifacepf)
          jf2    = skpdat(5,ifacepf)
          jskip2 = skpdat(6,ifacepf)
       else
c        std version
          js1    = skpdat(ifacepf,1)
          jf1    = skpdat(ifacepf,2)
          jskip1 = skpdat(ifacepf,3)
          js2    = skpdat(ifacepf,4)
          jf2    = skpdat(ifacepf,5)
          jskip2 = skpdat(ifacepf,6)
       endif
C
       call faccl3 (w,qx(1,ie),unx(1,1,iface,ie),iface)
       call faddcl3(w,qy(1,ie),uny(1,1,iface,ie),iface)
       if (if3d)
      $call faddcl3(w,qz(1,ie),unz(1,1,iface,ie),iface)
c
       dq = 0
       i  = 0
       do 100 j2=js2,jf2,jskip2
       do 100 j1=js1,jf1,jskip1
          i = i+1
          dq    = dq   +area(i,1,iface,ie)*w(j1,j2,1)
   100 continue
C
       return
       end
c-----------------------------------------------------------------------
       subroutine gaujordf(a,m,n,indr,indc,ipiv,ierr,rmult)
C
C     Gauss-Jordan matrix inversion with full pivoting
c
c     Num. Rec. p. 30, 2nd Ed., Fortran
c
C
C     a     is an m x n matrix
C     rmult is a  work array of dimension m
C
c
       real a(m,n),rmult(m)
       integer indr(m),indc(n),ipiv(n)

c     call outmat(a,m,n,'ab4',n)
c     do i=1,m
c        write(6,1) (a(i,j),j=1,n)
c     enddo
c 1   format('mat: ',1p6e12.4)

       ierr = 0
       eps = 1.e-9
       call izero(ipiv,m)

       do k=1,m
          amx=0.
          do i=1,m                    ! Pivot search
             if (ipiv(i).ne.1) then
                do j=1,m
                   if (ipiv(j).eq.0) then
                     if (abs(a(i,j)).ge.amx) then
                        amx = abs(a(i,j))
                        ir  = i
                        jc  = j
                     endif
                  elseif (ipiv(j).gt.1) then
                     ierr = -ipiv(j)
                     return
                  endif
               enddo
            endif
         enddo
         ipiv(jc) = ipiv(jc) + 1
c
c       Swap rows
         if (ir.ne.jc) then
            do j=1,n
               tmp     = a(ir,j)
               a(ir,j) = a(jc,j)
               a(jc,j) = tmp
            enddo
         endif
         indr(k)=ir
         indc(k)=jc
c       write(6 ,*) k,' Piv:',jc,a(jc,jc)
c       write(28,*) k,' Piv:',jc,a(jc,jc)
         if (abs(a(jc,jc)).lt.eps) then
            write(6 ,*) 'small Gauss Jordan Piv:',jc,a(jc,jc)
            write(28,*) 'small Gauss Jordan Piv:',jc,a(jc,jc)
            ierr = jc
            call exitt
            return
         endif
         piv = 1./a(jc,jc)
         a(jc,jc)=1.
         do j=1,n
            a(jc,j) = a(jc,j)*piv
         enddo
c
         do j=1,n
            work    = a(jc,j)
            a(jc,j) = a(1 ,j)
            a(1 ,j) = work
         enddo
         do i=2,m
            rmult(i) = a(i,jc)
            a(i,jc)  = 0.
         enddo
c
         do j=1,n
         do i=2,m
            a(i,j) = a(i,j) - rmult(i)*a(1,j)
         enddo
         enddo
c
         do j=1,n
            work    = a(jc,j)
            a(jc,j) = a(1 ,j)
            a(1 ,j) = work
         enddo
c
c       do i=1,m
c          if (i.ne.jc) then
c             rmult   = a(i,jc)
c             a(i,jc) = 0.
c             do j=1,n
c                a(i,j) = a(i,j) - rmult*a(jc,j)
c             enddo
c          endif
c       enddo
c
       enddo
c
c     Unscramble matrix
       do j=m,1,-1
          if (indr(j).ne.indc(j)) then
             do i=1,m
                tmp=a(i,indr(j))
                a(i,indr(j))=a(i,indc(j))
                a(i,indc(j))=tmp
             enddo
          endif
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine legendre_poly(L,x,N)
c
c     Evaluate Legendre polynomials of degrees 0-N at point x
c
       real L(0:N)
c
       L(0) = 1.
       L(1) = x
c
       do j=2,N
          L(j) = ( (2*j-1) * x * L(j-1) - (j-1) * L(j-2) ) / j
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine build_new_filter(intv,zpts,nx,kut,wght,nid)
c
c     This routing builds a 1D filter with a transfer function that
c     looks like:
c
c
c        ^
c    d_k |
c        |                 |
c     1  |__________      _v_
c        |          -_ 
c        |            \  wght
c        |             \  ___
c        |             |   ^
c     0  |-------------|---|>
c
c        0         c   N   k-->
c
c        Where c := N-kut is the point below which d_k = 1.
c
c
c
c      Here, nx = number of points
c
       real intv(nx,nx),zpts(nx)
c
       parameter (lm=40)
       parameter (lm2=lm*lm)
       real      phi(lm2),pht(lm2),diag(lm2),rmult(lm),Lj(lm)
       integer   indr(lm),indc(lm),ipiv(lm)
c
       if (nx.gt.lm) then
          write(6,*) 'ABORT in build_new_filter:',nx,lm
          call exitt
       endif
c
       kj = 0
       n  = nx-1
       do j=1,nx
          z = zpts(j)
          call legendre_poly(Lj,z,n)
          kj = kj+1
          pht(kj) = Lj(1)
          kj = kj+1
          pht(kj) = Lj(2)
          do k=3,nx
             kj = kj+1
             pht(kj) = Lj(k)-Lj(k-2)
          enddo
       enddo
       call transpose (phi,nx,pht,nx)
       call copy      (pht,phi,nx*nx)
       call gaujordf  (pht,nx,nx,indr,indc,ipiv,ierr,rmult)
c
c     Set up transfer function
c
       call ident   (diag,nx)
c
       k0 = nx-kut
       do k=k0+1,nx
          kk = k+nx*(k-1)
          amp = wght*(k-k0)*(k-k0)/(kut*kut)   ! quadratic growth
          diag(kk) = 1.-amp
       enddo
c
       call mxm  (diag,nx,pht,nx,intv,nx)      !          -1
       call mxm  (phi ,nx,intv,nx,pht,nx)      !     V D V
       call copy (intv,pht,nx*nx)
c
       do k=1,nx*nx
          pht(k) = 1.-diag(k)
       enddo
       np1 = nx+1
       if (nid.eq.0) then
          write(6,6) 'filt amp',(pht (k),k=1,nx*nx,np1)
          write(6,6) 'filt trn',(diag(k),k=1,nx*nx,np1)
    6     format(a8,16f7.4,6(/,8x,16f7.4))
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine avg_all
c
c     This routine computes running averages E(X),E(X^2),E(X*Y)
c     and outputs to avg*.fld*, rms*.fld*, and rm2*.fld* for all
c     fields.
c
c     E denotes the expected value operator and X,Y two
c     real valued random variables.
c
c     variances and covariances can be computed in a post-processing step:
c
c        var(X)   := E(X^X) - E(X)*E(X) 
c        cov(X,Y) := E(X*Y) - E(X)*E(Y) 
c
c     Note: The E-operator is linear, in the sense that the expected
c           value is given by E(X) = 1/N * sum[ E(X)_i ], where E(X)_i
c           is the expected value of the sub-ensemble i (i=1...N).
c
       include 'SIZE'
       include 'TOTAL'
       include 'AVG'

       logical ifverbose
       integer icalld
       save    icalld
       data    icalld  /0/

       if (ax1.ne.lx1 .or. ay1.ne.ly1 .or. az1.ne.lz1) then
          if(nid.eq.0) write(6,*)
      $     'ABORT: wrong size of ax1,ay1,az1 in avg_all(), check SIZEu!'
          call exitt
       endif
       if (ax2.ne.lx2 .or. ay2.ne.ay2 .or. az2.ne.lz2) then
          if(nid.eq.0) write(6,*)
      $     'ABORT: wrong size of ax2,ay2,az2 in avg_all(), check SIZEu!'
          call exitt
       endif

       ntot  = nx1*ny1*nz1*nelv
       ntott = nx1*ny1*nz1*nelt
       nto2  = nx2*ny2*nz2*nelv

       ! initialization
       if (icalld.eq.0) then
          icalld = icalld + 1
          atime  = 0.
          timel  = time

          call rzero(uavg,ntot)
          call rzero(vavg,ntot)
          call rzero(wavg,ntot)
          call rzero(pavg,nto2)
          do i = 1,ldimt
             call rzero(tavg(1,1,1,1,i),ntott)
          enddo

          call rzero(urms,ntot)
          call rzero(vrms,ntot)
          call rzero(wrms,ntot)
          call rzero(prms,nto2)
          do i = 1,ldimt
             call rzero(trms(1,1,1,1,i),ntott)
          enddo

          call rzero(vwms,ntot)
          call rzero(wums,ntot)
          call rzero(uvms,ntot)
       endif

       dtime = time  - timel
       atime = atime + dtime

       ! dump freq
       iastep = param(68)
       if  (iastep.eq.0) iastep=param(15)   ! same as iostep
       if  (iastep.eq.0) iastep=500

       ifverbose=.false.
       if (istep.le.10) ifverbose=.true.
       if  (mod(istep,iastep).eq.0) ifverbose=.true.

       if (atime.ne.0..and.dtime.ne.0.) then
          if(nid.eq.0) write(6,*) 'Compute statistics ...'
          beta  = dtime/atime
          alpha = 1.-beta
          ! compute averages E(X)
          call avg1    (uavg,vx,alpha,beta,ntot ,'um  ',ifverbose)
          call avg1    (vavg,vy,alpha,beta,ntot ,'vm  ',ifverbose)
          call avg1    (wavg,vz,alpha,beta,ntot ,'wm  ',ifverbose)
          call avg1    (pavg,pr,alpha,beta,nto2 ,'prm ',ifverbose)
          call avg1    (tavg,t ,alpha,beta,ntott,'tm  ',ifverbose)
          do i = 2,ldimt
             call avg1 (tavg(1,1,1,1,i),t(1,1,1,1,i),alpha,beta,
      &                 ntott,'psav',ifverbose)
          enddo

          ! compute averages E(X^2)
          call avg2    (urms,vx,alpha,beta,ntot ,'ums ',ifverbose)
          call avg2    (vrms,vy,alpha,beta,ntot ,'vms ',ifverbose)
          call avg2    (wrms,vz,alpha,beta,ntot ,'wms ',ifverbose)
          call avg2    (prms,pr,alpha,beta,nto2 ,'prms',ifverbose)
          call avg2    (trms,t ,alpha,beta,ntott,'tms ',ifverbose)
          do i = 2,ldimt
             call avg2 (trms(1,1,1,1,i),t(1,1,1,1,i),alpha,beta,
      &                 ntott,'psms',ifverbose)
          enddo

          ! compute averages E(X*Y) (for now just for the velocities)
          call avg3    (uvms,vx,vy,alpha,beta,ntot,'uvm ',ifverbose)
          call avg3    (vwms,vy,vz,alpha,beta,ntot,'vwm ',ifverbose)
          call avg3    (wums,vz,vx,alpha,beta,ntot,'wum ',ifverbose)
       endif
c
c-----------------------------------------------------------------------
       if ( (mod(istep,iastep).eq.0.and.istep.gt.1) .or.lastep.eq.1) then

          time_temp = time
          time      = atime   ! Output the duration of this avg

          call outpost2(uavg,vavg,wavg,pavg,tavg,ldimt,'avg')
          call outpost2(urms,vrms,wrms,prms,trms,ldimt,'rms')
          call outpost2(uvms,vwms,wums,prms,wtms,0    ,'rm2')

          atime = 0.
          time  = time_temp  ! Restore clock

       endif
c
       timel = time
c
       return
       end
c-----------------------------------------------------------------------
       subroutine avg1(avg,f,alpha,beta,n,name,ifverbose)
       include 'SIZE'
       include 'TSTEP'
c
       real avg(n),f(n)
       character*4 name
       logical ifverbose
c
       do k=1,n
          avg(k) = alpha*avg(k) + beta*f(k)
       enddo
c
       if (ifverbose) then
          avgmax = glmax(avg,n)
          avgmin = glmin(avg,n)
          if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
      $                           ,alpha,beta,name
     1    format(i9,1p5e13.5,1x,a4,' av1mnx')
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine avg2(avg,f,alpha,beta,n,name,ifverbose)
       include 'SIZE'
       include 'TSTEP'
c
       real avg(n),f(n)
       character*4 name
       logical ifverbose
c
       do k=1,n
          avg(k) = alpha*avg(k) + beta*f(k)*f(k)
       enddo
c
       if (ifverbose) then
          avgmax = glmax(avg,n)
          avgmin = glmin(avg,n)
          if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
      $                           ,alpha,beta,name
     1    format(i9,1p5e13.5,1x,a4,' av2mnx')
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine avg3(avg,f,g,alpha,beta,n,name,ifverbose)
       include 'SIZE'
       include 'TSTEP'
c
       real avg(n),f(n),g(n)
       character*4 name
       logical ifverbose
c
       do k=1,n
          avg(k) = alpha*avg(k) + beta*f(k)*g(k)
       enddo
c
       if (ifverbose) then
          avgmax = glmax(avg,n)
          avgmin = glmin(avg,n)
          if (nid.eq.0) write(6,1) istep,time,avgmin,avgmax
      $                           ,alpha,beta,name
     1    format(i9,1p5e13.5,1x,a4,' av3mnx')
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine build_legend_transform(Lj,Ljt,zpts,nx)
c
       real Lj(nx*nx),Ljt(nx*nx),zpts(nx)
c
       parameter (lm=90)
       integer   indr(lm),indc(lm),ipiv(lm)
c
       if (nx.gt.lm) then
          write(6,*) 'ABORT in build_legend_transform:',nx,lm
          call exitt
       endif
c
       j = 1
       n = nx-1
       do i=1,nx
          z = zpts(i)
          call legendre_poly(Lj(j),z,n)  ! Return Lk(z), k=0,...,n
          j = j+nx
       enddo
       call transpose1(Lj,nx)
c     call outmat(Lj,nx,nx,'Lj ',n)
c     call exitt
       call gaujordf  (Lj,nx,nx,indr,indc,ipiv,ierr,rmult)
       call transpose (Ljt,nx,Lj,nx)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine local_err_est(err,u,nx,Lj,Ljt,uh,w,if3d)
c
c     Local error estimates for u_e
c
       include 'SIZE'
       real err(5,2),u(1),uh(nx,nx,nx),w(1),Lj(1),Ljt(1)
       logical if3d
c
       call rzero(err,10)
c
       nxyz = nx**ndim
       utot = vlsc2(u,u,nxyz)
       if (utot.eq.0) return
c
       call tensr3(uh,nx,u,nx,Lj,Ljt,Ljt,w)    !  Go to Legendre space
c
c
c     Get energy in low modes
c
       m = nx-2
c
       if (if3d) then
          amp2_l = 0.
          do k=1,m
          do j=1,m
          do i=1,m
             amp2_l = amp2_l + uh(i,j,k)**2
          enddo
          enddo
          enddo
c
c        Energy in each spatial direction
c
          amp2_t = 0
          do k=m+1,nx
          do j=1,m
          do i=1,m
             amp2_t = amp2_t + uh(i,j,k)**2
          enddo
          enddo
          enddo
c
          amp2_s = 0
          do k=1,m
          do j=m+1,nx
          do i=1,m
             amp2_s = amp2_s + uh(i,j,k)**2
          enddo
          enddo
          enddo
c
          amp2_r = 0
          do k=1,m
          do j=1,m
          do i=m+1,nx
             amp2_r = amp2_r + uh(i,j,k)**2
          enddo
          enddo
          enddo
c
          amp2_h = 0
          do k=m+1,nx
          do j=m+1,nx
          do i=m+1,nx
             amp2_h = amp2_h + uh(i,j,k)**2
          enddo
          enddo
          enddo
c
          etot = amp2_l + amp2_r + amp2_s + amp2_t + amp2_h
c
          relr = amp2_r / (amp2_r + amp2_l)
          rels = amp2_s / (amp2_s + amp2_l)
          relt = amp2_t / (amp2_t + amp2_l)
          relh = (amp2_r + amp2_s + amp2_t + amp2_h) / etot
c
       else
          k = 1
          amp2_l = 0.
          do j=1,m
          do i=1,m
             amp2_l = amp2_l + uh(i,j,k)**2
          enddo
          enddo
          if (amp2_l.eq.0) return
c
c        Energy in each spatial direction
c
          amp2_t = 0
c
          amp2_s = 0
          do j=m+1,nx
          do i=1,m
             amp2_s = amp2_s + uh(i,j,k)**2
          enddo
          enddo
c
          amp2_r = 0
          do j=1,m
          do i=m+1,nx
             amp2_r = amp2_r + uh(i,j,k)**2
          enddo
          enddo
c
          amp2_h = 0
          do j=m+1,nx
          do i=m+1,nx
             amp2_h = amp2_h + uh(i,j,k)**2
          enddo
          enddo
c
          etot = amp2_l + amp2_r + amp2_s + amp2_h
c
          relr = amp2_r / (amp2_r + amp2_l)
          rels = amp2_s / (amp2_s + amp2_l)
          relt = 0
          relh = (amp2_r + amp2_s + amp2_h) / etot
c
       endif
c
       err (1,1) = sqrt(relr)
       err (2,1) = sqrt(rels)
       if (if3d) err (3,1) = sqrt(relt)
       err (4,1) = sqrt(relh)
       err (5,1) = sqrt(etot)
c
       err (1,2) = sqrt(amp2_r)
       err (2,2) = sqrt(amp2_s)
       if (if3d) err (3,2) = sqrt(amp2_t)
       err (4,2) = sqrt(amp2_h)
       err (5,2) = sqrt(utot)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine transpose1(a,n)
       real a(n,n)
c
       do j=1,n
       do i=j+1,n
          ta     = a(i,j)
          a(i,j) = a(j,i)
          a(j,i) = ta
       enddo
       enddo
       return
       end
c-----------------------------------------------------------------------
       subroutine get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
       integer ex,ey,ez,eg
c
       nelxy = nelx*nely
c
       ez = 1 +  (eg-1)/nelxy
       ey = mod1 (eg,nelxy)
       ey = 1 +  (ey-1)/nelx
       ex = mod1 (eg,nelx)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine dump_header2d(excode,nx,ny,nlx,nly)
c
       include 'SIZE'
       include 'TOTAL'
c
       character*2 excode(15)
c
       real*4         test_pattern
c
       character*1 fhdfle1(132)
       character*132 fhdfle
       equivalence (fhdfle,fhdfle1)
c
       jstep = istep
       if (jstep.gt.10000) jstep = jstep / 10
       if (jstep.gt.10000) jstep = jstep / 10
       if (jstep.gt.10000) jstep = jstep / 10
       if (jstep.gt.10000) jstep = jstep / 10
       if (jstep.gt.10000) jstep = jstep / 10

       nlxy = nlx*nly
       nzz  = 1

c     write(6,'(4i4,1PE14.7,i5,1x,15a2,1x,a12)')
c    $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
c    $  'NELT,NX,NY,N'
c
       p66 = 0.
       IF (p66.EQ.1.0) THEN
C       unformatted i/o
         WRITE(24)
      $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15)
       ELSEIF (p66.EQ.3.0) THEN
C       formatted i/o to header file
         WRITE(27,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
      $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
      $  'NELT,NX,NY,N'
       ELSEIF (p66.eq.4.0) THEN
C       formatted i/o to header file
         WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
      $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
      $  ' 4 NELT,NX,NY,N'
         call byte_write(fhdfle,20)
       ELSEIF (p66.eq.5.0) THEN
C       formatted i/o to header file
         WRITE(fhdfle,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
      $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
      $  ' 8 NELT,NX,NY,N'
         call byte_write(fhdfle,20)
       ELSE
C       formatted i/o
         WRITE(24,'(4I4,1pe14.7,I5,1X,15A2,1X,A12)')
      $  nlxy,nx,ny,nzz,TIME,jstep,(excode(i),i=1,15),
      $  'NELT,NX,NY,N'
       ENDIF
C     cdrror is a dummy cerror value for now.
       CDRROR=0.0
       IF (p66.EQ.1.0) THEN
C       unformatted i/o
         WRITE(24)(CDRROR,I=1,nlxy)
       ELSEIF (p66.eq.3. .or. p66.eq.4.0) then
C       write byte-ordering test pattern to byte file...
         test_pattern = 6.54321
         call byte_write(test_pattern,1)
       ELSEIF (p66.eq.5.) then
         test_pattern8 = 6.54321
         call byte_write(test_pattern8,2)
       ELSE
C       formatted i/o
         WRITE(24,'(6G11.4)')(CDRROR,I=1,nlxy)
       ENDIF
c
       return
       end
c-----------------------------------------------------------------------
       subroutine outfld2d_p(u,v,w,nx,ny,nlx,nly,name,ifld,jid,npido)

       include 'SIZE'
       include 'TOTAL'

       integer icalld
       save    icalld
       data    icalld /0/

       real u(nx*ny*nlx*nly)
       real v(nx*ny*nlx*nly)
       real w(nx*ny*nlx*nly)
       character*4 name

       character*2  excode(15)
       character*12 fm
       character*20 outfile

       character*1 slash,dot
       save        slash,dot
       data        slash,dot  / '/' , '.' /

       icalld = icalld+1

       call blank(excode,30)
       excode(4) = 'U '
       excode(5) = '  '
       excode(6) = 'T '
       nthings   =  3

       call blank(outfile,20)
       if (npido.lt.100) then
          if (ifld.lt.100) then
             write(outfile,22) jid,slash,name,ifld
    22       format('B',i2.2,a1,a4,'.fld',i2.2)
          elseif (ifld.lt.1000) then
             write(outfile,23) jid,slash,name,ifld
    23       format('B',i2.2,a1,a4,'.fld',i3)
          elseif (ifld.lt.10000) then
             write(outfile,24) jid,slash,name,ifld
    24       format('B',i2.2,a1,a4,'.fld',i4)
          elseif (ifld.lt.100000) then
             write(outfile,25) jid,slash,name,ifld
    25       format('B',i2.2,a1,a4,'.fld',i5)
          elseif (ifld.lt.1000000) then
             write(outfile,26) jid,slash,name,ifld
    26       format('B',i2.2,a1,a4,'.fld',i6)
          endif
       else
          if (ifld.lt.100) then
             write(outfile,32) jid,slash,name,ifld
    32       format('B',i3.3,a1,a4,'.fld',i2.2)
          elseif (ifld.lt.1000) then
             write(outfile,33) jid,slash,name,ifld
    33       format('B',i3.3,a1,a4,'.fld',i3)
          elseif (ifld.lt.10000) then
             write(outfile,34) jid,slash,name,ifld
    34       format('B',i3.3,a1,a4,'.fld',i4)
          elseif (ifld.lt.100000) then
             write(outfile,35) jid,slash,name,ifld
    35       format('B',i3.3,a1,a4,'.fld',i5)
          elseif (ifld.lt.1000000) then
             write(outfile,36) jid,slash,name,ifld
    36       format('B',i3.3,a1,a4,'.fld',i6)
          endif
       endif

       if (icalld.le.4) write(6,*) nid,outfile,' OPEN',nlx,nly
       open(unit=24,file=outfile,status='unknown')
       call dump_header2d(excode,nx,ny,nlx,nly)

       n = nx*ny*nlx*nly
       write(fm,10) nthings
       write(24,fm) (u(i),v(i),w(i),i=1,n)
    10 format('(1p',i1,'e14.6)')
       close(24)

       return
       end
c-----------------------------------------------------------------------
       subroutine outfld2d(u,v,w,nx,ny,nlx,nly,name,ifld)
c
       include 'SIZE'
       include 'TOTAL'
c
       real u(nx*ny*nlx*nly)
       real v(nx*ny*nlx*nly)
       real w(nx*ny*nlx*nly)
       character*3 name
c
       character*2  excode(15)
       character*12 fm
       character*20 outfile

c     if (istep.le.10) write(6,*) nid,' in out2d:',iz
c
       call blank(excode,30)
c
c     excode(1) = 'X '
c     excode(2) = 'Y '
c     excode(3) = 'U '
c     excode(4) = 'V '
c     excode(5) = 'P '
c     excode(6) = 'T '
c
       excode(4) = 'U '
       excode(5) = '  '
       excode(6) = 'T '
       nthings   =  3
c
       if (nid.eq.0) then
          call blank(outfile,20)
          if (ifld.lt.100) then
             write(outfile,2) name,ifld
     2       format(a3,'2d.fld',i2.2)
          elseif (ifld.lt.1000) then
             write(outfile,3) name,ifld
     3       format(a3,'2d.fld',i3)
          elseif (ifld.lt.10000) then
             write(outfile,4) name,ifld
     4       format(a3,'2d.fld',i4)
          elseif (ifld.lt.100000) then
             write(outfile,5) name,ifld
     5       format(a3,'2d.fld',i5)
          elseif (ifld.lt.1000000) then
             write(outfile,6) name,ifld
     6       format(a3,'2d.fld',i6)
          endif
          open(unit=24,file=outfile,status='unknown')
          call dump_header2d(excode,nx,ny,nlx,nly)
c
          n = nx*ny*nlx*nly
          write(fm,10) nthings
c        write(6,*) fm
c        call exitt
          write(24,fm) (u(i),v(i),w(i),i=1,n)
    10    format('(1p',i1,'e14.6)')
c  10    format('''(1p',i1,'e15.7)''')
c  10    format(1p7e15.7)
c
          close(24)
       endif
c
       return
       end
c-----------------------------------------------------------------------
       subroutine planar_average_z(ua,u,w1,w2)
c
c     Compute r-s planar average of quantity u()
c
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'WZ'
       include 'ZPER'
c
       real ua(nz1,nelz),u(nx1*ny1,nz1,nelv),w1(nz1,nelz),w2(nz1,nelz)
       integer e,eg,ez
c
       melxy = nelx*nely
c
       nz = nz1*nelz
       call rzero(ua,nz)
       call rzero(w1,nz)
c
       do e=1,nelt
c
          eg = lglel(e)
          ez = 1 + (eg-1)/melxy
c
          do k=1,nz1
          do i=1,nx1*ny1
             zz = (1.-zgm1(k,3))/2.  ! = 1 for k=1, = 0 for k=nz1
             aa = zz*area(i,1,5,e) + (1-zz)*area(i,1,6,e)  ! wgtd jacobian
             w1(k,ez) = w1(k,ez) + aa
             ua(k,ez) = ua(k,ez) + aa*u(i,k,e)
          enddo
          enddo
       enddo
c
       call gop(ua,w2,'+  ',nz)
       call gop(w1,w2,'+  ',nz)
c
       do i=1,nz
          ua(i,1) = ua(i,1) / w1(i,1)   ! Normalize
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,visc,f,e)
c
       INCLUDE 'SIZE'
       INCLUDE 'GEOM'
       INCLUDE 'INPUT'
       INCLUDE 'TOPOL'
       INCLUDE 'TSTEP'
c
       real dgtq(3,4)
       real xm0 (lx1,ly1,lz1,lelt)
       real ym0 (lx1,ly1,lz1,lelt)
       real zm0 (lx1,ly1,lz1,lelt)
       real sij (lx1,ly1,lz1,3*ldim-3,lelv)
       real pm1 (lx1,ly1,lz1,lelv)
       real visc(lx1,ly1,lz1,lelv)
c
       real dg(3,2)
c
       integer f,e,pf
       real    n1,n2,n3
c
       call dsset(nx1,ny1,nz1)    ! set up counters
       pf     = eface1(f)         ! convert from preproc. notation
       js1    = skpdat(1,pf)
       jf1    = skpdat(2,pf)
       jskip1 = skpdat(3,pf)
       js2    = skpdat(4,pf)
       jf2    = skpdat(5,pf)
       jskip2 = skpdat(6,pf)
C
       call rzero(dgtq,12)
c
       if (if3d.or.ifaxis) then
        i = 0
        a = 0
        do j2=js2,jf2,jskip2
        do j1=js1,jf1,jskip1
          i = i+1
          n1 = unx(i,1,f,e)*area(i,1,f,e)
          n2 = uny(i,1,f,e)*area(i,1,f,e)
          n3 = unz(i,1,f,e)*area(i,1,f,e)
          a  = a +          area(i,1,f,e)
c
          v  = visc(j1,j2,1,e)
c
          s11 = sij(j1,j2,1,1,e)
          s21 = sij(j1,j2,1,4,e)
          s31 = sij(j1,j2,1,6,e)
c
          s12 = sij(j1,j2,1,4,e)
          s22 = sij(j1,j2,1,2,e)
          s32 = sij(j1,j2,1,5,e)
c
          s13 = sij(j1,j2,1,6,e)
          s23 = sij(j1,j2,1,5,e)
          s33 = sij(j1,j2,1,3,e)
c
          dg(1,1) = pm1(j1,j2,1,e)*n1     ! pressure drag
          dg(2,1) = pm1(j1,j2,1,e)*n2
          dg(3,1) = pm1(j1,j2,1,e)*n3
c
          dg(1,2) = -v*(s11*n1 + s12*n2 + s13*n3) ! viscous drag
          dg(2,2) = -v*(s21*n1 + s22*n2 + s23*n3)
          dg(3,2) = -v*(s31*n1 + s32*n2 + s33*n3)
c
          r1 = xm0(j1,j2,1,e)
          r2 = ym0(j1,j2,1,e)
          r3 = zm0(j1,j2,1,e)
c
          do l=1,2
          do k=1,3
             dgtq(k,l) = dgtq(k,l) + dg(k,l)
          enddo
          enddo
c
          dgtq(1,3) = dgtq(1,3) + (r2*dg(3,1)-r3*dg(2,1)) ! pressure
          dgtq(2,3) = dgtq(2,3) + (r3*dg(1,1)-r1*dg(3,1)) ! torque
          dgtq(3,3) = dgtq(3,3) + (r1*dg(2,1)-r2*dg(1,1))
c
          dgtq(1,4) = dgtq(1,4) + (r2*dg(3,2)-r3*dg(2,2)) ! viscous
          dgtq(2,4) = dgtq(2,4) + (r3*dg(1,2)-r1*dg(3,2)) ! torque
          dgtq(3,4) = dgtq(3,4) + (r1*dg(2,2)-r2*dg(1,2))
        enddo
        enddo

       else ! 2D

        i = 0
        a = 0
        do j2=js2,jf2,jskip2
        do j1=js1,jf1,jskip1
          i = i+1
          n1 = unx(i,1,f,e)*area(i,1,f,e)
          n2 = uny(i,1,f,e)*area(i,1,f,e)
          a  = a +          area(i,1,f,e)
          v  = visc(j1,j2,1,e)

          s11 = sij(j1,j2,1,1,e)
          s12 = sij(j1,j2,1,3,e)
          s21 = sij(j1,j2,1,3,e)
          s22 = sij(j1,j2,1,2,e)

          dg(1,1) = pm1(j1,j2,1,e)*n1     ! pressure drag
          dg(2,1) = pm1(j1,j2,1,e)*n2
          dg(3,1) = 0

          dg(1,2) = -v*(s11*n1 + s12*n2) ! viscous drag
          dg(2,2) = -v*(s21*n1 + s22*n2)
          dg(3,2) = 0.

          r1 = xm0(j1,j2,1,e)
          r2 = ym0(j1,j2,1,e)
          r3 = 0.

          do l=1,2
          do k=1,3
             dgtq(k,l) = dgtq(k,l) + dg(k,l)
          enddo
          enddo

          dgtq(1,3) = 0! dgtq(1,3) + (r2*dg(3,1)-r3*dg(2,1)) ! pressure
          dgtq(2,3) = 0! dgtq(2,3) + (r3*dg(1,1)-r1*dg(3,1)) ! torque
          dgtq(3,3) = dgtq(3,3) + (r1*dg(2,1)-r2*dg(1,1))

          dgtq(1,4) = 0! dgtq(1,4) + (r2*dg(3,2)-r3*dg(2,2)) ! viscous
          dgtq(2,4) = 0! dgtq(2,4) + (r3*dg(1,2)-r1*dg(3,2)) ! torque
          dgtq(3,4) = dgtq(3,4) + (r1*dg(2,2)-r2*dg(1,2))
        enddo
        enddo
       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine torque_calc(scale,x0,ifdout,iftout)
c
c     Compute torque about point x0
c
c     Scale is a user-supplied multiplier so that results may be
c     scaled to any convenient non-dimensionalization.
c
c
       INCLUDE 'SIZE'
       INCLUDE 'TOTAL'

       common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
      $                , scale_vf(3)

c
       real x0(3),w1(0:maxobj)
       logical ifdout,iftout
c
       common /scrns/         sij (lx1*ly1*lz1*6*lelv)
       common /scrcg/         pm1 (lx1,ly1,lz1,lelv)
       common /scrsf/         xm0(lx1,ly1,lz1,lelt)
      $,                      ym0(lx1,ly1,lz1,lelt)
      $,                      zm0(lx1,ly1,lz1,lelt)
c
       parameter (lr=lx1*ly1*lz1)
       common /scruz/         ur(lr),us(lr),ut(lr)
      $                     , vr(lr),vs(lr),vt(lr)
      $                     , wr(lr),ws(lr),wt(lr)
c
       common /ctorq/ dragx(0:maxobj),dragpx(0:maxobj),dragvx(0:maxobj)
      $             , dragy(0:maxobj),dragpy(0:maxobj),dragvy(0:maxobj)
      $             , dragz(0:maxobj),dragpz(0:maxobj),dragvz(0:maxobj)
c
      $             , torqx(0:maxobj),torqpx(0:maxobj),torqvx(0:maxobj)
      $             , torqy(0:maxobj),torqpy(0:maxobj),torqvy(0:maxobj)
      $             , torqz(0:maxobj),torqpz(0:maxobj),torqvz(0:maxobj)
c
      $             , dpdx_mean,dpdy_mean,dpdz_mean
      $             , dgtq(3,4)
c
c
       n = nx1*ny1*nz1*nelv
c
       call mappr(pm1,pr,xm0,ym0) ! map pressure onto Mesh 1
c
c    Add mean_pressure_gradient.X to p:

       if (param(55).ne.0) then
          dpdx_mean = -scale_vf(1)
          dpdy_mean = -scale_vf(2)
          dpdz_mean = -scale_vf(3)
       endif

       call add2s2(pm1,xm1,dpdx_mean,n)  ! Doesn't work if object is cut by
       call add2s2(pm1,ym1,dpdy_mean,n)  ! periodicboundary.  In this case,
       call add2s2(pm1,zm1,dpdz_mean,n)  ! set ._mean=0 and compensate in
c
c    Compute sij
c
       nij = 3
       if (if3d.or.ifaxis) nij=6
       call comp_sij(sij,nij,vx,vy,vz,ur,us,ut,vr,vs,vt,wr,ws,wt)
c
c
c     Fill up viscous array w/ default
c
       if (istep.lt.1) call cfill(vdiff,param(2),n)
c
       call cadd2(xm0,xm1,-x0(1),n)
       call cadd2(ym0,ym1,-x0(2),n)
       call cadd2(zm0,zm1,-x0(3),n)
c
       x1min=glmin(xm0(1,1,1,1),n)
       x2min=glmin(ym0(1,1,1,1),n)
       x3min=glmin(zm0(1,1,1,1),n)
c
       x1max=glmax(xm0(1,1,1,1),n)
       x2max=glmax(ym0(1,1,1,1),n)
       x3max=glmax(zm0(1,1,1,1),n)
c
       do i=0,maxobj
          dragpx(i) = 0   ! BIG CODE  :}
          dragvx(i) = 0
          dragx (i) = 0
          dragpy(i) = 0
          dragvy(i) = 0
          dragy (i) = 0
          dragpz(i) = 0
          dragvz(i) = 0
          dragz (i) = 0
          torqpx(i) = 0
          torqvx(i) = 0
          torqx (i) = 0
          torqpy(i) = 0
          torqvy(i) = 0
          torqy (i) = 0
          torqpz(i) = 0
          torqvz(i) = 0
          torqz (i) = 0
       enddo
c
c
       nobj = 0
       do ii=1,nhis
         if (hcode(10,ii).EQ.'I') then
           iobj   = lochis(1,ii)
           memtot = nmember(iobj)
           nobj   = max(iobj,nobj)
c
           if (hcode(1,ii).ne.' ' .or. hcode(2,ii).ne.' ' .or.
      $      hcode(3,ii).ne.' ' ) then
             ifield = 1
c
c           Compute drag for this object
c
             do mem=1,memtot
                ieg   = object(iobj,mem,1)
                ifc   = object(iobj,mem,2)
                if (gllnid(ieg).eq.nid) then ! this processor has a contribution
                   ie = gllel(ieg)
                   call drgtrq(dgtq,xm0,ym0,zm0,sij,pm1,vdiff,ifc,ie)
c
                   call cmult(dgtq,scale,12)
c
                   dragpx(iobj) = dragpx(iobj) + dgtq(1,1)  ! pressure
                   dragpy(iobj) = dragpy(iobj) + dgtq(2,1)
                   dragpz(iobj) = dragpz(iobj) + dgtq(3,1)
c
                   dragvx(iobj) = dragvx(iobj) + dgtq(1,2)  ! viscous
                   dragvy(iobj) = dragvy(iobj) + dgtq(2,2)
                   dragvz(iobj) = dragvz(iobj) + dgtq(3,2)
c
                   torqpx(iobj) = torqpx(iobj) + dgtq(1,3)  ! pressure
                   torqpy(iobj) = torqpy(iobj) + dgtq(2,3)
                   torqpz(iobj) = torqpz(iobj) + dgtq(3,3)
c
                   torqvx(iobj) = torqvx(iobj) + dgtq(1,4)  ! viscous
                   torqvy(iobj) = torqvy(iobj) + dgtq(2,4)
                   torqvz(iobj) = torqvz(iobj) + dgtq(3,4)
c
                endif
             enddo
           endif
         endif
       enddo
c
c     Sum contributions from all processors
c
       call gop(dragpx,w1,'+  ',maxobj+1)
       call gop(dragpy,w1,'+  ',maxobj+1)
       call gop(dragpz,w1,'+  ',maxobj+1)
       call gop(dragvx,w1,'+  ',maxobj+1)
       call gop(dragvy,w1,'+  ',maxobj+1)
       call gop(dragvz,w1,'+  ',maxobj+1)
c
       call gop(torqpx,w1,'+  ',maxobj+1)
       call gop(torqpy,w1,'+  ',maxobj+1)
       call gop(torqpz,w1,'+  ',maxobj+1)
       call gop(torqvx,w1,'+  ',maxobj+1)
       call gop(torqvy,w1,'+  ',maxobj+1)
       call gop(torqvz,w1,'+  ',maxobj+1)
c
       nobj = iglmax(nobj,1)
c
       do i=1,nobj
          dragx(i) = dragpx(i) + dragvx(i)
          dragy(i) = dragpy(i) + dragvy(i)
          dragz(i) = dragpz(i) + dragvz(i)
c
          torqx(i) = torqpx(i) + torqvx(i)
          torqy(i) = torqpy(i) + torqvy(i)
          torqz(i) = torqpz(i) + torqvz(i)
c
          dragpx(0) = dragpx (0) + dragpx (i)
          dragvx(0) = dragvx (0) + dragvx (i)
          dragx (0) = dragx  (0) + dragx  (i)
c
          dragpy(0) = dragpy (0) + dragpy (i)
          dragvy(0) = dragvy (0) + dragvy (i)
          dragy (0) = dragy  (0) + dragy  (i)
c
          dragpz(0) = dragpz (0) + dragpz (i)
          dragvz(0) = dragvz (0) + dragvz (i)
          dragz (0) = dragz  (0) + dragz  (i)
c
          torqpx(0) = torqpx (0) + torqpx (i)
          torqvx(0) = torqvx (0) + torqvx (i)
          torqx (0) = torqx  (0) + torqx  (i)
c
          torqpy(0) = torqpy (0) + torqpy (i)
          torqvy(0) = torqvy (0) + torqvy (i)
          torqy (0) = torqy  (0) + torqy  (i)
c
          torqpz(0) = torqpz (0) + torqpz (i)
          torqvz(0) = torqvz (0) + torqvz (i)
          torqz (0) = torqz  (0) + torqz  (i)
c
       enddo
c
       i0 = 0
       if (nobj.le.1) i0 = 1  ! one output for single-object case
c
       do i=i0,nobj
         if (nid.eq.0) then
           if (if3d.or.ifaxis) then
            if (ifdout) then
             write(6,6) istep,time,dragx(i),dragpx(i),dragvx(i),i,'dragx'
             write(6,6) istep,time,dragy(i),dragpy(i),dragvy(i),i,'dragy'
             write(6,6) istep,time,dragz(i),dragpz(i),dragvz(i),i,'dragz'
            endif
            if (iftout) then
             write(6,6) istep,time,torqx(i),torqpx(i),torqvx(i),i,'torqx'
             write(6,6) istep,time,torqy(i),torqpy(i),torqvy(i),i,'torqy'
             write(6,6) istep,time,torqz(i),torqpz(i),torqvz(i),i,'torqz'
            endif
           else
            if (ifdout) then
             write(6,6) istep,time,dragx(i),dragpx(i),dragvx(i),i,'dragx'
             write(6,6) istep,time,dragy(i),dragpy(i),dragvy(i),i,'dragy'
            endif
            if (iftout) then
             write(6,6) istep,time,torqz(i),torqpz(i),torqvz(i),i,'torqz'
            endif
           endif
         endif
     6   format(i8,1p4e15.7,2x,i5,a5)
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine comp_sij(sij,nij,u,v,w,ur,us,ut,vr,vs,vt,wr,ws,wt)
c                                       du_i       du_j
c     Compute the stress tensor S_ij := ----   +   ----
c                                       du_j       du_i
c
       include 'SIZE'
       include 'TOTAL'
c
       integer e
c
       real sij(lx1*ly1*lz1,nij,lelv)
       real u  (lx1*ly1*lz1,lelv)
       real v  (lx1*ly1*lz1,lelv)
       real w  (lx1*ly1*lz1,lelv)
       real ur (1) , us (1) , ut (1)
      $   , vr (1) , vs (1) , vt (1)
      $   , wr (1) , ws (1) , wt (1)


       n    = nx1-1      ! Polynomial degree
       nxyz = nx1*ny1*nz1

       if (if3d) then     ! 3D CASE
        do e=1,nelv
         call local_grad3(ur,us,ut,u,N,e,dxm1,dxtm1)
         call local_grad3(vr,vs,vt,v,N,e,dxm1,dxtm1)
         call local_grad3(wr,ws,wt,w,N,e,dxm1,dxtm1)

         do i=1,nxyz

          j = jacmi(i,e)

          sij(i,1,e) = j*  ! du/dx + du/dx
      $   2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e)+ut(i)*txm1(i,1,1,e))

          sij(i,2,e) = j*  ! dv/dy + dv/dy
      $   2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e)+vt(i)*tym1(i,1,1,e))

          sij(i,3,e) = j*  ! dw/dz + dw/dz
      $   2*(wr(i)*rzm1(i,1,1,e)+ws(i)*szm1(i,1,1,e)+wt(i)*tzm1(i,1,1,e))

          sij(i,4,e) = j*  ! du/dy + dv/dx
      $   (ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e)+ut(i)*tym1(i,1,1,e) +
      $    vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e)+vt(i)*txm1(i,1,1,e) )

          sij(i,5,e) = j*  ! dv/dz + dw/dy
      $   (wr(i)*rym1(i,1,1,e)+ws(i)*sym1(i,1,1,e)+wt(i)*tym1(i,1,1,e) +
      $    vr(i)*rzm1(i,1,1,e)+vs(i)*szm1(i,1,1,e)+vt(i)*tzm1(i,1,1,e) )

          sij(i,6,e) = j*  ! du/dz + dw/dx
      $   (ur(i)*rzm1(i,1,1,e)+us(i)*szm1(i,1,1,e)+ut(i)*tzm1(i,1,1,e) +
      $    wr(i)*rxm1(i,1,1,e)+ws(i)*sxm1(i,1,1,e)+wt(i)*txm1(i,1,1,e) )

         enddo
        enddo

       elseif (ifaxis) then  ! AXISYMMETRIC CASE

c
c        Notation:                       ( 2  x  Acheson, p. 353)
c                     Cylindrical
c            Nek5k    Coordinates
c
c              x          z
c              y          r
c              z          theta
c

          do e=1,nelv
             call setaxdy ( ifrzer(e) )  ! change dytm1 if on-axis
             call local_grad2(ur,us,u,N,e,dxm1,dytm1)
             call local_grad2(vr,vs,v,N,e,dxm1,dytm1)
             call local_grad2(wr,ws,w,N,e,dxm1,dytm1)

             do i=1,nxyz
                j = jacmi(i,e)
                r = ym1(i,1,1,e)                              ! Cyl. Coord:

                sij(i,1,e) = j*  ! du/dx + du/dx              ! e_zz
      $           2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e))

                sij(i,2,e) = j*  ! dv/dy + dv/dy              ! e_rr
      $           2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))

                if (r.gt.0) then                              ! e_@@
                   sij(i,3,e) = v(i,e)/r  ! v / r
                else
                   sij(i,3,e) = j*  ! L'Hopital's rule: e_@@ = dv/dr
      $            2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))
                endif

                sij(i,4,e) = j*  ! du/dy + dv/dx             ! e_zr
      $            ( ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e) +
      $              vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e) )

                if (yyyr.gt.0) then                             ! e_r@
                   sij(i,5,e) = j*  ! dw/dy
      $              ( wr(i)*rym1(i,1,1,e)+ws(i)*sym1(i,1,1,e) )
      $              - w(i,e) / r
                else
                   sij(i,5,e) = 0
                endif

                sij(i,6,e) = j*  ! dw/dx                     ! e_ at z
      $            ( wr(i)*rxm1(i,1,1,e)+ws(i)*sxm1(i,1,1,e) )

             enddo
          enddo

       else              ! 2D CASE

          do e=1,nelv
             call local_grad2(ur,us,u,N,e,dxm1,dxtm1)
             call local_grad2(vr,vs,v,N,e,dxm1,dxtm1)

             do i=1,nxyz
                j = jacmi(i,e)

                sij(i,1,e) = j*  ! du/dx + du/dx
      $           2*(ur(i)*rxm1(i,1,1,e)+us(i)*sxm1(i,1,1,e))

                sij(i,2,e) = j*  ! dv/dy + dv/dy
      $           2*(vr(i)*rym1(i,1,1,e)+vs(i)*sym1(i,1,1,e))

                sij(i,3,e) = j*  ! du/dy + dv/dx
      $           (ur(i)*rym1(i,1,1,e)+us(i)*sym1(i,1,1,e) +
      $            vr(i)*rxm1(i,1,1,e)+vs(i)*sxm1(i,1,1,e) )

             enddo
          enddo
       endif
       return
       end
c-----------------------------------------------------------------------
       subroutine y_slice (ua,u,w1,w2)
c
c     Extract a y slice of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'WZ'
       include 'ZPER'
c
       real ua(nx1,nz1,nelx,nelz),u (nx1,ny1,nz1,nelv)
      $    ,w1(nx1,nz1,nelx,nelz),w2(nx1,nz1,nelx,nelz)
       integer e,eg,ex,ey,ez
       real dy2
c
       mxz = nelx*nelz*nx1*nz1
       call rzero(ua,mxz)
c
       do e=1,nelt
c
          eg = lglel(e)
          call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)

          j = 1
          if (ey.eq.1) then
             do k=1,nz1
             do i=1,nx1
                ua(i,k,ex,ez) = u(i,j,k,e)
             enddo
             enddo
          endif
       enddo

       call gop(ua,w2,'+  ',mxz)

       return
       end
c-----------------------------------------------------------------------
       subroutine z_slice (ua,u,w1,w2)
c
c     Extract a z slice of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'WZ'
       include 'ZPER'
c
       real ua(nx1,ny1,nelx,nely),u (nx1,ny1,nz1,nelv)
      $    ,w1(nx1,ny1,nelx,nely),w2(nx1,ny1,nelx,nely)
       integer e,eg,ex,ey,ez
       real dy2
c
       mxy = nelx*nely*nx1*ny1
       call rzero(ua,mxy)
c
       do e=1,nelt
c
          eg = lglel(e)
          call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)

          k = 1
          if (ez.eq.1) then
             do j=1,ny1
             do i=1,nx1
                ua(i,j,ex,ey) = u(i,j,k,e)
             enddo
             enddo
          endif
       enddo

       call gop(ua,w2,'+  ',mxy)

       return
       end
c-----------------------------------------------------------------------
       subroutine y_average(ua,u,w1,w2)
c
c     Compute the y average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'WZ'
       include 'ZPER'
c
       real ua(nx1,nz1,nelx,nelz),u (nx1,ny1,nz1,nelv)
      $    ,w1(nx1,nz1,nelx,nelz),w2(nx1,nz1,nelx,nelz)
       integer e,eg,ex,ey,ez
       real dy2
c
       mxz = nelx*nelz*nx1*nz1
       call rzero(ua,mxz)
       call rzero(w1,mxz)
c
       do e=1,nelt
c
          eg = lglel(e)
          call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
c
          do k=1,nz1
          do i=1,nx1
c           dy2 = .5*( ym1(i,ny1,k,e) - ym1(i,1,k,e) )
             dy2 = 1.0  !  Assuming uniform in "y" direction
             do j=1,ny1
                ua(i,k,ex,ez) = ua(i,k,ex,ez)+dy2*wym1(j)*u(i,j,k,e)
                w1(i,k,ex,ez) = w1(i,k,ex,ez)+dy2*wym1(j) ! redundant but clear
             enddo
          enddo
          enddo
       enddo
c
       call gop(ua,w2,'+  ',mxz)
       call gop(w1,w2,'+  ',mxz)
c
       do i=1,mxz
          ua(i,1,1,1) = ua(i,1,1,1) / w1(i,1,1,1)   ! Normalize
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine z_average(ua,u,w1,w2)
c
c     Compute the z average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'GEOM'
       include 'PARALLEL'
       include 'WZ'
       include 'ZPER'
c
       real ua(nx1,ny1,nelx,nely),u (nx1,ny1,nz1,nelv)
      $    ,w1(nx1,ny1,nelx,nely),w2(nx1,ny1,nelx,nely)
       integer e,eg,ex,ey,ez
       real dy2
c
       mxy = nelx*nely*nx1*ny1
       call rzero(ua,mxy)
       call rzero(w1,mxy)
c
       do e=1,nelt
c
          eg = lglel(e)
          call get_exyz(ex,ey,ez,eg,nelx,nely,nelz)
c
          do j=1,ny1
          do i=1,nx1
             dz2 = 1.0  !  Assuming uniform in "z" direction
             do k=1,nz1
                ua(i,j,ex,ey) = ua(i,j,ex,ey)+dz2*wzm1(k)*u(i,j,k,e)
                w1(i,j,ex,ey) = w1(i,j,ex,ey)+dz2*wzm1(k) ! redundant but clear
             enddo
          enddo
          enddo
       enddo
c
       call gop(ua,w2,'+  ',mxy)
       call gop(w1,w2,'+  ',mxy)
c
       do i=1,mxy
          ua(i,1,1,1) = ua(i,1,1,1) / w1(i,1,1,1)   ! Normalize
       enddo
c
       return
       end
c-----------------------------------------------------------------------
       subroutine y_avg_buff(ux,uy,uz,c2,name,icount)
c
c     Compute the y average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'TOTAL'
       include 'ZPER'
c
       real ux(1),uy(1),uz(1)
       character*2 c2,name
c
       parameter (lyavg = lx1*lz1*lelx*lelz)
       common /scravg/ u (lyavg)
      $              , v (lyavg)
      $              , w (lyavg)
      $              , w1(lyavg)
      $              , w2(lyavg)
c
       call y_average(u,ux,w1,w2)
       call y_average(v,uy,w1,w2)
       call y_average(w,uz,w1,w2)
c
       call buff_2d_out(u,v,w,nx1,nz1,nelx,nelz,c2,name,icount)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine z_avg_buff(ux,uy,uz,c2,name,icount)
c
c     Compute the z average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'TOTAL'
       include 'ZPER'
c
       real ux(1),uy(1),uz(1)
       character*2 c2,name
c
       parameter (lyavg = lx1*ly1*lelx*lely)
       common /scravg/ u (lyavg)
      $              , v (lyavg)
      $              , w (lyavg)
      $              , w1(lyavg)
      $              , w2(lyavg)
c
       call z_average(u,ux,w1,w2)
       call z_average(v,uy,w1,w2)
       call z_average(w,uz,w1,w2)

       call buff_2d_out(u,v,w,nx1,ny1,nelx,nely,c2,name,icount)

       return
       end
c-----------------------------------------------------------------------
       subroutine y_ins_buff(ux,uy,uz,c2,name,icount)
c
c     Compute the z average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'TOTAL'
       include 'ZPER'
c
       real ux(1),uy(1),uz(1)
       character*2 c2,name
c
       parameter (lyavg = lx1*lz1*lelx*lelz)
       common /scravg/ u (lyavg)
      $              , v (lyavg)
      $              , w (lyavg)
      $              , w1(lyavg)
      $              , w2(lyavg)
c
       call y_slice  (u,ux,w1,w2)
       call y_slice  (v,uy,w1,w2)
       call y_slice  (w,uz,w1,w2)
c
       call buff_2d_out(u,v,w,nx1,nz1,nelx,nelz,c2,name,icount)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine z_ins_buff(ux,uy,uz,c2,name,icount)
c
c     Compute the z average of quantity u() - assumes global tens.prod.
c
       include 'SIZE'
       include 'TOTAL'
       include 'ZPER'
c
       real ux(1),uy(1),uz(1)
       character*2 c2,name
c
       parameter (lyavg = lx1*ly1*lelx*lely)
       common /scravg/ u (lyavg)
      $              , v (lyavg)
      $              , w (lyavg)
      $              , w1(lyavg)
      $              , w2(lyavg)
c
       call z_slice  (u,ux,w1,w2)
       call z_slice  (v,uy,w1,w2)
       call z_slice  (w,uz,w1,w2)
c
       call buff_2d_out(u,v,w,nx1,ny1,nelx,nely,c2,name,icount)
c
       return
       end
c-----------------------------------------------------------------------
       subroutine buff_2d_out(u,v,w,nx,ny,nex,ney,c2,name,ifld)
c
       include 'SIZE'
       include 'TOTAL'

       real u(1),v(1),w(1)
       character*2 c2,name
       character*4  bname
       save         bname

       parameter (lyzm = lelx*max(lely,lelz))
       common /scrav2/ ub(lx1,lz1,lyzm),vb(lx1,lz1,lyzm),wb(lx1,lz1,lyzm)

       integer ibfld,icalld,nxf,nyf,nexf,neyf
       save    ibfld,icalld,nxf,nyf,nexf,neyf
       data    ibfld,icalld,nxf,nyf,nexf,neyf  / 6*0 /

c     npido = 64             !  64 files buffered
       npido = 128            !  64 files buffered
       npido =  min(npido,np) !  P  files buffered

       mpido = np/npido     ! stride between processors (e.g., 128/64 = 2)

       jcalld = mod(icalld,npido)       ! call # 0,1,...,63,0,1,...
       if (mod(nid,mpido) .eq. 0) then  ! this is a buffering/writing proc

          jid = nid/mpido
          if (jid.eq.jcalld) then       ! save this buffer on this proc
c           write(6,1) nid,jid,istep,icalld,jcalld,c2,name,nex,ney,ifld
c   1       format(5i7,' buffering: ',2a2,3i7)
             write(bname,4) c2,name
     4       format(2a2)
             n = nx*ny*nex*ney
             ibfld = ifld
             call copy(ub,u,n)
             call copy(vb,v,n)
             call copy(wb,w,n)
             nxf  = nx
             nyf  = ny
             nexf = nex
             neyf = ney
          endif

          if (jcalld .eq. npido-1) call  ! output buffer
      $      outfld2d_p(ub,vb,wb,nxf,nyf,nexf,neyf,bname,ibfld,jid,npido)

       endif

       icalld = icalld+1
       return
       end
c-----------------------------------------------------------------------
       subroutine y2d(u,v,w,p,c1,icount)
c
c     Compute the y average of quantity u() - assumes global tens.prod.
c

       include 'SIZE'
       include 'TOTAL'
       real u(1),v(1),w(1),p(1)
       character*1 c1,c2(2)

       common /scrns/ ur(lx1*ly1*lz1*lelv)
      $             , ut(lx1*ly1*lz1*lelv)
      $             , wr(lx1*ly1*lz1*lelv)
      $             , wt(lx1*ly1*lz1*lelv)
      $             , wp(lx1*ly1*lz1*lelv)
c
c     Convert velocities to poloidal-toroidal
c
       n = nx1*ny1*nz1*nelv
       do i=1,n
          rr = xm1(i,1,1,1)*xm1(i,1,1,1)+ym1(i,1,1,1)*ym1(i,1,1,1)
          rr = sqrt(rr)
          ct = xm1(i,1,1,1)/rr
          st = ym1(i,1,1,1)/rr
          ur(i) = ct*u(i)+st*v(i)
          ut(i) = ct*v(i)-st*u(i)
          wr(i) = ur(i)**2
          wt(i) = ut(i)**2
          wp(i) = w (i)**2
       enddo

       c2(1) = c1
       c2(2) = 'y'

       call y_avg_buff(ur,w ,ut,c2,'ub',icount)
       call y_avg_buff(wr,wp,wt,c2,'u2',icount)

       do i=1,n
          wr(i) = ur(i)*ut(i)
          wt(i) = ut(i)*w (i)
          wp(i) = w (i)*ur(i)
       enddo
       call y_avg_buff(wr,wt,wp,c2,'uv',icount)

       call y_ins_buff(ur,w ,ut,c2,'ui',icount)

       return
       end
c-----------------------------------------------------------------------
       subroutine z2d(u,v,w,p,c1,icount)
c
c     Compute the y average of quantity u() - assumes global tens.prod.
c

       include 'SIZE'
       include 'TOTAL'
       real u(1),v(1),w(1),p(1)
       character*1 c1,c2(2)

       common /scrns/ ur(lx1*ly1*lz1*lelv)
      $             , ut(lx1*ly1*lz1*lelv)
      $             , wr(lx1*ly1*lz1*lelv)
      $             , wt(lx1*ly1*lz1*lelv)
      $             , wp(lx1*ly1*lz1*lelv)
c
c
c     Convert velocities to poloidal-toroidal
c
       n = nx1*ny1*nz1*nelv
       do i=1,n
          wr(i) = u (i)**2
          wt(i) = v (i)**2
          wp(i) = w (i)**2
       enddo

       c2(1) = c1
       c2(2) = 'z'

       call z_avg_buff(u ,v ,w ,c2,'ub',icount)
       call z_avg_buff(wr,wt,wp,c2,'u2',icount)

       do i=1,n
          wr(i) = u(i)*v(i)
          wt(i) = v(i)*w(i)
          wp(i) = w(i)*u(i)
       enddo
       call z_avg_buff(wr,wt,wp,c2,'uv',icount)

       call z_ins_buff(u ,v ,w ,c2,'ui',icount)

       return
       end
c-----------------------------------------------------------------------
       subroutine anal_2d

       include 'SIZE'
       include 'TOTAL'
       include 'ZPER'

       integer icount
       save    icount

       if (nelx.gt.lelx .or.
      $    nely.gt.lely .or.
      $    nelz.gt.lelz ) then
          if (nid.eq.0) write(6,1) nelx,nely,nelz,lelx,lely,lelz
     1    format('anal_2d fail:',6i6)
          return
       endif

       if (istep.eq.0) then   ! dump four times, just to keep phase

          icount = 0
          call z2d(xm1,ym1,zm1,pr,'u',icount)
          if (ifmhd) call z2d(xm1,ym1,zm1,pm,'b',icount)

          call y2d(xm1,ym1,zm1,pr,'u',icount)
          if (ifmhd) call y2d(xm1,ym1,zm1,pm,'b',icount)

       endif

       icount = icount + 1

       call z2d(vx,vy,vz,pr,'u',icount)
       if (ifmhd) call z2d(bx,by,bz,pm,'b',icount)

       call y2d(vx,vy,vz,pr,'u',icount)
       if (ifmhd) call y2d(bx,by,bz,pm,'b',icount)

       return
       end
c-----------------------------------------------------------------------
       subroutine chkit(u,name4,n)

       include 'SIZE'
       include 'TOTAL'

       character*4 name4
       real u(1)


       integer icalld
       save    icalld
       data    icalld /0/

       icalld = icalld + 1

       u2   = vlsc2(u,u,n)
       umin = vlmin(u,n)
       umax = vlmax(u,n)
       ulst = u(n)
       if (nid.eq.0)
      $write(6,1) nid,icalld,istep,n,umin,umax,ulst,name4,' chkit',nid
     1 format(4i7,1p3e12.4,a4,a6,i1)

       return
       end
c-----------------------------------------------------------------------
       subroutine outmesh
       include 'SIZE'
       include 'TOTAL'
       integer e,eg

       common /cmesh/ xt(2**ldim,ldim)

       len = wdsize*ndim*(2**ndim)

       if (nid.eq.0) open(unit=29,file='rea.new')

       do eg=1,nelgt
          mtype = eg
          call gsync()          !  belt
          jnid = gllnid(eg)
          e    = gllel (eg)
          if (jnid.eq.0 .and. nid.eq.0) then
             call get_el(xt,xm1(1,1,1,e),ym1(1,1,1,e),zm1(1,1,1,e))
             call out_el(xt,eg)
          elseif (nid.eq.0) then
             call crecv(mtype,xt,len)
             call out_el(xt,eg)
          elseif (jnid.eq.nid) then
             call get_el(xt,xm1(1,1,1,e),ym1(1,1,1,e),zm1(1,1,1,e))
             call csend(mtype,xt,len,0,0)
          endif
          call gsync()          !  suspenders
       enddo

       if (nid.eq.0) close(29)
       call gsync()
       call exitt

       return
       end
c-----------------------------------------------------------------------
       subroutine out_el(xt,e)
       include 'SIZE'
       include 'TOTAL'

       real xt(2**ldim,ldim)
       integer e

       integer ed(8)
       save    ed
       data    ed  / 1,2,4,3 , 5,6,8,7 /

       write(29,1) e
       write(29,2) ((xt(ed(k),j),k=1,4),j=1,ndim)
       write(29,2) ((xt(ed(k),j),k=5,8),j=1,ndim)

     1 format(12x,'ELEMENT',i6,' [    1 ]    GROUP     0')
     2 format(1p4e18.10)

       return
       end
c-----------------------------------------------------------------------
       subroutine get_el(xt,x,y,z)
       include 'SIZE'
       include 'TOTAL'

       real xt(2**ldim,ldim)
       real x(nx1,ny1,nz1),y(nx1,ny1,nz1),z(nx1,ny1,nz1)

       l = 0
       do k=1,nz1,nz1-1
       do j=1,ny1,ny1-1
       do i=1,nx1,nx1-1
          l = l+1
          xt(l,1) = x(i,j,k)
          xt(l,2) = y(i,j,k)
          xt(l,3) = z(i,j,k)
       enddo
       enddo
       enddo

       return
       end
c-----------------------------------------------------------------------
       subroutine shear_calc_max(strsmx,scale,x0,ifdout,iftout)
c
c     Compute maximum shear stress on objects
c
c     Scale is a user-supplied multiplier so that results may be
c     scaled to any convenient non-dimensionalization.
c
c
       INCLUDE 'SIZE'
       INCLUDE 'TOTAL'

       real    strsmx(maxobj),x0(3),w1(0:maxobj)
       logical ifdout,iftout

       common /cvflow_r/ flow_rate,base_flow,domain_length,xsec
      $                , scale_vf(3)


       common /scrns/         sij (lx1*ly1*lz1*6*lelv)
       common /scrcg/         pm1 (lx1,ly1,lz1,lelv)
       common /scrsf/         xm0(lx1,ly1,lz1,lelt)
      $,                      ym0(lx1,ly1,lz1,lelt)
      $,                      zm0(lx1,ly1,lz1,lelt)

       parameter (lr=lx1*ly1*lz1)
       common /scruz/         ur(lr),us(lr),ut(lr)
      $                     , vr(lr),vs(lr),vt(lr)
      $                     , wr(lr),ws(lr),wt(lr)


       n = nx1*ny1*nz1*nelv

       call mappr(pm1,pr,xm0,ym0) ! map pressure onto Mesh 1

c    Add mean_pressure_gradient.X to p:

       if (param(55).ne.0) then
          dpdx_mean = -scale_vf(1)
          dpdy_mean = -scale_vf(2)
          dpdz_mean = -scale_vf(3)
       endif

       call add2s2(pm1,xm1,dpdx_mean,n)  ! Doesn't work if object is cut by
       call add2s2(pm1,ym1,dpdy_mean,n)  ! periodicboundary.  In this case,
       call add2s2(pm1,zm1,dpdz_mean,n)  ! set ._mean=0 and compensate in
c
c    Compute sij
c
       nij = 3
       if (if3d.or.ifaxis) nij=6
       call comp_sij(sij,nij,vx,vy,vz,ur,us,ut,vr,vs,vt,wr,ws,wt)
c
c
c     Fill up viscous array w/ default
c
       if (istep.lt.1) call cfill(vdiff,param(2),n)
c
       call cadd2(xm0,xm1,-x0(1),n)
       call cadd2(ym0,ym1,-x0(2),n)
       call cadd2(zm0,zm1,-x0(3),n)
c
       x1min=glmin(xm0(1,1,1,1),n)
       x2min=glmin(ym0(1,1,1,1),n)
       x3min=glmin(zm0(1,1,1,1),n)
c
       x1max=glmax(xm0(1,1,1,1),n)
       x2max=glmax(ym0(1,1,1,1),n)
       x3max=glmax(zm0(1,1,1,1),n)
c
       call rzero(strsmx,maxobj)
c
c
       nobj = 0
       do ii=1,nhis
         if (hcode(10,ii).EQ.'I') then
           iobj   = lochis(1,ii)
           memtot = nmember(iobj)
           nobj   = max(iobj,nobj)
c
           if (hcode(1,ii).ne.' ' .or. hcode(2,ii).ne.' ' .or.
      $      hcode(3,ii).ne.' ' ) then
             ifield = 1
c
c           Compute max stress for this object
c
             strsmx(ii) = 0.
             do mem=1,memtot
                ieg   = object(iobj,mem,1)
                ifc   = object(iobj,mem,2)
                if (gllnid(ieg).eq.nid) then ! this processor has a contribution

                   ie = gllel(ieg)
                   call get_strsmax
      $                    (strsmxl,xm0,ym0,zm0,sij,pm1,vdiff,ifc,ie)

                   call cmult(strsmxl,scale,1)
                   strsmx(ii)=max(strsmx(ii),strsmxl)

                endif
             enddo
           endif
         endif
       enddo
c
c     Max contributions over all processors
c
       call gop(strsmx,w1,'M  ',maxobj)


       return
       end
c-----------------------------------------------------------------------
       subroutine get_strsmax(strsmax,xm0,ym0,zm0,sij,pm1,visc,f,e)
c
       INCLUDE 'SIZE'
       INCLUDE 'GEOM'
       INCLUDE 'INPUT'
       INCLUDE 'TOPOL'
       INCLUDE 'TSTEP'
c
       real dgtq(3,4)
       real xm0 (lx1,ly1,lz1,lelt)
       real ym0 (lx1,ly1,lz1,lelt)
       real zm0 (lx1,ly1,lz1,lelt)
       real sij (lx1,ly1,lz1,3*ldim-3,lelv)
       real pm1 (lx1,ly1,lz1,lelv)
       real visc(lx1,ly1,lz1,lelv)

       integer f,e,pf
       real    n1,n2,n3

       call dsset(nx1,ny1,nz1)    ! set up counters
       pf     = eface1(f)         ! convert from preproc. notation
       js1    = skpdat(1,pf)
       jf1    = skpdat(2,pf)
       jskip1 = skpdat(3,pf)
       js2    = skpdat(4,pf)
       jf2    = skpdat(5,pf)
       jskip2 = skpdat(6,pf)

       if (if3d.or.ifaxis) then
          i       = 0
          strsmax = 0
          do j2=js2,jf2,jskip2
          do j1=js1,jf1,jskip1
             i = i+1
             n1 = unx(i,1,f,e)
             n2 = uny(i,1,f,e)
             n3 = unz(i,1,f,e)
c
             v  = visc(j1,j2,1,e)
c
             s11 = sij(j1,j2,1,1,e)
             s21 = sij(j1,j2,1,4,e)
             s31 = sij(j1,j2,1,6,e)
c
             s12 = sij(j1,j2,1,4,e)
             s22 = sij(j1,j2,1,2,e)
             s32 = sij(j1,j2,1,5,e)

             s13 = sij(j1,j2,1,6,e)
             s23 = sij(j1,j2,1,5,e)
             s33 = sij(j1,j2,1,3,e)

             stress1 = -v*(s11*n1 + s12*n2 + s13*n3) ! viscous drag
             stress2 = -v*(s21*n1 + s22*n2 + s23*n3)
             stress3 = -v*(s31*n1 + s32*n2 + s33*n3)

             strsnrm = stress1*stress1+stress2*stress2+stress3*stress3
             strsmax = max(strsmax,strsnrm)

          enddo
          enddo

       else ! 2D

          i       = 0
          strsmax = 0
          do j2=js2,jf2,jskip2
          do j1=js1,jf1,jskip1
             i = i+1
             n1 = unx(i,1,f,e)*area(i,1,f,e)
             n2 = uny(i,1,f,e)*area(i,1,f,e)
             a  = a +          area(i,1,f,e)
             v  = visc(j1,j2,1,e)

             s11 = sij(j1,j2,1,1,e)
             s12 = sij(j1,j2,1,3,e)
             s21 = sij(j1,j2,1,3,e)
             s22 = sij(j1,j2,1,2,e)

             stress1 = -v*(s11*n1 + s12*n2) ! viscous drag
             stress2 = -v*(s21*n1 + s22*n2)

             strsnrm = stress1*stress1+stress2*stress2
             strsmax = max(strsmax,strsnrm)

        enddo
        enddo

       endif

       if (strsmax.gt.0) strsmax = sqrt(strsmax)

       return
       end
c-----------------------------------------------------------------------
       subroutine fix_geom ! fix up geometry irregularities

       include 'SIZE'
       include 'TOTAL'

       parameter (lt = lx1*ly1*lz1)
       common /scrns/ xb(lt,lelt),yb(lt,lelt),zb(lt,lelt)
       common /scruz/ tmsk(lt,lelt),tmlt(lt,lelt),w1(lt),w2(lt)

       integer e,f
       character*3 cb

       n      = nx1*ny1*nz1*nelt
       nxyz   = nx1*ny1*nz1
       nfaces = 2*ndim
       ifield = 1                   ! velocity field
       if (ifheat) ifield = 2       ! temperature field


       call rone  (tmlt,n)
       call dssum (tmlt,nx1,ny1,nz1)  ! denominator

       call rone  (tmsk,n)
       do e=1,nelfld(ifield)      ! fill mask where bc is periodic
       do f=1,nfaces              ! so we don't translate periodic bcs (z only)
          cb =cbc(f,e,ifield)
          if (cb.eq.'P  ') call facev (tmsk,e,f,0.0,nx1,ny1,nz1)
       enddo
       enddo

       do kpass = 1,ndim+1   ! This doesn't work for 2D, yet.
                             ! Extra pass is just to test convergence

c        call opcopy (xb,yb,zb,xm1,ym1,zm1)
c        call opdssum(xb,yb,zb)
          call copy   (xb,xm1,n)
          call copy   (yb,ym1,n)
          call copy   (zb,zm1,n)
          call dssum  (xb,nx1,ny1,nz1)
          call dssum  (yb,nx1,ny1,nz1)
          call dssum  (zb,nx1,ny1,nz1)

          xm = 0.
          ym = 0.
          zm = 0.

          do e=1,nelfld(ifield)
             do i=1,nxyz                       ! compute averages of geometry
                s     = 1./tmlt(i,e)
                xb(i,e) = s*xb(i,e)
                yb(i,e) = s*yb(i,e)
                zb(i,e) = s*zb(i,e)

                xb(i,e) = xb(i,e) - xm1(i,1,1,e)   ! local displacements
                yb(i,e) = yb(i,e) - ym1(i,1,1,e)
                zb(i,e) = zb(i,e) - zm1(i,1,1,e)
                zb(i,e) = zb(i,e)*tmsk(i,e)

                xm = max(xm,abs(xb(i,e)))
                ym = max(ym,abs(yb(i,e)))
                zm = max(zm,abs(zb(i,e)))
             enddo

             if (kpass.le.ndim) then
                call gh_face_extend(xb(1,e),zgm1,nx1,kpass,w1,w2)
                call gh_face_extend(yb(1,e),zgm1,nx1,kpass,w1,w2)
                call gh_face_extend(zb(1,e),zgm1,nx1,kpass,w1,w2)
             endif

          enddo

          if (kpass.le.ndim) then
             call add2(xm1,xb,n)
             call add2(ym1,yb,n)
             call add2(zm1,zb,n)
          endif

          xx = glamax(xb,n)
          yx = glamax(yb,n)
          zx = glamax(zb,n)

          xm = glmax(xm,1)
          ym = glmax(ym,1)
          zm = glmax(zm,1)

          if (nid.eq.0) write(6,1) xm,ym,zm,xx,yx,zx,kpass
     1    format(1p6e12.4,' xyz repair',i2)

       enddo

       param(59) = 1.       ! ifdef = .true.
       call geom_reset(1)   ! reset metrics, etc.

       return
       end
c-----------------------------------------------------------------------
       subroutine gh_face_extend(x,zg,n,gh_type,e,v)
       include 'SIZE'

       real x(1),zg(1),e(1),v(1)
       integer gh_type

       if (ndim.eq.2) then
          call gh_face_extend_2d(x,zg,n,gh_type,e,v)
       else
          call gh_face_extend_3d(x,zg,n,gh_type,e,v)
       endif

       return
       end
c-----------------------------------------------------------------------
       subroutine gh_face_extend_2d(x,zg,n,gh_type,e,v)
c
c     Extend 2D faces into interior via gordon hall
c
c     gh_type:  1 - vertex only
c               2 - vertex and faces
c
c
       real x(n,n)
       real zg(n)
       real e(n,n)
       real v(n,n)
       integer gh_type
c
c     Build vertex interpolant
c
       ntot=n*n
       call rzero(v,ntot)
       do jj=1,n,n-1
       do ii=1,n,n-1
          do j=1,n
          do i=1,n
             si     = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             sj     = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             v(i,j) = v(i,j) + si*sj*x(ii,jj)
          enddo
          enddo
       enddo
       enddo
       if (gh_type.eq.1) then
          call copy(x,v,ntot)
          return
       endif


c     Extend 4 edges
       call rzero(e,ntot)
c
c     x-edges
c
       do jj=1,n,n-1
          do j=1,n
          do i=1,n
             hj     = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             e(i,j) = e(i,j) + hj*(x(i,jj)-v(i,jj))
          enddo
          enddo
       enddo
c
c     y-edges
c
       do ii=1,n,n-1
          do j=1,n
          do i=1,n
             hi     = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             e(i,j) = e(i,j) + hi*(x(ii,j)-v(ii,j))
          enddo
          enddo
       enddo

       call add3(x,e,v,ntot)

       return
       end
c-----------------------------------------------------------------------
       subroutine gh_face_extend_3d(x,zg,n,gh_type,e,v)
c
c     Extend faces into interior via gordon hall
c
c     gh_type:  1 - vertex only
c               2 - vertex and edges
c               3 - vertex, edges, and faces
c
c
       real x(n,n,n)
       real zg(n)
       real e(n,n,n)
       real v(n,n,n)
       integer gh_type
c
c     Build vertex interpolant
c
       ntot=n*n*n
       call rzero(v,ntot)
       do kk=1,n,n-1
       do jj=1,n,n-1
       do ii=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             si       = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             sj       = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             sk       = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
             v(i,j,k) = v(i,j,k) + si*sj*sk*x(ii,jj,kk)
          enddo
          enddo
          enddo
       enddo
       enddo
       enddo
       if (gh_type.eq.1) then
          call copy(x,v,ntot)
          return
       endif
c
c
c     Extend 12 edges
       call rzero(e,ntot)
c
c     x-edges
c
       do kk=1,n,n-1
       do jj=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hj       = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             hk       = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
             e(i,j,k) = e(i,j,k) + hj*hk*(x(i,jj,kk)-v(i,jj,kk))
          enddo
          enddo
          enddo
       enddo
       enddo
c
c     y-edges
c
       do kk=1,n,n-1
       do ii=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hi       = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             hk       = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
             e(i,j,k) = e(i,j,k) + hi*hk*(x(ii,j,kk)-v(ii,j,kk))
          enddo
          enddo
          enddo
       enddo
       enddo
c
c     z-edges
c
       do jj=1,n,n-1
       do ii=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hi       = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             hj       = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             e(i,j,k) = e(i,j,k) + hi*hj*(x(ii,jj,k)-v(ii,jj,k))
          enddo
          enddo
          enddo
       enddo
       enddo
c
       call add2(e,v,ntot)
c
       if (gh_type.eq.2) then
          call copy(x,e,ntot)
          return
       endif
c
c     Extend faces
c
       call rzero(v,ntot)
c
c     x-edges
c
       do ii=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hi       = 0.5*((n-ii)*(1-zg(i))+(ii-1)*(1+zg(i)))/(n-1)
             v(i,j,k) = v(i,j,k) + hi*(x(ii,j,k)-e(ii,j,k))
          enddo
          enddo
          enddo
       enddo
c
c     y-edges
c
       do jj=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hj       = 0.5*((n-jj)*(1-zg(j))+(jj-1)*(1+zg(j)))/(n-1)
             v(i,j,k) = v(i,j,k) + hj*(x(i,jj,k)-e(i,jj,k))
          enddo
          enddo
          enddo
       enddo
c
c     z-edges
c
       do kk=1,n,n-1
          do k=1,n
          do j=1,n
          do i=1,n
             hk       = 0.5*((n-kk)*(1-zg(k))+(kk-1)*(1+zg(k)))/(n-1)
             v(i,j,k) = v(i,j,k) + hk*(x(i,j,kk)-e(i,j,kk))
          enddo
          enddo
          enddo
       enddo
c
       call add2(v,e,ntot)
       call copy(x,v,ntot)

       return
       end
c-----------------------------------------------------------------------
       function ran1(idum)
c
       integer idum,ia,im,iq,ir,ntab,ndiv
       real    ran1,am,eps,rnmx
c
       parameter (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836)
       parameter (ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps)
c
c     Numerical Rec. in Fortran, 2nd eD.  P. 271
c
       integer j,k
       integer iv(ntab),iy
       save    iv,iy
       data    iv,iy /ntab*0,0/
c
       if (idum.le.0.or.iy.eq.0) then
          idum=max(-idum,1)
          do j=ntab+8,1,-1
             k    = idum/iq
             idum = ia*(idum-k*iq)-ir*k
             if(idum.lt.0) idum = idum+im
             if (j.le.ntab) iv(j) = idum
          enddo
          iy = iv(1)
       endif
       k    = idum/iq
       idum = ia*(idum-k*iq)-ir*k
       if(idum.lt.0) idum = idum+im
       j     = 1+iy/ndiv
       iy    = iv(j)
       iv(j) = idum
       ran1  = min(am*iy,rnmx)
c     ran1  = cos(ran1*1.e8)

       return
       end
c-----------------------------------------------------------------------
       subroutine rand_fld_h1(x)

       include 'SIZE'
       real x(1)

       n=nx1*ny1*nz1*nelt
       id = n
       do i=1,n
          x(i) = ran1(id)
       enddo
       call dsavg(x)

       return
       end
c-----------------------------------------------------------------------
       subroutine rescale_x (x,x0,x1)
       include 'SIZE'
       real x(1)

       n = nx1*ny1*nz1*nelt
       xmin = glmin(x,n)
       xmax = glmax(x,n)

       if (xmax.le.xmin) return

       scale = (x1-x0)/(xmax-xmin)
       do i=1,n
          x(i) = x0 + scale*(x(i)-xmin)
       enddo

       return
       end
c-----------------------------------------------------------------------



More information about the Nek5000-users mailing list