      subroutine zq(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
      implicit none
c
c#######################################################################
c
c     purpose -
c
c        this routine sets mesh quantities
c
c             ..........................................................
c             common 1 flags.
c
c             isq  - point sequence number (fitword entry)
c             imd  - model part identifer (fitword entry)
c             itp  - point type identifer (fitword entry)
c             ihb  - hydro boundary condition flag (fitword entry)
c             irb  - radiation boundary condition flag (fitword entry)
c             nn1  - nearest neighbor search flag (no neighbors are ever
c                       changed after the initial search).
c             nn2  - indicates which neighbors have been searched in a
c                       given calculational cycle.
c             icr  - constraint index to applies to this point.
c             iah  - active hydro flag (=0 ==> active, =1 ==> inactive).
c             npf  - neighbor point type flag.
c
c        format: zq/   isq/istart/iend/istep/ sequence #
c        format: zq/   imd/istart/iend/istep/ part name
c        format: zq/   itp/istart/iend/istep/ point type
c        format: zq/   ihb/istart/iend/istep/ hydro b.c.
c        format: zq/   irb/istart/iend/istep/ radiation b.c.
c        format: zq/   nn1/istart/iend/istep/ permanent n.n. flag.
c        format: zq/   nn2/istart/iend/istep/ dynamic n.n. flag.
c        format: zq/   icr/istart/iend/istep/ constraint flag.
c        format: zq/   iah/istart/iend/istep/ active hydro flag.
c        format: zq/   npf/istart/iend/istep/ neighbor point flag.
c
c             ..........................................................
c             common 2 flags.
c
c             isn  - sequence number.
c
c             ..........................................................
c             source flags.
c
c             iss  - energy source index
c             its  - temperature source index
c             ips  - pressure source index
c             ivs  - velocity (or acceleration) source index
c
c        format: zq/   iss/istart/iend/istep/ source # / start time
c        format: zq/   its/istart/iend/istep/ source # / start time
c        format: zq/   ips/istart/iend/istep/ source # / start time
c        format: zq/   ivs/istart/iend/istep/ source # / start time
c
c             ..........................................................
c             primary variables.
c
c               x  - x-coordinate for a specific mass point
c               y  - y-coordinate for a specific mass point
c               z  - z-coordinate for a specific mass point
c               u  - x-velocity for a specific mass point
c               v  - y-velocity for a specific mass point
c               w  - z-velocity for a specific mass point
c            pmat  - material pressure
c             rho  - material density
c           einter - internal energy
c             tmat - material temperature
c            trad  - radiation temperature
c            prad  - radiation pressure
c           xmass  - mass associated with a point
c          volume  - volume associated with a point
c         velocity - radial velocity relative to an arbitrary center
c           radius - radial position relative to an arbitrary center
c
c        format: zq/     x/istart/iend/istep/  x-coordinate
c        format: zq/     y/istart/iend/istep/  y-coordinate
c        format: zq/     z/istart/iend/istep/  z-coordinate
c        format: zq/     u/istart/iend/istep/  x-velocity
c        format: zq/     v/istart/iend/istep/  y-velocity
c        format: zq/     w/istart/iend/istep/  z-velocity
c        format: zq/  pmat/istart/iend/istep/  pressure
c        format: zq/   rho/istart/iend/istep/  density
c        format: zq/einter/istart/iend/istep/  internal energy
c        format: zq/  tmat/istart/iend/istep/  material temperature
c        format: zq/  trad/istart/iend/istep/  radiation temperature
c        format: zq/  prad/istart/iend/istep/  radiation pressure
c        format: zq/ xmass/istart/iend/istep/  mass
c        format: zq/volume/istart/iend/istep/  volume
c        format: zq/velocity/istart/iend/istep/velocity/xcen/ycen/zcen
c        format: zq/  radius/istart/iend/istep/  radius/xcen/ycen/zcen
c
c
c     input arguments -
c
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
c
c     output arguments -
c
C        ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
c
c     change history -
C
C        $Log: zq.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS    
CPVCS       Rev 1.2   Thu Feb 03 08:42:38 2000   dcg
CPVCS    
CPVCS       Rev 1.1   25 Jan 2000 09:36:20   dcg
CPVCS
CPVCS       Rev 1.47   Fri Sep 03 15:49:20 1999   dcg
CPVCS    get rid of unused options
CPVCS
CPVCS       Rev 1.46   Tue Aug 24 13:35:28 1999   llt
CPVCS    testing
CPVCS
CPVCS       Rev 1.45   Fri Mar 12 12:33:10 1999   dcg
CPVCS    if nwds < 6 print out basic info if not special case
CPVCS
CPVCS       Rev 1.44   Tue Jul 21 08:29:08 1998   dcg
CPVCS    treat ipt1 as itp, icr1 as icr
CPVCS
CPVCS       Rev 1.43   Wed Dec 17 14:33:46 1997   dcg
CPVCS    remove unused cmo_get_info calls
CPVCS
CPVCS       Rev 1.42   Thu Dec 04 17:31:08 1997   dcg
CPVCS    fix bad go to if no attribute found
CPVCS
CPVCS       Rev 1.41   Mon Dec 01 16:31:56 1997   dcg
CPVCS    remove a few obsolete variables
CPVCS
CPVCS       Rev 1.40   Mon Nov 24 16:38:28 1997   dcg
CPVCS     use geom.h and calls to get_regions, get_mregions, get_surfaces
CPVCS    to access geometry data - start to isolate integer*8 dependencies
CPVCS
CPVCS       Rev 1.38   Mon Nov 17 10:39:54 1997   dcg
CPVCS    remove obsolete code
CPVCS
CPVCS       Rev 1.37   Fri Oct 31 10:51:32 1997   dcg
CPVCS    declare ipcmoprm as a pointer
CPVCS
CPVCS       Rev 1.36   Mon Apr 14 17:06:20 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.35   Mon Apr 14 16:15:38 1997   llt
CPVCS    No change.
CPVCS
CPVCS       Rev 1.34   Fri May 24 16:10:10 1996   dcg
CPVCS    fix dimension on vels, get rid of int
CPVCS
CPVCS       Rev 1.33   Sat Mar 09 10:28:38 1996   dcg
CPVCS    replace hollerith in format statements
CPVCS
CPVCS       Rev 1.32   Tue Mar 05 12:50:34 1996   dcg
CPVCS    remove int1, icn1
CPVCS
CPVCS       Rev 1.31   Mon Feb 26 13:44:54 1996   dcg
CPVCS    fixed bug with printing velocities
CPVCS
CPVCS       Rev 1.30   Fri Feb 23 16:38:10 1996   dcg
CPVCS    use dictionary to retrieve velocity names
CPVCS
CPVCS       Rev 1.29   Mon Feb 12 16:15:56 1996   dcg
CPVCS    list option works for added attributes
CPVCS    rank is now looked at for added attributes
CPVCS
CPVCS       Rev 1.28   11/20/95 09:10:08   dcg
CPVCS    test for npoints=0 then return
CPVCS
CPVCS       Rev 1.27   11/17/95 15:21:54   dcg
CPVCS    replace literal character strings in calls
CPVCS
CPVCS       Rev 1.26   11/16/95 15:23:06   dcg
CPVCS    replace character literals in calls
CPVCS
CPVCS       Rev 1.25   11/07/95 17:29:16   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.24   09/29/95 09:13:00   het
CPVCS    Put in added attributes inheritance
CPVCS
CPVCS       Rev 1.23   09/19/95 08:43:48   dcg
CPVCS    allow integer type for added attribute
CPVCS
CPVCS       Rev 1.22   09/18/95 19:43:42   dcg
CPVCS    look for mesh object added attributes
CPVCS
CPVCS       Rev 1.21   08/31/95 11:54:12   dcg
CPVCS    fix default points limits (ipointi,ipointj)
CPVCS
CPVCS       Rev 1.20   08/29/95 12:15:32   dcg
CPVCS    set length for names to 40 characters
CPVCS
CPVCS       Rev 1.19   08/23/95 06:59:40   het
CPVCS    Remove the CMO prefix from SB-ids
CPVCS
CPVCS       Rev 1.18   08/22/95 06:51:36   het
CPVCS    Split the storage block for CMO variables.
CPVCS
CPVCS       Rev 1.17   07/17/95 16:00:24   dcg
CPVCS    use names for point types
CPVCS
CPVCS       Rev 1.16   07/15/95 02:21:20   het
CPVCS    Correct an error with ipointi and ipointj
CPVCS
CPVCS       Rev 1.15   06/27/95 16:38:48   dcg
CPVCS    remove second literal argument in memory management calls
CPVCS
CPVCS       Rev 1.14   06/20/95 15:41:52   dcg
CPVCS    remove character literals from arguments list to hgetprt
CPVCS
CPVCS       Rev 1.13   06/19/95 16:43:58   dcg
CPVCS    add blank after literal in calling sequence to savpart
CPVCS
CPVCS       Rev 1.12   06/13/95 09:04:22   ejl
CPVCS    Cleaned up msgtty, calling arguments.
CPVCS
CPVCS
CPVCS       Rev 1.11   06/07/95 15:32:34   het
CPVCS    Change character*32 idsb to character*132 idsb
CPVCS
CPVCS       Rev 1.10   05/15/95 13:36:56   het
CPVCS    Make changes to the regset and surfset routines
CPVCS
CPVCS       Rev 1.9   05/01/95 08:37:00   het
CPVCS    Modifiy all the storage block calles for long names
CPVCS
CPVCS       Rev 1.8   03/31/95 09:11:30   het
CPVCS    Add the buildid calles before all storage block calls
CPVCS
CPVCS       Rev 1.7   03/30/95 05:01:02   het
CPVCS    Change the storage block id packing and preidsb to buildid for long names
CPVCS
CPVCS       Rev 1.6   03/23/95 22:59:44   het
CPVCS    Add the model routines and add the cmo name into the idsbs
CPVCS
CPVCS       Rev 1.5   03/23/95 15:08:54   dcg
CPVCS     Add mesh object name to storage block id for surface,region info.
CPVCS
CPVCS       Rev 1.4   03/10/95 17:12:50   dcg
CPVCS     put in mesh object calls
CPVCS
CPVCS       Rev 1.3   02/18/95 06:57:38   het
CPVCS    Changed the parameter list to be the same as pntlimc
CPVCS
CPVCS       Rev 1.2   01/04/95 22:06:46   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.1   12/19/94 08:27:34   het
CPVCS    Add the "comdict.h" include file.
CPVCS
CPVCS
CPVCS       Rev 1.0   11/10/94 12:20:42   pvcs
CPVCS    Original version.
C
c
c#######################################################################
c
c
c#######################################################################
c
      integer nplen
      parameter (nplen=1000000)
c
      character*132 logmess
 
c
      pointer (ipisetwd, isetwd)
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      pointer (ipicr1, icr1)
      pointer (ipisn1, isn1)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      integer isetwd(nplen)
      integer imt1(nplen), itp1(nplen),
     *        icr1(nplen), isn1(nplen)
      real*8 xic(nplen), yic(nplen), zic(nplen)
      pointer ( ipmpary1 , mpary1(1) )
      integer mpary1
 
c
      pointer ( ipies , ies1(1) )
      pointer ( iptmes , tmes1(1) )
      pointer ( ipits , its1(1) )
      pointer ( iptmts , tmts1(1) )
      pointer ( ipips , ips1(1) )
      pointer ( iptmps , tmps1(1) )
      pointer ( ipivs , ivs1(1) )
      pointer ( iptmvs , tmvs1(1) )
      pointer (ip,out)
      real*8 out(*)
c
      integer nwds, imsgin(nwds), msgtype(nwds)
      REAL*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
      integer ierror
C
      character*32 isubname,cnamz
      character*32 ich1,ich2,ich3, cmo, crank, ctype
 
      pointer(ipxfield,xfield)
      real*8 xfield(1000000)
      pointer(ipxfield,ifield)
      pointer (ipvels,vels)
      real*8 vels(3,1000000)
      integer ifield(1000000)
C
      character*32 iword, iword1, cvelnm
      character*8 cpart
      character*132 iformat
      real*8 tmdvs,tmdss,uradius,radius,emat,rho,pmat,prad,tmat,trad,
     *  wa,va,ua,rout,xa,ya,za,tmdps,tmdts,tmvs1,tmps1,tmts1,
     * tmes1
      integer ivs,ips,its,iss,nptstmp,iout,isn,nn2,nn1,irb,ihb,itp,imt,
     * isq,ier2,ier,lin,itin,ier1,irank,ierror_return,j1,i1,len,
     * icharlnf,icr,if1,if2,i,mpno,ipt1,ipt2,ipt3,itype,icscode,ipointi,
     * ipointj,mmrel2,iunpk,iprt5,iprt4,iprt1,iprt2,iprt3,ihead1,
     * ihead2,ihead3,ihead4,ihead5,ierr,ityp,icmotype,length,npoints,
     * ierrw,ivs1,ips1,l,iatt_index,ilen,ntets,ies1,its1
      character*32 cio,cpers,cinter,clen
 
c
c#######################################################################
c
c
c     ******************************************************************
c
c     set the memory management path name to be the subroutine name.
c
      isubname='zq'
      cnamz='zq2'
      cpart='part'
      isubname='zq'
c
c  get mesh object
      call cmo_get_name(cmo,ierror)
      if(ierror.ne.0) then
        write(logmess,'(a)') 'ZQ found bad mesh object'
        call writloga('default',0,logmess,0,ierrw)
        go to 9999
      endif
C
      call cmo_get_info('nnodes',cmo,
     *                  npoints,length,icmotype,ierror)
c  check that there are points -- if none return
      if(npoints.eq.0) then
        write(logmess,'(a)') 'npoints = 0 in subroutine z'
        call writloga('default',0,logmess,0,ierrw)
        go to 9999
      endif
      call cmo_get_info('nelements',cmo,
     *                  ntets,length,icmotype,ierror)
      call cmo_get_info('isetwd',cmo,
     *                  ipisetwd,ilen,ityp,ierr)
      call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr)
      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierr)
      call cmo_get_info('icr1',cmo,ipicr1,ilen,ityp,ierr)
      call cmo_get_info('isn1',cmo,ipisn1,ilen,ityp,ierr)
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr)
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr)
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr)
c     initialize some variables.
c
      ihead1=0
      ihead2=0
      ihead3=0
      ihead4=0
      ihead5=0
      iprt1=0
      iprt2=0
      iprt3=0
      iprt4=0
      iprt5=0
      iunpk=0
      mmrel2=0
c
c     ******************************************************************
c
c     set the point index boundaries.
c
      ipointi=0
      ipointj=0
      call cmo_get_info('ipointi',cmo,ipointi,ilen,itype,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_info('ipointj',cmo,ipointj,ilen,itype,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
C
      if(msgtype(3).eq.1.and.imsgin(3).eq.0) then
         imsgin(3)=max(1,ipointi)
      endif
      if(msgtype(4).eq.1.and.imsgin(4).eq.0) then
         if(ipointj.le.0.or.imsgin(3).eq.1) then
            imsgin(4)=npoints
         else
            imsgin(4)=ipointj
         endif
      endif
      if(msgtype(5).eq.1.and.imsgin(5).eq.0) then
         imsgin(5)=1
      endif
C
      ich1=' '
      ich2=' '
      ich3=' '
      if(msgtype(3).eq.1) then
        ipt1=max(1,min(imsgin(3),npoints))
        ipt2=max(1,min(imsgin(4),npoints))
        ipt3=max(1,min(imsgin(5),npoints))
      else
        ich1=cmsgin(3)
        ich2=cmsgin(4)
        ich3=cmsgin(5)
      endif
c
c     ******************************************************************
c
c     check point limits and translate to valid limits if necessary.
c
      length=npoints
      call mmgetblk('mpary1',isubname,ipmpary1,length,2,icscode)
      if(msgtype(3).eq.1) then
         call pntlimn(ipt1,ipt2,ipt3,ipmpary1,mpno,npoints,isetwd,itp1)
      elseif(msgtype(3).ne.1) then
         call pntlimc(ich1,ich2,ich3,ipmpary1,mpno,npoints,isetwd,itp1)
      endif
c
c     ******************************************************************
c
c     set requested values for mass points.
c
      do 100 j1=1,mpno
         i1=mpary1(j1)
         iword=cmsgin(2)
         len=icharlnf(iword)
c
c        _______________________________________________________________
c
c        write data for points.
c
         if(iword(1:len).eq.'all') then
            iprt1=1
            iprt2=1
            iprt3=1
            goto 9995
         endif
         if(iword(1:len).eq.'imt') then
            len=len+1
            iword(1:len)='imt1'
         endif
         if(iword(1:len).eq.'isn') then
            len=len+1
            iword(1:len)='isn1'
         endif
c
c
c        set type in common.
c
         if(iword(1:len).eq.'itp'.or.iword(1:len).eq.'itp1') then
            ierror=0
            if(nwds.lt.6) then
               iprt1=1
               goto 9995
            endif
            if(msgtype(6).eq.1) then
              itp1(i1)=imsgin(6)
            elseif (msgtype(6).eq.3) then
               call getptyp(cmsgin(6),itp1(i1),ierror)
               if (ierror.ne.0) call x3d_error(isubname,'getptyp')
            else
               write(logmess,'(a30)') 'illegal argument in zq command'
               call writloga ('default',0,logmess,0,ierr)
            endif
            goto 9998
         endif
c
c
c        set constriants index in common.
c
         if(iword(1:len).eq.'icr'.or.iword(1:len).eq.'icr1') then
            ierror=0
            if(nwds.lt.6) then
               iprt1=1
               goto 9995
            endif
            if(msgtype(6).le.2) then
               icr=imsgin(6)
            elseif(msgtype(6).eq.3) then
               iword=cmsgin(6)
               if1=5
               if2=8
               do 120 i=if1,if2
                  if(iword(i:i).eq.' ') then
                     iformat=' '
                     write(iformat,"('(a',i1,',i',i1,')')") if1-1,i-if1
                     goto 121
                  endif
 120           continue
 121           continue
               read(iword,iformat) iword1,icr
            endif
            icr1(i1)=imsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set xyz-coordinates.
c
         if(iword(1:len).eq.'xyz') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            xic(i1)=xmsgin(6)
            yic(i1)=xmsgin(7)
            zic(i1)=xmsgin(8)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set x-coordinate.
c
         if(iword(1:len).eq.'x'.or.iword(1:len).eq.'xic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            xic(i1)=xmsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set y-coordinate.
c
         if(iword(1:len).eq.'y'.or.iword(1:len).eq.'yic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            yic(i1)=xmsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set z-coordinate.
c
         if(iword(1:len).eq.'z'.or.iword(1:len).eq.'zic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            zic(i1)=xmsgin(6)
            goto 9998
         endif
c        _______________________________________________________________
c      look for added attribute
c
         if(nwds.le.5) then
           iprt1=1
           iprt2=1
           go to 9995
         endif
         if(j1.eq.1) then
            call  cmo_get_attparam(iword,cmo,iatt_index,ctype,crank,
     *      clen,cinter,cpers,cio,ierror_return)
            if(icscode.eq.0) then
C   found existing attribute
               if(ctype(1:4).eq.'VINT') ityp=1
               if(ctype(1:7).eq.'VDOUBLE') ityp=2
               call mmgetpr(iword(1:len),cmo,ipxfield,icscode)
               call cmo_get_info(crank,cmo,irank,lin,itin,ier1)
            else
               write(logmess,9005) iword(1:len),cmo
               call writloga('default',0,logmess,0,ierrw)
               go to 9998
            endif
         endif
         ierror=0
         if((j1.eq.1.and.icscode.eq.0.and.ier.eq.0.and.ier1.eq.0.and.
     *            ier2.eq.0).or.j1.ne.1) then
            if(msgtype(6).eq.2) then
               do l=1,irank
                  xfield((i1-1)*irank+l)=xmsgin(6)
               enddo
            elseif(msgtype(6).eq.1) then
               do l=1,irank
                  ifield((i1-1)*irank+l)=imsgin(6)
               enddo
            elseif(nwds.lt.6) then
               do l=1,irank
                  if(ityp.eq.1) write(logmess,'(i6,i6)') i1,
     *                 ifield((i1-1)*irank+l)
                  if(ityp.eq.2) write(logmess,'(i6,e10.3)') i1,
     *                 xfield((i1-1)*irank+l)
                  call writloga('default',0,logmess,0,ierrw)
               enddo
            endif
         else
            write(logmess,9005) iword(1:len),cmo
 9005       format(' zq cannot find attribute ',a,' in ',a)
            call writloga('default',0,logmess,0,ierrw)
            go to 9997
         endif
c        _______________________________________________________________
c
c        invalid option used if this location reached.
c
         goto 9998
c
c        _______________________________________________________________
c
c        write point data to log files.
c
 9995    continue
c
         ierror=0
         if(ihead1.eq.0) then
            ihead1=1
            if(iprt1.eq.1) then
               write(logmess,9000)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead2.eq.0) then
            ihead2=1
            if(iprt2.eq.1) then
               write(logmess,9030)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead3.eq.0) then
            ihead3=1
            if(iprt3.eq.1) then
               write(logmess,9050)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead4.eq.0) then
            ihead4=1
            if(iprt4.eq.1) then
               write(logmess,9070)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         isq=0
         imt=imt1(i1)
         itp=itp1(i1)
         ihb=0
         irb=0
         nn1=0
         nn2=0
Cdcg     int=int1(i1)
         icr=icr1(i1)
Cdcg     icn=icn1(i1)
         isn=isn1(i1)
c
         if(iprt1.eq.1) then
            write(logmess,9010) i1,isq,imt,itp,icr,isn
            call writloga('default',0,logmess,0,ierr)
         endif
         if(iprt2.eq.1) then
            xa=xic(i1)
            ya=yic(i1)
            za=zic(i1)
            if(j1.eq.1)
     *        call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *         ip,length,itype,ier)
            if(ier.eq.0.and.j1.eq.1)
     *        call cmo_get_info(cvelnm,cmo,ipvels,length,itype,ier)
            if(ier.eq.0) then
               ua=vels(1,i1)
               va=vels(2,i1)
               wa=vels(3,i1)
            else
               ua=0.
               va=0.
               wa=0.
            endif
            write(logmess,9040) i1,xa,ya,za,ua,va,wa
            call writloga('default',0,logmess,0,ierr)
         endif
Cdcg     pmat=pic(i1)
Cdcg     rho=ric(i1)
Cdcg     emat=eic(i1)
         tmat=0.0
         trad=0.0
         prad=0.0
         if(iprt3.eq.1) then
            write(logmess,9040) i1,rho,emat,tmat,trad,pmat,prad
            call writloga('default',0,logmess,0,ierr)
         endif
c
         if(iprt4.eq.1) then
            radius=sqrt(xic(i1)*xic(i1)+yic(i1)*yic(i1)
     *              +zic(i1)*zic(i1) )
            call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *       ip,length,itype,ier)
            call cmo_get_info(cvelnm,cmo,ipvels,length,itype,ier)
            if(ier.eq.0) then
               uradius=
     *          sqrt(vels(1,i1)*vels(1,i1)+vels(2,i1)*vels(2,i1)
     *              +vels(3,i1)*vels(3,i1) )
            else
               uradius=0.
            endif
            write(logmess,9040) i1,radius,uradius
            call writloga('default',0,logmess,0,ierr)
         endif
 
        if(iprt5.eq.1) then
           if(nptstmp.le.0) then
              write(logmess,9082)
              call writloga('default',0,logmess,0,ierr)
9082          format('no source points have been assigned.')
           else
             iss=ies1(i1)
              tmdss=tmes1(i1)
              its=its1(i1)
              tmdts=tmts1(i1)
              ips=ips1(i1)
              tmdps=tmps1(i1)
              ivs=ivs1(i1)
              tmdvs=tmvs1(i1)
              write(logmess,9080) i1,iss,tmdss,its,tmdts,ips,tmdps,ivs,
     *                            tmdvs
              call writloga('default',0,logmess,0,ierr)
9080          format(i5,2x,4(i4,2x,1pe12.4))
           endif
        endif
 9000    format('      ipt',' isq',' imt',' itp',' icr',' isn')
 9010    format(i9,4i4,i9)
 9030    format(1x,'ipt',9x,'xa',10x,'ya',10x,'za',
     *                         10x,'ua',10x,'va',10x,'wa')
 9040    format(i5,2x,6(1pe12.4))
 9050    format(1x,'ipt',8x,'rho ',8x,'emat',8x,'tmat',
     *                         8x,'trad',8x,'pmat',8x,'prad')
 9070    format(1x,'ipt',5x,'radius',4x,'velocity')
         goto 9998
 9998    continue
c
c        _______________________________________________________________
c
 100  continue
c
c     ******************************************************************
c
c     release any local memory allocated for this routine.
c
 9997 call mmrelblk('mpary1',isubname,ipmpary1,icscode)
c
c     if (mmrel2 .ne. 0) call mmrelprt(cnamz, ics)
c
c
c     ******************************************************************
c
c     error returns transfer to this statement 9999
c
      goto 9999
 9999 continue
c
c     ******************************************************************
c
      return
      end
 
