876 lines
31 KiB
Fortran
Executable File
876 lines
31 KiB
Fortran
Executable File
c#######################################################################
|
|
|
|
subroutine cmo_copyatt(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
|
|
implicit none
|
|
c
|
|
c#######################################################################
|
|
c
|
|
c purpose -
|
|
c
|
|
c this routine copies an attribute field to another
|
|
c (see also subroutine copyatt_mpary_lg below)
|
|
c
|
|
c there is currently no provision for indexed sets
|
|
c
|
|
c copy element to node: ! Not for 2 different mesh objects !
|
|
c This routine allows the value of an element attribute
|
|
c to be copied to each of the element's node vertices.
|
|
C It is assumed that each element has its own set of node points.
|
|
c These chains can be formed by using cmo/set_id and settets.
|
|
c An error messege will be displayed indicating two attributes
|
|
c with differing lengths, this can be ignored for this option.
|
|
c
|
|
c ..........................................................
|
|
c syntax -
|
|
c
|
|
c cmo/copyatt / cmosink /cmo_src/ attnam_sink / attnam_src
|
|
c
|
|
c cmosink attnam_sink - is the cmo and attribute
|
|
c that values will be written to
|
|
c cmo_src attnam_src - is the cmo and attribute
|
|
c that values will be copied from
|
|
c
|
|
c examples:
|
|
c
|
|
c cmo / copyatt / cmosnk / cmosrc / itetclr / itetclr
|
|
c cmo / copyatt / cmosnk / cmosrc / itetclr
|
|
c - both versions will copy itetclr field from cmosrc to cmosnk
|
|
c
|
|
c cmo / addatt / cmosnk / elevation
|
|
c cmo / copyatt / cmosnk cmosrc / elevation zic /
|
|
c - will copy the zic field of cmosrc to the
|
|
c elevation field of cmosnk
|
|
c
|
|
c reserved words -all- -xyx- nnode nelement are recognized
|
|
c
|
|
c cmo / copyatt / cmo / cmo / itetsav / itetclr
|
|
c cmo set_id cmo element itetclr
|
|
c settets color_points
|
|
c resetpts itp
|
|
c settets
|
|
c cmo /copyatt / cmo / cmo / imt / itetsav
|
|
c - copy element itetclr values into itetsav
|
|
c assign itetclr its element number
|
|
c set parent-child chains so each elem has own set of nodes
|
|
c copy the saved element values to each element node imt
|
|
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: cmo_copyatt.f,v $
|
|
C Revision 2.00 2007/11/05 19:45:48 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.7 17 Jun 2004 10:11:44 gable
|
|
CPVCS Allow copy of node attribute into an element attribute
|
|
CPVCS or element attribute into a node attribute, if and only
|
|
CPVCS if they have the same lenght.
|
|
CPVCS
|
|
CPVCS Rev 1.6 28 Nov 2001 18:37:16 tam
|
|
CPVCS Allow value of an element attribute to be copied
|
|
CPVCS to each of the element's node vertices.
|
|
CPVCS is assumed that each element has its own set
|
|
CPVCS of parent-child chains.
|
|
CPVCS
|
|
CPVCS Rev 1.5 07 Aug 2001 13:47:20 dcg
|
|
CPVCS use same pointer for character attributes as others
|
|
CPVCS
|
|
CPVCS Rev 1.4 Thu Feb 03 08:49:42 2000 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.3 Tue Feb 01 13:46:30 2000 dcg
|
|
CPVCS
|
|
CPVCS Rev 1.4 20 Jan 2000 10:11:16 jtg
|
|
CPVCS fixed Log line, changes is_network to jtet_cycle_max
|
|
CPVCS
|
|
CPVCS Rev 1.2 Wed Dec 01 13:34:16 1999 jtg
|
|
CPVCS added Log line
|
|
CPVCS Initial revision.
|
|
|
|
c
|
|
c#######################################################################
|
|
c
|
|
include "local_element.h"
|
|
c
|
|
c#######################################################################
|
|
c
|
|
c
|
|
!not used! pointer ( ipmpary1 , mpary1)
|
|
!not used! integer mpary1
|
|
|
|
c pointer (ipisetwd,isetwd), (ipxtetwd,xtetwd)
|
|
c integer itp1(*),isetwd(*),xtetwd(*)
|
|
|
|
integer nwds, imsgin(nwds), msgtype(nwds)
|
|
REAL*8 xmsgin(nwds)
|
|
character*(*) cmsgin(nwds)
|
|
C
|
|
integer nlen_copy,icmotype,ierror,ilen,lentyp_snk
|
|
|
|
integer indxtyp, i,idx,nen,ipt, inxt, ilast, istart, iend
|
|
c integer ipt_start, ipt_stride, ipointi, ipointj
|
|
integer ics,ierr,ier2,ierrw,
|
|
* len,ier,lentyp_src,itin,attlen,
|
|
* ipt1,ipt2,ipt3, ipt1_sav,ipt2_sav,ipt3_sav,
|
|
* k,i1,i2,l, elem_to_vertices,
|
|
* ityp,itotal,nset,ivalue
|
|
c integer mpno,ifound,imin,imax
|
|
|
|
integer attyp,attyp2
|
|
integer irank_src,irank_sink,index,index2
|
|
integer nelem_src,nnode_src,nnode_snk,nelem_snk
|
|
c
|
|
c real*8 xvalue,xmin,xmax
|
|
integer printopt
|
|
integer NOWRITE, VALUES, LIST, MINMAX
|
|
logical ivalid, mmset
|
|
integer icharlnf
|
|
c
|
|
pointer (ipitet, itet)
|
|
pointer (ipitettyp, itettyp)
|
|
pointer (ipitetoff, itetoff)
|
|
integer itet(*),itettyp(*),itetoff(*)
|
|
c
|
|
pointer(ipxvalsink,xvalsink)
|
|
pointer(ipxvalsrc,xvalsrc)
|
|
pointer(ipxvalsink,cvalsink)
|
|
pointer(ipxvalsrc,cvalsrc)
|
|
pointer(ipxvalsink,ivalsink)
|
|
pointer(ipxvalsrc,ivalsrc)
|
|
real*8 xvalsink(*),xvalsrc(*)
|
|
integer ivalsrc(*),ivalsink(*)
|
|
|
|
c
|
|
character*32 attnam, attnam2
|
|
character*32 csrcnam, csnknam
|
|
character*32 isubname
|
|
character*32 ich1,ich2,ich3
|
|
character*32 cmosrc,crank,clength,ctype,cinter,cpers,cio2,cio
|
|
character*32 cmosink, ctype2,crank2,clength2,cinter2,cpers2
|
|
character*32 cvalsrc(*),cvalsink(*)
|
|
character*132 logmess, cbuff
|
|
|
|
data NOWRITE, VALUES, LIST, MINMAX /0,1,2,3/
|
|
c
|
|
c
|
|
c#######################################################################
|
|
c
|
|
c
|
|
c ******************************************************************
|
|
c
|
|
isubname = 'cmo_copyatt'
|
|
mmset = .false.
|
|
printopt = NOWRITE
|
|
indxtyp = 1
|
|
ierror = 1
|
|
elem_to_vertices = 0
|
|
|
|
C
|
|
c ******************************************************************
|
|
c
|
|
C Parse the required commands
|
|
c 1 2 3 4 5 6
|
|
c cmo / copyatt / cmosink / cmosrc / sink_att / src_att
|
|
c or
|
|
c cmo / copyatt / cmosink / cmosrc / sink and src att
|
|
c
|
|
c ******************************************************************
|
|
|
|
ilast=nwds
|
|
|
|
c 3 - get mesh object sink
|
|
if (msgtype(3).eq.3) then
|
|
cmosink=cmsgin(3)
|
|
ilen=icharlnf(cmosink)
|
|
if (cmosink(1:ilen).eq.'-def-') then
|
|
call cmo_get_name(cmosink,ierror)
|
|
if(ierror.ne.0) then
|
|
write(logmess,'(a)') 'CMO found bad mesh object'
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
endif
|
|
else
|
|
ierr=1
|
|
goto 9991
|
|
endif
|
|
|
|
c 4 - get mesh object source
|
|
if (msgtype(4).eq.3) then
|
|
cmosrc=cmsgin(4)
|
|
ilen=icharlnf(cmosrc)
|
|
if (cmosrc(1:ilen).eq.'-def-') then
|
|
call cmo_get_name(cmosrc,ierror)
|
|
if(ierror.ne.0) then
|
|
write(logmess,'(a)') 'CMO ADDATT: found bad mesh object'
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
endif
|
|
else
|
|
ierr=1
|
|
goto 9991
|
|
endif
|
|
|
|
inxt = 5
|
|
c 5 - get sink attribute
|
|
if (nwds.gt.4 .and. msgtype(5).eq.3 ) then
|
|
attnam2 = cmsgin(5)
|
|
inxt = inxt+1
|
|
else
|
|
attnam2 = '-all-'
|
|
endif
|
|
|
|
c 6 - get source attribute if different from sink
|
|
if (nwds.gt.5 .and. msgtype(6).eq.3) then
|
|
attnam = cmsgin(6)
|
|
inxt = inxt+1
|
|
else
|
|
attnam = attnam2
|
|
endif
|
|
|
|
|
|
C Not implemented yet
|
|
C define users selected point set
|
|
ipt1=1
|
|
ipt2=0
|
|
ipt3=0
|
|
ich1=' '
|
|
ich2=' '
|
|
ich3=' '
|
|
if (inxt.le.ilast) then
|
|
if (ilast.ge.inxt .and. msgtype(inxt).eq.1 ) then
|
|
ipt1=imsgin(inxt)
|
|
inxt=inxt+1
|
|
if (ilast.ge.inxt .and. msgtype(inxt).eq.1 ) ipt2=imsgin(inxt)
|
|
inxt=inxt+1
|
|
if (ilast.ge.inxt .and. msgtype(inxt).eq.1 ) ipt3=imsgin(inxt)
|
|
indxtyp=1
|
|
elseif (ilast.ge.inxt .and. msgtype(inxt).eq.3) then
|
|
ich1=cmsgin(inxt)
|
|
inxt=inxt+1
|
|
if (ilast.ge.inxt .and. msgtype(inxt).eq.3 ) ich2=cmsgin(inxt)
|
|
inxt=inxt+1
|
|
if (ilast.ge.inxt .and. msgtype(inxt).eq.3 ) ich3=cmsgin(inxt)
|
|
indxtyp=3
|
|
write(logmess,'(a)') 'CMO ADDATT: point set not implemented.'
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
endif
|
|
ierr=0
|
|
9991 if (ierr.ne.0) then
|
|
write(logmess,'(a)')'cmo/copyatt: not a valid syntax'
|
|
call writloga('default',0,logmess,1,ierrw)
|
|
goto 9999
|
|
endif
|
|
|
|
C ******************************************************************
|
|
C END Parse commands
|
|
|
|
c check mesh cmo's
|
|
c the mesh objects must have nodes -- if none return
|
|
c both mesh objects must have nodes
|
|
c they do not need to have elements
|
|
c set nnode_src and nelem_src lengths to copy from
|
|
|
|
call cmo_get_info('nnodes',cmosink,nnode_snk,ilen,icmotype,ierr)
|
|
call cmo_get_info('nnodes',cmosrc,nnode_src,ilen,icmotype,ier2)
|
|
if (ierr.ne.0 .or. ier2 .ne. 0)
|
|
* call x3d_error('cmo get_info nnodes',isubname)
|
|
|
|
if(nnode_src.eq.0) then
|
|
write(logmess,'(a,a)')'nnode source = 0 in cmo ',cmosrc
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
if(nnode_snk.eq.0) then
|
|
write(logmess,'(a,a)')'nnode sink = 0 in cmo ',cmosink
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
|
|
call cmo_get_info('nelements',cmosink,nelem_snk,ilen,icmotype,ier)
|
|
call cmo_get_info('nelements',cmosrc,nelem_src,ilen,icmotype,ier2)
|
|
if(nelem_src.eq.0) then
|
|
write(logmess,'(a,a)')'Warning: nelements = 0 in cmo ',cmosrc
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
endif
|
|
if(nelem_snk.eq.0) then
|
|
write(logmess,'(a,a)')'Warning: nelements = 0 in cmo ',cmosink
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
endif
|
|
|
|
c figure out loop through all attributes
|
|
c usually this is one to one, but we support multiple attribute copy
|
|
istart = 1
|
|
if (attnam(1:5).eq.'nnode' .or. attnam(1:8).eq.'nelement' .or.
|
|
* attnam(1:5).eq.'-all-' ) then
|
|
call cmo_get_info('number_of_attributes',cmosrc,iend,
|
|
* ilen,ityp,ierror)
|
|
if (ierror.ne.0) call x3d_error(isubname,'number_of_attributes')
|
|
|
|
elseif (attnam(1:5).eq.'-xyz-') then
|
|
iend = 3
|
|
else
|
|
iend = 1
|
|
endif
|
|
|
|
c ******************************************************************
|
|
C loop through all cmo attributes
|
|
C usually 1 to 1, but also -all-, nnode, nelement, or -xyz-
|
|
C take action on those chosen by user
|
|
|
|
itotal=0
|
|
ivalid=.false.
|
|
ipt1_sav=ipt1
|
|
ipt2_sav=ipt2
|
|
ipt3_sav=ipt3
|
|
|
|
do i = istart, iend
|
|
ier=0
|
|
nset=0
|
|
|
|
C ................................................................
|
|
C decide if there is output for this attribute based on src cmo
|
|
|
|
if(attnam(1:5).eq.'-all-') then
|
|
c ...get name for each of all attributes except scalar
|
|
|
|
call cmo_get_attribute_name(cmosrc,i,csrcnam,ier)
|
|
call cmo_get_attparam(csrcnam,cmosrc,index,ctype,crank
|
|
* ,clength,cinter,cpers,cio,ierror)
|
|
if (clength(1:6).eq.'scalar' ) then
|
|
write(logmess,'( a,a,a,a )')
|
|
* 'CMO_COPYATT: Uncopied attribute: ',
|
|
* cmosrc(1:icharlnf(cmosrc)), ' ',
|
|
* csrcnam(1:icharlnf(csrcnam))
|
|
call writloga('default',0,logmess,0,ierr)
|
|
else
|
|
ivalid=.true.
|
|
csnknam = csrcnam
|
|
endif
|
|
|
|
elseif(attnam(1:5).eq.'nnode') then
|
|
c ...get name for each of attributes of length nnode
|
|
|
|
call cmo_get_attribute_name(cmosrc,i,csrcnam,ier)
|
|
call cmo_get_attparam(csrcnam,cmosrc,index,ctype,crank,
|
|
* clength,cinter,cpers,cio,ierror)
|
|
csnknam = csrcnam
|
|
if (clength(1:4).eq.'nnod') ivalid=.true.
|
|
|
|
elseif(attnam(1:8).eq.'nelement') then
|
|
c ...copy all attributes of length nelement
|
|
inxt = inxt+2
|
|
call cmo_get_attribute_name(cmosrc,i,csrcnam,ier)
|
|
call cmo_get_attparam(csrcnam,cmosrc,index,ctype,crank,
|
|
* clength,cinter,cpers,cio,ierror)
|
|
csnknam = csrcnam
|
|
if (clength(1:4).eq.'nele') ivalid=.true.
|
|
|
|
elseif(attnam(1:5).eq.'-xyz-' .and. i.eq.1) then
|
|
c ...get the coordinate names
|
|
|
|
csrcnam='xic'
|
|
csnknam = csrcnam
|
|
ivalid=.true.
|
|
elseif(attnam(1:5).eq.'-xyz-' .and. i.eq.2) then
|
|
csrcnam='yic'
|
|
csnknam = csrcnam
|
|
ivalid=.true.
|
|
elseif(attnam(1:5).eq.'-xyz-' .and. i.eq.3) then
|
|
csrcnam='zic'
|
|
csnknam = csrcnam
|
|
ivalid=.true.
|
|
else
|
|
csrcnam=attnam
|
|
csnknam=attnam2
|
|
ivalid=.true.
|
|
|
|
c to avoid problems with sbnloc not recognizing att name
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'imt')csrcnam='imt1'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'itp')csrcnam='itp1'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'icr')csrcnam='icr1'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'isn')csrcnam='isn1'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'ign')csrcnam='ign1'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'xic1')csrcnam='xic'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'yic1')csrcnam='yic'
|
|
if(csrcnam(1:icharlnf(csrcnam)).eq.'zic1')csrcnam='zic'
|
|
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'imt')csnknam='imt1'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'itp')csnknam='itp1'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'icr')csrcnam='icr1'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'isn')csnknam='isn1'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'ign')csnknam='ign1'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'xic1')csnknam='xic'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'yic1')csnknam='yic'
|
|
if(csnknam(1:icharlnf(csnknam)).eq.'zic1')csnknam='zic'
|
|
|
|
endif
|
|
if (ier.ne.0) goto 9999
|
|
|
|
C ................................................................
|
|
C get attributes based on current csrcnam and csnknam
|
|
if (ivalid) then
|
|
|
|
C SOURCE CMO STORAGE
|
|
c get block name, pointer,mem name, and len of attribute
|
|
call cmo_get_attparam(csrcnam,cmosrc,index,ctype,crank,
|
|
* clength,cinter,cpers,cio,ierror)
|
|
|
|
if(ierror.eq.0) then
|
|
c ...attribute exists
|
|
len=icharlnf(csrcnam)
|
|
else
|
|
c ...can not copy from non-existing attribute
|
|
write(logmess,'(a,a,a)')
|
|
* 'CMO_COPYATT error: attribute does not exist: ',
|
|
* cmosrc, csrcnam
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
endif
|
|
|
|
C SINK CMO STORAGE
|
|
C get length and adjust sink cmo attribute if needed
|
|
c for now warn user so they can define cmo, add code here late
|
|
call cmo_get_attparam(csnknam,cmosink,index2,ctype2,crank2,
|
|
* clength2,cinter2,cpers2,cio2,ierror)
|
|
|
|
if(ierror.eq.0) then
|
|
c ...attribute exists
|
|
len=icharlnf(csnknam)
|
|
else
|
|
c ...need to create attribute in sink cmo
|
|
write(logmess,'(a,a,a)')
|
|
* 'CMO_COPYATT WARNING: attribute does not exist:
|
|
* attribute now created: ', csnknam
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
call cmo_get_attparam(csrcnam,cmosrc,index,ctype,crank,
|
|
* clength,cinter,cpers,cio,ierror)
|
|
cbuff = 'cmo/addatt/' // cmosink(1:icharlnf(cmosink)) //
|
|
* '/' // csnknam(1:icharlnf(csnknam)) // '/'
|
|
* // ctype(1:icharlnf(ctype)) // '/'
|
|
* // crank(1:icharlnf(crank)) // '/'
|
|
* // clength(1:icharlnf(clength)) // '/'
|
|
* // cinter(1:icharlnf(cinter)) // '/'
|
|
* // cpers(1:icharlnf(cpers)) // '/'
|
|
* // cio(1:icharlnf(cio)) // ';finish'
|
|
call dotaskx3d(cbuff, ierror)
|
|
call cmo_get_attparam(csnknam,cmosink,index2,ctype2,crank2,
|
|
* clength2,cinter2,cpers2,cio2,ierror)
|
|
endif
|
|
|
|
C Done getting Storage Block info for attributes
|
|
c get mesh object type=attyp, length=lentyp_src and rank=irank_src
|
|
c ...attributes exist, continue definitions
|
|
|
|
C SET lentyp_snk and lentyp_src to detirmine copy type
|
|
call cmo_get_info(clength2,cmosink,attlen,ityp,itin,ierror)
|
|
if(clength2(1:6).eq.'nnodes') lentyp_snk=1
|
|
if(clength2(1:9).eq.'nelements') lentyp_snk=2
|
|
if(clength2(1:6).eq.'scalar') lentyp_snk=3
|
|
|
|
call cmo_get_info(clength,cmosrc,attlen,ityp,itin,ierror)
|
|
if(clength(1:6).eq.'nnodes') lentyp_src=1
|
|
if(clength(1:9).eq.'nelements') lentyp_src=2
|
|
if(clength(1:6).eq.'scalar') lentyp_src=3
|
|
|
|
c some of this is reported below so this may be redundant
|
|
if (lentyp_src.ne.lentyp_snk) then
|
|
if((lentyp_snk .eq. 1).and.(lentyp_src .eq. 2)) then
|
|
if(nnode_snk .eq. nelem_src)then
|
|
call x3d_error('WARNING:copy element att into node att ',
|
|
* isubname)
|
|
else
|
|
call x3d_error('incompatible att length types for ',
|
|
* isubname)
|
|
endif
|
|
elseif((lentyp_snk .eq. 2).and.(lentyp_src .eq. 1)) then
|
|
if(nnode_src .eq. nelem_snk)then
|
|
call x3d_error('WARNING:copy node att into elem att ',
|
|
* isubname)
|
|
else
|
|
call x3d_error('incompatible att length types for ',
|
|
* isubname)
|
|
endif
|
|
else
|
|
call x3d_error('incompatible att length types for ',
|
|
* isubname)
|
|
endif
|
|
endif
|
|
|
|
C SET attyp and attyp2 for copy of int, real, or char
|
|
|
|
if (ctype(1:1).ne.'V') then
|
|
c ...type for source attribute not found
|
|
write(logmess,'(a,a)')
|
|
* 'CMO_COPYATT: attribute type not found for ',
|
|
* csrcnam(1:icharlnf(csrcnam))
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
endif
|
|
if (ctype2(1:1).ne.'V') then
|
|
c ...type for sink attribute not found
|
|
write(logmess,'(a,a)')
|
|
* 'CMO_COPYATT: attribute type not found for ',
|
|
* csnknam(1:icharlnf(csnknam))
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
endif
|
|
|
|
if(ctype(1:4).eq.'VINT') then
|
|
attyp=1
|
|
elseif(ctype(1:7).eq.'VDOUBLE') then
|
|
attyp=2
|
|
elseif(ctype(1:7).eq.'VCHAR') then
|
|
attyp=4
|
|
else
|
|
attyp=3
|
|
ctype='UNKNOWN'
|
|
endif
|
|
if(ctype2(1:4).eq.'VINT') then
|
|
attyp2=1
|
|
elseif(ctype2(1:7).eq.'VDOUBLE') then
|
|
attyp2=2
|
|
elseif(ctype2(1:7).eq.'VCHAR') then
|
|
attyp2=4
|
|
else
|
|
attyp2=3
|
|
ctype2='UNKNOWN'
|
|
endif
|
|
|
|
if (attyp.ne.attyp2) then
|
|
write(logmess,'(a,a,a,a)')
|
|
* 'Warning: Attribute type ',ctype(1:7),' written to ',
|
|
* ctype2(1:7)
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
endif
|
|
|
|
c SET RANK FIELD for attributes
|
|
call cmo_get_info(crank,cmosink,irank_sink,ilen,itin,ier)
|
|
if (ier.ne.0) call x3d_error('get sink rank:',isubname)
|
|
if (ier.ne.0) goto 9999
|
|
call cmo_get_info(crank2,cmosrc,irank_src,ilen,itin,ierr)
|
|
if (ierr.ne.0) call x3d_error('get source rank:',isubname)
|
|
if (ierr.ne.0) goto 9999
|
|
if (irank_src .ne. irank_sink) then
|
|
call x3d_error('incompatible att ranks for ',isubname)
|
|
goto 9999
|
|
endif
|
|
|
|
C SET pointers to attributes
|
|
C report if error, continue if this is a loop, otherwise return
|
|
|
|
len=icharlnf(csnknam)
|
|
call mmgetpr(csnknam(1:len),cmosink,ipxvalsink,ics)
|
|
if (ics.ne.0) then
|
|
call x3d_error('mmgetpr sink value',isubname)
|
|
if (iend.eq.1) then
|
|
write(logmess,'(a,a,a)')
|
|
* 'CMO_COPYATT ERROR: can not get attribute pointer: ',
|
|
* cmosink, csnknam
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
endif
|
|
endif
|
|
|
|
len=icharlnf(csrcnam)
|
|
call mmgetpr(csrcnam(1:len),cmosrc,ipxvalsrc,ics)
|
|
if (ics.ne.0) then
|
|
call x3d_error('mmgetpr source value',isubname)
|
|
if (iend.eq.1) then
|
|
write(logmess,'(a,a,a)')
|
|
* 'CMO_COPYATT ERROR: can not get attribute pointer: ',
|
|
* cmosrc, csrcnam
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9999
|
|
endif
|
|
endif
|
|
ierror=0
|
|
|
|
C ................................................................
|
|
c check length and combinations to copy
|
|
|
|
if(lentyp_src.eq.1 .and. lentyp_snk.eq.1) then
|
|
c ...node to node
|
|
|
|
nlen_copy=nnode_src
|
|
|
|
c ...if sink points are less than source
|
|
if (nnode_snk .lt. nnode_src) then
|
|
nlen_copy=nnode_snk
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink nodes lt source nodes by ',nnode_src-nnode_snk
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink points are greater than source
|
|
elseif (nnode_snk .gt. nnode_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink nodes gt source nodes by ',nnode_snk-nnode_src
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
|
|
elseif(lentyp_src.eq.2 .and. lentyp_snk.eq.2) then
|
|
c ...element to element
|
|
|
|
nlen_copy=nelem_src
|
|
if (nelem_src.le.0) then
|
|
write(logmess,'(a,a)')' 0 element attribute: ',csrcnam
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
goto 9998
|
|
endif
|
|
|
|
c ...if sink elements are less than source
|
|
if (nelem_snk .lt. nelem_src) then
|
|
nlen_copy=nelem_snk
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink elems lt source elems by ',nelem_src-nelem_snk
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink elements are greater than source
|
|
elseif (nelem_snk .gt. nelem_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink elems gt source elems by ',nelem_snk-nelem_src
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
|
|
c non-standard combinations give warnings and pick smallest length
|
|
elseif(lentyp_src.eq.1 .and. lentyp_snk.eq.2) then
|
|
c ...node to element
|
|
|
|
nlen_copy=nnode_src
|
|
|
|
c ...if sink elements are less than source points
|
|
if (nelem_snk .lt. nnode_src) then
|
|
nlen_copy=nelem_snk
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink elems lt source nodes by ',nnode_src-nelem_snk
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink elements are greater than source points
|
|
elseif (nelem_snk .gt. nnode_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink nodes gt source nodes by ',nelem_snk-nnode_src
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink elements are equal to source points
|
|
elseif (nelem_snk .eq. nnode_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'sink elements and source nodes are equal length: ',nlen_copy
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
|
|
c non-standard combinations give warnings and pick smallest length
|
|
|
|
elseif(lentyp_src.eq.2 .and. lentyp_snk.eq.1) then
|
|
c ...element to node (where cmo sink differs from cmo source)
|
|
C !!!! element into node is done below (element to vertice copy) !!!!
|
|
|
|
c first check if this should go into special case element to vertice
|
|
c otherwise copy here
|
|
|
|
nlen_copy=nelem_src
|
|
|
|
if ( cmosrc(1:icharlnf(cmosrc)) .eq.
|
|
* cmosink(1:icharlnf(cmosink)) ) then
|
|
|
|
elem_to_vertices = 1
|
|
print*,'Special Copy...'
|
|
|
|
else
|
|
|
|
elem_to_vertices = 0
|
|
|
|
c ...if sink nodes are less than source elements
|
|
if (nnode_snk .lt. nelem_src) then
|
|
nlen_copy=nnode_snk
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink nodes lt source elements by ',nelem_src-nnode_snk
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink nodes are greater than source elements
|
|
elseif (nnode_snk .gt. nelem_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'Warning: sink nodes gt source elements by ',nnode_snk-nelem_src
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
c ...if sink elements are equal to source points
|
|
elseif (nnode_snk .eq. nelem_src) then
|
|
write(logmess,'(a,i5)')
|
|
* 'sink elements and source nodes are equal length: ',nlen_copy
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
endif
|
|
|
|
elseif(lentyp_src.eq.3) then
|
|
c ...scalar type
|
|
|
|
nlen_copy=1
|
|
|
|
else
|
|
c ...unknown type index to selected set combination
|
|
nlen_copy=0
|
|
endif
|
|
|
|
c pset not supported - for now start is 1 and stride is 1
|
|
ipt1 = 1
|
|
ipt2 = nlen_copy
|
|
ipt3 = 1
|
|
c .............................................END selected set
|
|
|
|
if (nlen_copy.le.0) then
|
|
len=icharlnf(csrcnam)
|
|
write(logmess,'(a,a)')
|
|
* 'CMO ADDATT ERROR: copy length is 0 from source ',csrcnam(1:len)
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
go to 9999
|
|
endif
|
|
|
|
c COPY LOOP
|
|
c Copy valid src attribute to current sink attribute
|
|
|
|
C ***************************************************************
|
|
C COPY ATTRIBUTE VALUES
|
|
if (ivalid .and. elem_to_vertices.eq.0 ) then
|
|
|
|
nset=0
|
|
do k=1,nlen_copy
|
|
|
|
do l=1,irank_src
|
|
i1=(k-1)*irank_src+l
|
|
i2=(k-1)*irank_sink+l
|
|
|
|
if(attyp.eq.2 .and. attyp2.eq.2 ) then
|
|
xvalsink(i2) = xvalsrc(i1)
|
|
nset=nset+1
|
|
elseif(attyp.eq.1 .and. attyp2.eq.1 ) then
|
|
ivalsink(i2) = ivalsrc(i1)
|
|
nset=nset+1
|
|
elseif(attyp.eq.1 .and. attyp2.eq.2 ) then
|
|
xvalsink(i2) = ivalsrc(i1)
|
|
nset=nset+1
|
|
elseif(attyp.eq.2 .and. attyp2.eq.1 ) then
|
|
ivalsink(i2) = xvalsrc(i1)
|
|
nset=nset+1
|
|
elseif(attyp.eq.4 .and. attyp2.eq.4 ) then
|
|
cvalsink(i2) = cvalsrc(i1)
|
|
nset=nset+1
|
|
elseif(attyp.eq.3) then
|
|
call cmo_set_info(attnam,cmosrc,ivalue,1,1,
|
|
* ierror)
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
write(logmess,'(i10,a,a,a,a,a,a,a,a)')
|
|
* nset,' copied from ',cmosrc(1:icharlnf(cmosrc)),' ',
|
|
* csrcnam(1:icharlnf(csrcnam)),
|
|
* ' to -> ',cmosink(1:icharlnf(cmosink)),' ',
|
|
* csnknam(1:icharlnf(csnknam))
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
endif
|
|
|
|
c ...............................................................
|
|
c END COPY loop for attributes
|
|
|
|
9998 ivalid=.false.
|
|
if (mmset) then
|
|
call mmrelprt(isubname,ics)
|
|
mmset=.false.
|
|
endif
|
|
c
|
|
enddo
|
|
c ******************************************************************
|
|
c END Loop through all possible attributes
|
|
|
|
C NOTE, Special case - this is outside of the loop through attributes
|
|
C Loop through elements
|
|
C Allow element attribute to be copied to vertice node attribute
|
|
C if each element has valid parent-child chains
|
|
C parent points are not assigned a value
|
|
C
|
|
9990 if ( elem_to_vertices .eq. 1 ) then
|
|
|
|
nlen_copy=nelem_src
|
|
|
|
call cmo_get_info('itettyp',cmosrc,ipitettyp,ilen,ityp,ierr)
|
|
if(ierr.ne.0) call x3d_error(isubname,'get_info itettyp')
|
|
call cmo_get_info('itet',cmosrc,ipitet,ilen,ityp,ierr)
|
|
if(ierr.ne.0) call x3d_error(isubname,'get_info itet')
|
|
call cmo_get_info('itetoff',cmosrc,ipitetoff,ilen,ityp,ierr)
|
|
if(ierr.ne.0) call x3d_error(isubname,'get_info itetoff')
|
|
|
|
len=icharlnf(csnknam)
|
|
call mmgetpr(csnknam(1:len),cmosink,ipxvalsink,ics)
|
|
if (ics.ne.0) call x3d_error('mmgetpr sink value',isubname)
|
|
len=icharlnf(csrcnam)
|
|
call mmgetpr(csrcnam(1:len),cmosrc,ipxvalsrc,ics)
|
|
if (ics.ne.0) call x3d_error('mmgetpr source value',isubname)
|
|
ierror=0
|
|
|
|
do idx = 1, nlen_copy
|
|
nen=nelmnen(itettyp(idx))
|
|
do i=1,nen
|
|
ipt=itet(itetoff(idx)+i)
|
|
if(ctype(2:4).eq.'DOU' .and. ctype2(2:4).eq.'DOU' ) then
|
|
xvalsink(ipt) = xvalsrc(idx)
|
|
nset=nset+1
|
|
elseif(ctype(2:4).eq.'INT' .and. ctype2(2:4).eq.'INT' ) then
|
|
ivalsink(ipt) = ivalsrc(idx)
|
|
nset=nset+1
|
|
elseif(ctype(2:4).eq.'INT' .and. ctype2(2:4).eq.'DOU' ) then
|
|
xvalsink(ipt) = ivalsrc(idx)
|
|
nset=nset+1
|
|
elseif(ctype(2:4).eq.'DOU' .and. ctype2(2:4).eq.'INT' ) then
|
|
ivalsink(ipt) = xvalsrc(idx)
|
|
nset=nset+1
|
|
elseif(ctype(2:4).eq.'CHA' .and. ctype2(2:4).eq.'CHA' ) then
|
|
cvalsink(ipt) = cvalsrc(idx)
|
|
nset=nset+1
|
|
else
|
|
call cmo_set_info(attnam,cmosrc,ivalue,1,1,ierror)
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
write(logmess,'(i10,a,a,a,a,a,a,a,a)')
|
|
* nset,' copied from ',cmosrc(1:icharlnf(cmosrc)),
|
|
* ' element ',csrcnam(1:icharlnf(csrcnam)),
|
|
* ' to -> ',cmosink(1:icharlnf(cmosink)),
|
|
* ' node vertices ',csnknam(1:icharlnf(csnknam))
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
|
|
endif
|
|
c ******************************************************************
|
|
c END Loop through elements for special elem to vertice copy
|
|
|
|
logmess = ' '
|
|
call writloga('default',0,logmess,0,ierrw)
|
|
if (mmset) call mmrelprt(isubname,ics)
|
|
|
|
c error returns transfer to this statement 9999
|
|
goto 9999
|
|
9999 continue
|
|
c
|
|
return
|
|
end
|
|
|