initial upload
This commit is contained in:
875
src/cmo_copyatt.f
Executable file
875
src/cmo_copyatt.f
Executable file
@@ -0,0 +1,875 @@
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user