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